From 73145db0d23a5e35ecf98235a76996a29d7631f7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 16:08:35 -0700 Subject: [PATCH 01/76] Add Location pt 2 --- .../src/Unison/Codebase/Path.hs | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index b911e276f3..839e50a8c7 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -5,7 +5,12 @@ module Unison.Codebase.Path Path' (..), Absolute (..), pattern AbsolutePath', + absPath_, + Location (..), + locAbsPath_, + locPath_, Relative (..), + relPath_, pattern RelativePath', Resolve (..), pattern Empty, @@ -89,14 +94,28 @@ import Data.Sequence (Seq ((:<|), (:|>))) import Data.Sequence qualified as Seq import Data.Text qualified as Text import GHC.Exts qualified as GHC +import Unison.Core.Project (ProjectBranchName) import Unison.HashQualified' qualified as HQ' import Unison.Name (Convert (..), Name, Parse) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude hiding (empty, toList) +import Unison.Project (ProjectName) import Unison.Syntax.Name qualified as Name (toText, unsafeParseText) import Unison.Util.List qualified as List +data Location + = Location ProjectName ProjectBranchName Absolute + +locAbsPath_ :: Lens' Location Absolute +locAbsPath_ = lens go set + where + go (Location _ _ p) = p + set (Location n b _) p = Location n b p + +locPath_ :: Lens' Location Path +locPath_ = locAbsPath_ . absPath_ + -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] newtype Path = Path {toSeq :: Seq NameSegment} deriving stock (Eq, Ord) @@ -111,8 +130,14 @@ instance GHC.IsList Path where newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) +absPath_ :: Lens' Absolute Path +absPath_ = lens unabsolute (\_ new -> Absolute new) + newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord) +relPath_ :: Lens' Relative Path +relPath_ = lens unrelative (\_ new -> Relative new) + newtype Path' = Path' {unPath' :: Either Absolute Relative} deriving (Eq, Ord) From fe751e168557e7843fc8c14aaea3f95df31c09fb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 16:12:06 -0700 Subject: [PATCH 02/76] Remove direct access to root branch --- unison-cli/src/Unison/Cli/Monad.hs | 59 ++++++++++--------------- unison-cli/src/Unison/Cli/MonadUtils.hs | 6 +-- 2 files changed, 26 insertions(+), 39 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 0ef993cc27..6ccbff582e 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -14,6 +14,7 @@ module Unison.Cli.Monad -- * Immutable state LoopState (..), loopState0, + getCurrentLocation, -- * Lifting IO actions ioE, @@ -52,22 +53,20 @@ module Unison.Cli.Monad where import Control.Exception (throwIO) -import Control.Lens (lens, (.=)) +import Control.Lens import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Strict (MonadState) import Control.Monad.State.Strict qualified as State import Data.Configurator.Types qualified as Configurator import Data.List.NonEmpty qualified as List (NonEmpty) import Data.List.NonEmpty qualified as List.NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (diffAbsoluteTime) import Data.Unique (Unique, newUnique) -import GHC.OverloadedLabels (IsLabel (..)) import System.CPUTime (getCPUTime) import Text.Printf (printf) -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) @@ -76,10 +75,10 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) +import Unison.Codebase.Path (locAbsPath_) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug -import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.CodebaseServer qualified as Server @@ -179,10 +178,9 @@ data Env = Env -- -- There's an additional pseudo @"currentPath"@ field lens, for convenience. data LoopState = LoopState - { root :: TMVar (Branch IO), - lastSavedRootHash :: CausalHash, - -- the current position in the namespace - currentPathStack :: List.NonEmpty Path.Absolute, + { currentBranch :: TMVar (Branch IO), + -- the current position in the codebase, with the head being the most recent lcoation. + locationStack :: List.NonEmpty Path.Location, -- TBD -- , _activeEdits :: Set Branch.EditGuid @@ -207,26 +205,12 @@ data LoopState = LoopState } deriving stock (Generic) -instance - {-# OVERLAPS #-} - (Functor f) => - IsLabel "currentPath" ((Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState)) - where - fromLabel :: (Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState) - fromLabel = - lens - (\LoopState {currentPathStack} -> List.NonEmpty.head currentPathStack) - ( \loopState@LoopState {currentPathStack = _ List.NonEmpty.:| paths} path -> - loopState {currentPathStack = path List.NonEmpty.:| paths} - ) - -- | Create an initial loop state given a root branch and the current path. -loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState -loopState0 lastSavedRootHash b p = do +loopState0 :: TMVar (Branch IO) -> Path.Location -> LoopState +loopState0 b p = do LoopState - { root = b, - lastSavedRootHash = lastSavedRootHash, - currentPathStack = pure p, + { currentBranch = b, + locationStack = pure p, latestFile = Nothing, latestTypecheckedFile = Nothing, lastInput = Nothing, @@ -388,11 +372,13 @@ time label action = ms = ns / 1_000_000 s = ns / 1_000_000_000 +getCurrentLocation :: Cli Path.Location +getCurrentLocation = NonEmpty.head <$> use #locationStack + cd :: Path.Absolute -> Cli () cd path = do - setMostRecentNamespace path - State.modify' \state -> - state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)} + loc <- getCurrentLocation + #locationStack %= NonEmpty.cons (loc & locAbsPath_ .~ path) -- | Pop the latest path off the stack, if it's not the only path in the stack. -- @@ -400,16 +386,17 @@ cd path = do popd :: Cli Bool popd = do state <- State.get - case List.NonEmpty.uncons (currentPathStack state) of + case List.NonEmpty.uncons (locationStack state) of (_, Nothing) -> pure False (_, Just paths) -> do - setMostRecentNamespace (List.NonEmpty.head paths) - State.put state {currentPathStack = paths} + setMostRecentLocation (List.NonEmpty.head paths) + State.put state {locationStack = paths} pure True -setMostRecentNamespace :: Path.Absolute -> Cli () -setMostRecentNamespace = - runTransaction . Queries.setMostRecentNamespace . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute +setMostRecentLocation :: Path.Location -> Cli () +setMostRecentLocation _loc = + -- runTransaction . Queries.setMostRecentLocation . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute + error "Implement setMostRecentLocation" respond :: Output -> Cli () respond output = do diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index ddccf48a2d..f1ef8675b6 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -143,7 +143,7 @@ getConfig key = do -- | Get the current path. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - use #currentPath + view Path.locAbsPath_ <$> Cli.getCurrentLocation -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. resolvePath :: Path -> Cli Path.Absolute @@ -225,8 +225,8 @@ resolveShortCausalHashToCausalHash rollback shortHash = do -- Getting/Setting branches -- | Get the root branch. -getRootBranch :: Cli (Branch IO) -getRootBranch = do +getProjectRootBranch :: Cli (Branch IO) +getProjectRootBranch = do use #root >>= atomically . readTMVar -- | Get the root branch0. From 12b3107cdbb5f9eb5400652eb511fda284bcd8b3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 16:12:06 -0700 Subject: [PATCH 03/76] Add migration to move project branches to sqlite --- .../U/Codebase/Sqlite/ProjectBranch.hs | 5 +++-- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 9 +++++---- .../Unison/Codebase/SqliteCodebase/Migrations.hs | 4 +++- .../Migrations/MigrateSchema16To17.hs | 14 ++++++++++++++ parser-typechecker/unison-parser-typechecker.cabal | 3 ++- 5 files changed, 27 insertions(+), 8 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs index 05b63e7e23..a7059acb32 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs @@ -3,7 +3,7 @@ module U.Codebase.Sqlite.ProjectBranch ) where -import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId) import Unison.Core.Orphans.Sqlite () import Unison.Core.Project (ProjectBranchName) import Unison.Prelude @@ -14,7 +14,8 @@ data ProjectBranch = ProjectBranch { projectId :: !ProjectId, branchId :: !ProjectBranchId, name :: !ProjectBranchName, - parentBranchId :: !(Maybe ProjectBranchId) + parentBranchId :: !(Maybe ProjectBranchId), + rootCausalHash :: !CausalHashId } deriving stock (Eq, Generic, Show) deriving anyclass (ToRow, FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index ab263ef9d5..dc05c3f185 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3525,7 +3525,8 @@ loadProjectBranchSql projectId branchId = project_branch.project_id, project_branch.branch_id, project_branch.name, - project_branch_parent.parent_branch_id + project_branch_parent.parent_branch_id, + project_branch.causal_hash_id FROM project_branch LEFT JOIN project_branch_parent ON project_branch.project_id = project_branch_parent.project_id @@ -3680,11 +3681,11 @@ loadProjectAndBranchNames projectId branchId = -- | Insert a project branch. insertProjectBranch :: ProjectBranch -> Transaction () -insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do +insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId causalHashId) = do execute [sql| - INSERT INTO project_branch (project_id, branch_id, name) - VALUES (:projectId, :branchId, :branchName) + INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) + VALUES (:projectId, :branchId, :branchName, :causalHashId) |] whenJust maybeParentBranchId \parentBranchId -> execute diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 68dc7c0a9f..eec913cb61 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors) import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12) +import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) @@ -81,7 +82,8 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath = sqlMigration 13 Q.addMostRecentNamespaceTable, sqlMigration 14 Q.addSquashResultTable, sqlMigration 15 Q.addSquashResultTableIfNotExists, - sqlMigration 16 Q.cdToProjectRoot + sqlMigration 16 Q.cdToProjectRoot, + sqlMigration 17 migrateSchema16To17 ] where sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ()) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs new file mode 100644 index 0000000000..45c41036a2 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where + +import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Sqlite qualified as Sqlite + +-- | This migration adds the causal_object_id column to the project_branches table. +migrateSchema16To17 :: Sqlite.Transaction () +migrateSchema16To17 = do + Queries.expectSchemaVersion 16 + error "Impelement MigrateSchema16To17.migrateSchema16To17" + Queries.setSchemaVersion 17 diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 512a0093a0..43fd0af0e8 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 @@ -75,6 +75,7 @@ library Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 + Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 From 39f065e65683c60b638dfd3837455dfe8fd6480b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 16:38:05 -0700 Subject: [PATCH 04/76] Propagate root branch accessors --- .../U/Codebase/Sqlite/Operations.hs | 12 ++ .../U/Codebase/Sqlite/ProjectBranch.hs | 2 +- parser-typechecker/src/Unison/Codebase.hs | 28 ++++- .../src/Unison/Codebase/Path.hs | 34 ++--- .../src/Unison/Codebase/ProjectPath.hs | 90 +++++++++++++ parser-typechecker/src/Unison/Project/Util.hs | 18 --- .../unison-parser-typechecker.cabal | 1 + unison-cli/src/Unison/Cli/Monad.hs | 33 ++--- unison-cli/src/Unison/Cli/MonadUtils.hs | 119 ++++++++++-------- .../src/Unison/Codebase/Editor/HandleInput.hs | 73 +++++------ .../Codebase/Editor/HandleInput/Branch.hs | 3 +- .../HandleInput/NamespaceDependencies.hs | 6 +- .../Editor/HandleInput/ProjectClone.hs | 3 +- .../Editor/HandleInput/ProjectCreate.hs | 3 +- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/Propagate.hs | 2 +- unison-cli/src/Unison/CommandLine.hs | 25 ++-- .../src/Unison/CommandLine/Completion.hs | 23 ++-- .../src/Unison/CommandLine/FZFResolvers.hs | 13 +- .../src/Unison/CommandLine/InputPattern.hs | 3 +- .../src/Unison/CommandLine/InputPatterns.hs | 71 ++++------- unison-cli/src/Unison/CommandLine/Main.hs | 51 ++++---- 22 files changed, 345 insertions(+), 270 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/ProjectPath.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 556bb5327f..45b0950619 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -98,6 +98,9 @@ module U.Codebase.Sqlite.Operations fuzzySearchDefinitions, namesPerspectiveForRootAndPath, + -- * Projects + expectProjectAndBranchNames, + -- * reflog getReflog, appendReflog, @@ -181,6 +184,8 @@ import U.Codebase.Sqlite.Patch.TermEdit qualified as S import U.Codebase.Sqlite.Patch.TermEdit qualified as S.TermEdit import U.Codebase.Sqlite.Patch.TypeEdit qualified as S import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference @@ -198,6 +203,7 @@ import U.Codebase.TypeEdit qualified as C.TypeEdit import U.Codebase.WatchKind (WatchKind) import U.Util.Base32Hex qualified as Base32Hex import U.Util.Serialization qualified as S +import Unison.Core.Project (ProjectBranchName, ProjectName) import Unison.Hash qualified as H import Unison.Hash32 qualified as Hash32 import Unison.NameSegment (NameSegment) @@ -1541,3 +1547,9 @@ stripPrefixFromNamedRef (PathSegments prefix) namedRef = Nothing -> reversedName Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath) in namedRef {S.reversedSegments = newReversedName} + +expectProjectAndBranchNames :: Db.ProjectId -> Db.ProjectBranchId -> Transaction (ProjectName, ProjectBranchName) +expectProjectAndBranchNames projectId projectBranchId = do + Project {name = pName} <- Q.expectProject projectId + ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId + pure (pName, bName) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs index a7059acb32..986de3fbb6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs @@ -15,7 +15,7 @@ data ProjectBranch = ProjectBranch branchId :: !ProjectBranchId, name :: !ProjectBranchName, parentBranchId :: !(Maybe ProjectBranchId), - rootCausalHash :: !CausalHashId + causalHashId :: !CausalHashId } deriving stock (Eq, Generic, Show) deriving anyclass (ToRow, FromRow) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 9817a18b45..65608c0c96 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -49,6 +49,8 @@ module Unison.Codebase getShallowCausalFromRoot, getShallowRootBranch, getShallowRootCausal, + getShallowProjectRootBranch, + getShallowBranchAtProjectPath, -- * Root branch getRootBranch, @@ -116,7 +118,10 @@ import U.Codebase.Branch qualified as V2 import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.Operations qualified as Operations +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin qualified as Builtin import Unison.Builtin.Terms qualified as Builtin @@ -128,6 +133,7 @@ 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.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations import Unison.Codebase.Type (Codebase (..), GitError) @@ -214,10 +220,9 @@ getShallowCausalAtPath path mayCausal = do -- Use the root causal if none is provided. getShallowBranchAtPath :: Path -> - Maybe (V2Branch.Branch Sqlite.Transaction) -> + V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowBranchAtPath path mayBranch = do - branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value) +getShallowBranchAtPath path branch = do case path of Path.Empty -> pure branch ns Path.:< p -> do @@ -225,7 +230,22 @@ getShallowBranchAtPath path mayBranch = do Nothing -> pure V2Branch.empty Just childCausal -> do childBranch <- V2Causal.value childCausal - getShallowBranchAtPath p (Just childBranch) + getShallowBranchAtPath p childBranch + +getShallowProjectRootBranch :: Db.ProjectId -> Db.ProjectBranchId -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +getShallowProjectRootBranch projectId projectBranchId = do + ProjectBranch {causalHashId} <- Q.expectProjectBranch projectId projectBranchId + causalHash <- Q.expectCausalHash causalHashId + Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value + +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getShallowBranchAtProjectPath :: + PP.ProjectPathIds -> + Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = do + projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId + getShallowBranchAtPath (Path.unabsolute path) projectRootBranch -- | Get a v1 branch from the root following the given path. getBranchAtPath :: diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 839e50a8c7..3b7a7b483d 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -6,9 +6,6 @@ module Unison.Codebase.Path Absolute (..), pattern AbsolutePath', absPath_, - Location (..), - locAbsPath_, - locPath_, Relative (..), relPath_, pattern RelativePath', @@ -62,6 +59,8 @@ module Unison.Codebase.Path unsafeToName', toText, toText', + absToText, + relToText, unsplit, unsplit', unsplitAbsolute, @@ -94,28 +93,14 @@ import Data.Sequence (Seq ((:<|), (:|>))) import Data.Sequence qualified as Seq import Data.Text qualified as Text import GHC.Exts qualified as GHC -import Unison.Core.Project (ProjectBranchName) import Unison.HashQualified' qualified as HQ' import Unison.Name (Convert (..), Name, Parse) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude hiding (empty, toList) -import Unison.Project (ProjectName) import Unison.Syntax.Name qualified as Name (toText, unsafeParseText) import Unison.Util.List qualified as List -data Location - = Location ProjectName ProjectBranchName Absolute - -locAbsPath_ :: Lens' Location Absolute -locAbsPath_ = lens go set - where - go (Location _ _ p) = p - set (Location n b _) p = Location n b p - -locPath_ :: Lens' Location Path -locPath_ = locAbsPath_ . absPath_ - -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] newtype Path = Path {toSeq :: Seq NameSegment} deriving stock (Eq, Ord) @@ -128,6 +113,7 @@ instance GHC.IsList Path where toList (Path segs) = Foldable.toList segs fromList = Path . Seq.fromList +-- | A path absolute to the current project root newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) absPath_ :: Lens' Absolute Path @@ -166,14 +152,14 @@ absoluteToPath' = AbsolutePath' instance Show Path' where show = \case - AbsolutePath' abs -> show abs - RelativePath' rel -> show rel + AbsolutePath' abs -> Text.unpack $ absToText abs + RelativePath' rel -> Text.unpack $ relToText rel instance Show Absolute where - show s = "." ++ show (unabsolute s) + show s = Text.unpack $ absToText s instance Show Relative where - show = show . unrelative + show = Text.unpack . relToText unsplit' :: Split' -> Path' unsplit' = \case @@ -387,6 +373,12 @@ toText :: Path -> Text toText = maybe Text.empty Name.toText . toName +absToText :: Absolute -> Text +absToText abs = "." <> toText (unabsolute abs) + +relToText :: Relative -> Text +relToText rel = toText (unrelative rel) + unsafeParseText :: Text -> Path unsafeParseText = \case "" -> empty diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs new file mode 100644 index 0000000000..7fd5cfd669 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -0,0 +1,90 @@ +module Unison.Codebase.ProjectPath + ( ProjectPath (..), + ProjectPathIds, + ProjectPathNames, + ProjectPathCtx, + absPath_, + path_, + projectAndBranch_, + toText, + ctxAsIds_, + ctxAsNames_, + project_, + branch_, + ) +where + +import Control.Lens +import Data.Bifoldable (Bifoldable (..)) +import Data.Bitraversable (Bitraversable (..)) +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import Unison.Codebase.Path qualified as Path +import Unison.Prelude +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) + +data ProjectPath proj branch = ProjectPath + { projPathProject :: proj, + projPathBranch :: branch, + projPathPath :: Path.Absolute + } + deriving stock (Eq, Ord, Show) + +type ProjectPathIds = ProjectPath ProjectId ProjectBranchId + +type ProjectPathNames = ProjectPath ProjectName ProjectBranchName + +type ProjectPathCtx = ProjectPath (ProjectId, ProjectName) (ProjectBranchId, ProjectBranchName) + +project_ :: Lens' (ProjectPath p b) p +project_ = lens go set + where + go (ProjectPath p _ _) = p + set (ProjectPath _ b path) p = ProjectPath p b path + +branch_ :: Lens' (ProjectPath p b) b +branch_ = lens go set + where + go (ProjectPath _ b _) = b + set (ProjectPath p _ path) b = ProjectPath p b path + +-- | Project a project context into a project path of just IDs +ctxAsIds_ :: Lens' ProjectPathCtx ProjectPathIds +ctxAsIds_ = lens go set + where + go (ProjectPath (pid, _) (bid, _) p) = ProjectPath pid bid p + set (ProjectPath (_, pName) (_, bName) _) (ProjectPath pid bid p) = ProjectPath (pid, pName) (bid, bName) p + +-- | Project a project context into a project path of just names +ctxAsNames_ :: Lens' ProjectPathCtx ProjectPathNames +ctxAsNames_ = lens go set + where + go (ProjectPath (_, pName) (_, bName) path) = ProjectPath pName bName path + set (ProjectPath (pId, _) (bId, _) _) (ProjectPath pName bName path) = ProjectPath (pId, pName) (bId, bName) path + +instance Bifunctor ProjectPath where + bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path + +instance Bifoldable ProjectPath where + bifoldMap f g (ProjectPath p b _) = f p <> g b + +instance Bitraversable ProjectPath where + bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path + +toText :: ProjectPath ProjectName ProjectBranchName -> Text +toText (ProjectPath projName branchName path) = + into @Text projName <> "/" <> into @Text branchName <> ":" <> Path.absToText path + +absPath_ :: Lens' (ProjectPath p b) Path.Absolute +absPath_ = lens go set + where + go (ProjectPath _ _ p) = p + set (ProjectPath n b _) p = ProjectPath n b p + +path_ :: Lens' (ProjectPath p b) Path.Path +path_ = absPath_ . Path.absPath_ + +projectAndBranch_ :: Lens' (ProjectPath p b) (ProjectAndBranch p b) +projectAndBranch_ = lens go set + where + go (ProjectPath proj branch _) = ProjectAndBranch proj branch + set (ProjectPath _ _ p) (ProjectAndBranch proj branch) = ProjectPath proj branch p diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs index d75f2250a0..edc670c063 100644 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ b/parser-typechecker/src/Unison/Project/Util.hs @@ -5,9 +5,7 @@ module Unison.Project.Util projectBranchSegment, projectPathPrism, projectBranchPathPrism, - projectContextFromPath, pattern UUIDNameSegment, - ProjectContext (..), pattern ProjectsNameSegment, pattern BranchesNameSegment, ) @@ -123,22 +121,6 @@ projectBranchPathPrism = Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath) _ -> Nothing --- | The project information about the current path. --- NOTE: if the user has cd'd into the project storage area but NOT into a branch, (where they shouldn't ever --- be), this will result in a LooseCodePath. -data ProjectContext - = LooseCodePath Path.Absolute - | ProjectBranchPath ProjectId ProjectBranchId Path.Path {- path from branch root -} - deriving stock (Eq, Show) - -projectContextFromPath :: Path.Absolute -> ProjectContext -projectContextFromPath path = - case path ^? projectBranchPathPrism of - Just (ProjectAndBranch {project = projectId, branch = branchId}, restPath) -> - ProjectBranchPath projectId branchId restPath - Nothing -> - LooseCodePath path - pattern ProjectsNameSegment :: NameSegment pattern ProjectsNameSegment <- ((== projectsNameSegment) -> True) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 43fd0af0e8..f57ba4ad5e 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -62,6 +62,7 @@ library Unison.Codebase.Patch Unison.Codebase.Path Unison.Codebase.Path.Parse + Unison.Codebase.ProjectPath Unison.Codebase.PushBehavior Unison.Codebase.RootBranchCache Unison.Codebase.Runtime diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 6ccbff582e..1db18cf12d 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -14,7 +14,7 @@ module Unison.Cli.Monad -- * Immutable state LoopState (..), loopState0, - getCurrentLocation, + getProjectPathIds, -- * Lifting IO actions ioE, @@ -75,8 +75,8 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) -import Unison.Codebase.Path (locAbsPath_) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.Parser.Ann (Ann) @@ -178,9 +178,9 @@ data Env = Env -- -- There's an additional pseudo @"currentPath"@ field lens, for convenience. data LoopState = LoopState - { currentBranch :: TMVar (Branch IO), + { currentProjectRoot :: TMVar (Branch IO), -- the current position in the codebase, with the head being the most recent lcoation. - locationStack :: List.NonEmpty Path.Location, + projectPathStack :: List.NonEmpty PP.ProjectPathIds, -- TBD -- , _activeEdits :: Set Branch.EditGuid @@ -206,11 +206,11 @@ data LoopState = LoopState deriving stock (Generic) -- | Create an initial loop state given a root branch and the current path. -loopState0 :: TMVar (Branch IO) -> Path.Location -> LoopState +loopState0 :: TMVar (Branch IO) -> PP.ProjectPathIds -> LoopState loopState0 b p = do LoopState - { currentBranch = b, - locationStack = pure p, + { currentProjectRoot = b, + projectPathStack = pure p, latestFile = Nothing, latestTypecheckedFile = Nothing, lastInput = Nothing, @@ -372,13 +372,14 @@ time label action = ms = ns / 1_000_000 s = ns / 1_000_000_000 -getCurrentLocation :: Cli Path.Location -getCurrentLocation = NonEmpty.head <$> use #locationStack +getProjectPathIds :: Cli PP.ProjectPathIds +getProjectPathIds = do + NonEmpty.head <$> use #projectPathStack cd :: Path.Absolute -> Cli () cd path = do - loc <- getCurrentLocation - #locationStack %= NonEmpty.cons (loc & locAbsPath_ .~ path) + pp <- getProjectPathIds + #projectPathStack %= NonEmpty.cons (pp & PP.absPath_ .~ path) -- | Pop the latest path off the stack, if it's not the only path in the stack. -- @@ -386,15 +387,15 @@ cd path = do popd :: Cli Bool popd = do state <- State.get - case List.NonEmpty.uncons (locationStack state) of + case List.NonEmpty.uncons (projectPathStack state) of (_, Nothing) -> pure False (_, Just paths) -> do - setMostRecentLocation (List.NonEmpty.head paths) - State.put state {locationStack = paths} + setMostRecentProjectPath (List.NonEmpty.head paths) + State.put state {projectPathStack = paths} pure True -setMostRecentLocation :: Path.Location -> Cli () -setMostRecentLocation _loc = +setMostRecentProjectPath :: PP.ProjectPathIds -> Cli () +setMostRecentProjectPath _loc = -- runTransaction . Queries.setMostRecentLocation . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute error "Implement setMostRecentLocation" diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index f1ef8675b6..beaf3bff77 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -6,6 +6,9 @@ module Unison.Cli.MonadUtils -- * Paths getCurrentPath, + getCurrentProjectName, + getCurrentProjectBranchName, + getProjectPathCtx, resolvePath, resolvePath', resolveSplit', @@ -20,16 +23,14 @@ module Unison.Cli.MonadUtils resolveShortCausalHash, -- ** Getting/setting branches - getRootBranch, - setRootBranch, - modifyRootBranch, - getRootBranch0, + setCurrentProjectRoot, + modifyProjectRoot, + getProjectRoot, + getProjectRoot0, getCurrentBranch, getCurrentBranch0, getBranchAt, getBranch0At, - getLastSavedRootHash, - setLastSavedRootHash, getMaybeBranchAt, getMaybeBranch0At, expectBranchAtPath, @@ -49,7 +50,7 @@ module Unison.Cli.MonadUtils stepManyAtMNoSync, stepManyAtNoSync, syncRoot, - updateRoot, + updateCurrentProjectRoot, updateAtM, updateAt, updateAndStepAt, @@ -94,6 +95,9 @@ import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase @@ -106,6 +110,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.HashQualified qualified as HQ @@ -115,6 +120,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude +import Unison.Project (ProjectBranchName, ProjectName) import Unison.Reference (TypeReference) import Unison.Referent (Referent) import Unison.Sqlite qualified as Sqlite @@ -140,10 +146,28 @@ getConfig key = do ------------------------------------------------------------------------------------------------------------------------ -- Getting paths, path resolution, etc. --- | Get the current path. +getProjectPathCtx :: Cli PP.ProjectPathCtx +getProjectPathCtx = do + (PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds + -- TODO: Reset to a valid project on error. + (Project {name = projName}, ProjectBranch {name = branchName}) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do + project <- MaybeT $ Q.loadProject projId + branch <- MaybeT $ Q.loadProjectBranch projId branchId + pure (project, branch) + pure (PP.ProjectPath (projId, projName) (branchId, branchName) path) + +-- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - view Path.locAbsPath_ <$> Cli.getCurrentLocation + view PP.absPath_ <$> getProjectPathCtx + +getCurrentProjectName :: Cli ProjectName +getCurrentProjectName = do + view (PP.ctxAsNames_ . PP.project_) <$> getProjectPathCtx + +getCurrentProjectBranchName :: Cli ProjectBranchName +getCurrentProjectBranchName = do + view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPathCtx -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. resolvePath :: Path -> Cli Path.Absolute @@ -225,28 +249,28 @@ resolveShortCausalHashToCausalHash rollback shortHash = do -- Getting/Setting branches -- | Get the root branch. -getProjectRootBranch :: Cli (Branch IO) -getProjectRootBranch = do - use #root >>= atomically . readTMVar +getProjectRoot :: Cli (Branch IO) +getProjectRoot = do + use #currentProjectRoot >>= atomically . readTMVar -- | Get the root branch0. -getRootBranch0 :: Cli (Branch0 IO) -getRootBranch0 = - Branch.head <$> getRootBranch +getProjectRoot0 :: Cli (Branch0 IO) +getProjectRoot0 = + Branch.head <$> getProjectRoot -- | Set a new root branch. -- -- Note: This does _not_ update the codebase, the caller is responsible for that. -setRootBranch :: Branch IO -> Cli () -setRootBranch b = do - void $ modifyRootBranch (const b) +setCurrentProjectRoot :: Branch IO -> Cli () +setCurrentProjectRoot b = do + void $ modifyProjectRoot (const b) -- | Modify the root branch. -- -- Note: This does _not_ update the codebase, the caller is responsible for that. -modifyRootBranch :: (Branch IO -> Branch IO) -> Cli (Branch IO) -modifyRootBranch f = do - rootVar <- use #root +modifyProjectRoot :: (Branch IO -> Branch IO) -> Cli (Branch IO) +modifyProjectRoot f = do + rootVar <- use #currentProjectRoot atomically do root <- takeTMVar rootVar let !newRoot = f root @@ -265,17 +289,6 @@ getCurrentBranch0 :: Cli (Branch0 IO) getCurrentBranch0 = do Branch.head <$> getCurrentBranch --- | Get the last saved root hash. -getLastSavedRootHash :: Cli CausalHash -getLastSavedRootHash = do - use #lastSavedRootHash - --- | Set a new root branch. --- Note: This does _not_ update the codebase, the caller is responsible for that. -setLastSavedRootHash :: CausalHash -> Cli () -setLastSavedRootHash ch = do - #lastSavedRootHash .= ch - -- | Get the branch at an absolute path. getBranchAt :: Path.Absolute -> Cli (Branch IO) getBranchAt path = @@ -289,7 +302,7 @@ getBranch0At path = -- | Get the maybe-branch at an absolute path. getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO)) getMaybeBranchAt path = do - rootBranch <- getRootBranch + rootBranch <- getProjectRoot pure (Branch.getAt (Path.unabsolute path) rootBranch) -- | Get the maybe-branch0 at an absolute path. @@ -394,9 +407,9 @@ stepManyAtNoSync' :: f (Path, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepManyAtNoSync' actions = do - origRoot <- getRootBranch + origRoot <- getProjectRoot newRoot <- Branch.stepManyAtM actions origRoot - setRootBranch newRoot + setCurrentProjectRoot newRoot pure (origRoot /= newRoot) -- Like stepManyAt, but doesn't update the last saved root @@ -405,7 +418,7 @@ stepManyAtNoSync :: f (Path, Branch0 IO -> Branch0 IO) -> Cli () stepManyAtNoSync actions = - void . modifyRootBranch $ Branch.stepManyAt actions + void . modifyProjectRoot $ Branch.stepManyAt actions stepManyAtM :: (Foldable f) => @@ -421,15 +434,15 @@ stepManyAtMNoSync :: f (Path, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepManyAtMNoSync actions = do - oldRoot <- getRootBranch + oldRoot <- getProjectRoot newRoot <- liftIO (Branch.stepManyAtM actions oldRoot) - setRootBranch newRoot + setCurrentProjectRoot newRoot -- | Sync the in-memory root branch. syncRoot :: Text -> Cli () syncRoot description = do - rootBranch <- getRootBranch - updateRoot rootBranch description + rootBranch <- getProjectRoot + updateCurrentProjectRoot rootBranch description -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise @@ -439,9 +452,9 @@ updateAtM :: (Branch IO -> Cli (Branch IO)) -> Cli Bool updateAtM reason (Path.Absolute p) f = do - b <- getRootBranch + b <- getProjectRoot b' <- Branch.modifyAtM p f b - updateRoot b' reason + updateCurrentProjectRoot b' reason pure $ b /= b' -- | Update a branch at the given path, returning `True` if @@ -464,26 +477,22 @@ updateAndStepAt reason updates steps = do root <- (Branch.stepManyAt steps) . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) - <$> getRootBranch - updateRoot root reason + <$> getProjectRoot + updateCurrentProjectRoot root reason -updateRoot :: Branch IO -> Text -> Cli () -updateRoot new reason = - Cli.time "updateRoot" do +updateCurrentProjectRoot :: Branch IO -> Text -> Cli () +updateCurrentProjectRoot new reason = + Cli.time "updateCurrentProjectRoot" do Cli.Env {codebase} <- ask - let newHash = Branch.headHash new - oldHash <- getLastSavedRootHash - when (oldHash /= newHash) do - liftIO (Codebase.putRootBranch codebase reason new) - setRootBranch new - setLastSavedRootHash newHash + liftIO (Codebase.putRootBranch codebase reason new) + setCurrentProjectRoot new ------------------------------------------------------------------------------------------------------------------------ -- Getting terms getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent) getTermsAt path = do - rootBranch0 <- getRootBranch0 + rootBranch0 <- getProjectRoot0 pure (BranchUtil.getTerm (Path.convert path) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ @@ -491,7 +500,7 @@ getTermsAt path = do getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference) getTypesAt path = do - rootBranch0 <- getRootBranch0 + rootBranch0 <- getProjectRoot0 pure (BranchUtil.getType (Path.convert path) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 7e5352675c..b9fdbe0201 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -147,7 +147,6 @@ import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) 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 qualified as Reference import Unison.Referent (Referent) @@ -401,7 +400,7 @@ loop e = do Left hash -> Cli.resolveShortCausalHash hash Right path' -> Cli.expectBranchAtPath' path' description <- inputDescription input - Cli.updateRoot newRoot description + Cli.updateCurrentProjectRoot newRoot description Cli.respond Success ForkLocalBranchI src0 dest0 -> do (srcb, branchEmpty) <- @@ -520,7 +519,7 @@ loop e = do let elem = (Branch.headHash b, Branch.namesDiff b' b) doHistory schLength (n + 1) b' (elem : acc) UndoI -> do - rootBranch <- Cli.getRootBranch + rootBranch <- Cli.getProjectRoot (_, prev) <- liftIO (Branch.uncons rootBranch) & onNothingM do Cli.returnEarly . CantUndo $ @@ -528,7 +527,7 @@ loop e = do then CantUndoPastStart else CantUndoPastMerge description <- inputDescription input - Cli.updateRoot prev description + Cli.updateCurrentProjectRoot prev description (ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch) Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff) UiI path' -> openUI path' @@ -602,7 +601,7 @@ loop e = do -- this implementation will happily produce name conflicts, -- but will surface them in a normal diff at the end of the operation. AliasManyI srcs dest' -> do - root0 <- Cli.getRootBranch0 + root0 <- Cli.getProjectRoot0 currentBranch0 <- Cli.getCurrentBranch0 destAbs <- Cli.resolvePath' dest' old <- Cli.getBranch0At destAbs @@ -658,11 +657,11 @@ loop e = do fixupOutput = fmap Path.unsafeToName . HQ'.toHQ . Path.unsplitHQ NamesI global query -> do hqLength <- Cli.runTransaction Codebase.hashLength - root <- Cli.getRootBranch (names, pped) <- if global || any Name.isAbsolute query then do - let root0 = Branch.head root + -- TODO: Use some global names index here + root0 <- Cli.getProjectRoot0 -- Use an absolutely qualified ppe for view.global let names = Names.makeAbsolute $ Branch.toNames root0 let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names) @@ -735,15 +734,7 @@ loop e = do description (BranchUtil.makeDeletePatch (Path.convert src)) Cli.respond Success - DeleteTarget'Namespace insistence Nothing -> do - hasConfirmed <- confirmedCommand input - if hasConfirmed || insistence == Force - then do - description <- inputDescription input - Cli.updateRoot Branch.empty description - Cli.respond DeletedEverything - else Cli.respond DeleteEverythingConfirmation - DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do + DeleteTarget'Namespace insistence p@(parentPath, childName) -> do branch <- Cli.expectBranchAtPath' (Path.unsplit' p) description <- inputDescription input absPath <- Cli.resolveSplit' p @@ -752,7 +743,7 @@ loop e = do (Path.unsafeToName (Path.unsplit (Path.convert absPath))) (Branch.toNames (Branch.head branch)) afterDelete <- do - rootNames <- Branch.toNames <$> Cli.getRootBranch0 + rootNames <- Branch.toNames <$> Cli.getProjectRoot0 endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty rootNames) case (null endangerments, insistence) of (True, _) -> pure (Cli.respond Success) @@ -1039,20 +1030,19 @@ loop e = do Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms DebugTabCompletionI inputs -> do Cli.Env {authHTTPClient, codebase} <- ask - currentPath <- Cli.getCurrentPath - let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath + ppCtx <- Cli.getProjectPathCtx + let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient ppCtx (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "") Cli.respond (DisplayDebugCompletions completions) DebugFuzzyOptionsI command args -> do Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0 - let projCtx = projectContextFromPath currentPath case Map.lookup command InputPatterns.patternMap of Just (IP.InputPattern {args = argTypes}) -> do zip argTypes args & Monoid.foldMapM \case ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do - results <- liftIO $ getOptions codebase projCtx currentBranch + ppCtx <- Cli.getProjectPathCtx + results <- liftIO $ getOptions codebase ppCtx currentBranch Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do Cli.respond DebugFuzzyOptionsNoResolver @@ -1123,13 +1113,13 @@ loop e = do prettyRef renderR r = P.indentN 2 $ P.text (renderR r) prettyDefn renderR (r, Foldable.toList -> names) = P.lines (P.text <$> if null names then [""] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r - rootBranch <- Cli.getRootBranch - void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch] + projectRoot <- Cli.getProjectRoot + void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot] DebugDumpNamespaceSimpleI -> do - rootBranch0 <- Cli.getRootBranch0 - for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) -> + projectRootBranch0 <- Cli.getProjectRoot0 + for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) -> traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r) - for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) -> + for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) -> traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r) DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName DebugLSPFoldRangesI -> do @@ -1274,10 +1264,10 @@ inputDescription input = thing <- traverse hqs' thing0 pure ("delete.type.verbose " <> Text.intercalate " " thing) DeleteTarget'Namespace Try opath0 -> do - opath <- ops' opath0 + opath <- ps' opath0 pure ("delete.namespace " <> opath) DeleteTarget'Namespace Force opath0 -> do - opath <- ops' opath0 + opath <- ps' opath0 pure ("delete.namespace.force " <> opath) DeleteTarget'Patch path0 -> do path <- ps' path0 @@ -1410,8 +1400,6 @@ 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 wat = error $ show input ++ " is not expected to alter the branch" @@ -1458,10 +1446,11 @@ handleFindI isVerbose fscope ws input = do pped <- Cli.currentPrettyPrintEnvDecl pure (pped, names, Just p, branch0) FindGlobal -> do - globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0 - pped <- Cli.prettyPrintEnvDeclFromNames globalNames + -- TODO: Rewrite to be properly global again + projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getProjectRoot0 + pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames currentBranch0 <- Cli.getCurrentBranch0 - pure (pped, globalNames, Nothing, currentBranch0) + pure (pped, projectRootNames, Nothing, currentBranch0) let suffixifiedPPE = PPED.suffixifiedPPE pped let getResults :: Names -> Cli [SearchResult] getResults names = @@ -1666,16 +1655,16 @@ handleShowDefinition outputLoc showDefinitionScope query = do hqLength <- Cli.runTransaction Codebase.hashLength let hasAbsoluteQuery = any (any Name.isAbsolute) query (names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of - -- If any of the queries are absolute, use global names. -- TODO: We should instead print each definition using the names from its project-branch root. (True, _) -> do - root <- Cli.getRootBranch + root <- Cli.getProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names pure (names, pped) (_, ShowDefinitionGlobal) -> do - root <- Cli.getRootBranch + -- TODO: Maybe rewrite to be properly global + root <- Cli.getProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names @@ -1970,9 +1959,7 @@ checkDeletes typesTermsTuples doutput inputs = do toRel setRef name = R.fromList (fmap (name,) (toList setRef)) let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames -- make sure endangered is compeletely contained in paths - -- TODO: We should just check for endangerments from the project root, not the - -- global root! - rootNames <- Branch.toNames <$> Cli.getRootBranch0 + projectNames <- Branch.toNames <$> Cli.getProjectRoot0 -- get only once for the entire deletion set let allTermsToDelete :: Set LabeledDependency allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete) @@ -1981,7 +1968,7 @@ checkDeletes typesTermsTuples doutput inputs = do Cli.runTransaction $ traverse ( \targetToDelete -> - getEndangeredDependents targetToDelete (allTermsToDelete) rootNames + getEndangeredDependents targetToDelete (allTermsToDelete) projectNames ) toDelete -- If the overall dependency map is not completely empty, abort deletion @@ -2005,7 +1992,7 @@ checkDeletes typesTermsTuples doutput inputs = do DeleteOutput'NoDiff -> do Cli.respond Success else do - ppeDecl <- Cli.prettyPrintEnvDeclFromNames rootNames + ppeDecl <- Cli.prettyPrintEnvDeclFromNames projectNames let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs) @@ -2066,7 +2053,7 @@ displayI outputLoc hq = do (names, pped) <- if useRoot then do - root <- Cli.getRootBranch + root <- Cli.getProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 4e740830cb..9ca57e574e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -151,7 +151,8 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = parentBranchId + parentBranchId = parentBranchId, + rootCausalHash = error "TODO: implement doCreateBranch" } Queries.setMostRecentBranch projectId newBranchId pure newBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index f812df39ba..88b75a289b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -43,11 +43,11 @@ handleNamespaceDependencies namespacePath' = do externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) currentPPED <- Cli.currentPrettyPrintEnvDecl - globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0 - globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames + rootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getProjectRoot0 + rootPPED <- Cli.prettyPrintEnvDeclFromNames rootNames -- We explicitly include a global unsuffixified fallback on namespace dependencies since -- the things we want names for are obviously outside of our scope. - let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback globalPPED currentPPED + let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback rootPPED currentPPED Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies -- | Check the dependencies of all types and terms in the current namespace, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index a459b343bf..a0cc253bde 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -259,7 +259,8 @@ cloneInto localProjectBranch remoteProjectBranch = do { projectId = localProjectId, branchId = localBranchId, name = localProjectBranch.branch, - parentBranchId = Nothing + parentBranchId = Nothing, + rootCausalHash = error "Add causal hash id in cloneInto" } Queries.insertBranchRemoteMapping localProjectId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 99a90be6f8..90dead6159 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -161,7 +161,8 @@ insertProjectAndBranch projectId projectName branchId branchName = do { projectId, branchId, name = branchName, - parentBranchId = Nothing + parentBranchId = Nothing, + rootCausalHash = error "Add causal hash id in insertProjectAndBranch" } Queries.setMostRecentBranch projectId branchId diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 2cdfb96c13..8c18fd047b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -331,7 +331,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'Namespace Insistence Path.Split' | DeleteTarget'Patch Path.Split' | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | DeleteTarget'Project ProjectName diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index addb8d5de9..c06cd1f71a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -241,7 +241,7 @@ propagate patch b = case validatePatch patch of pure noEdits Just (initialTermEdits, initialTypeEdits) -> do -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent` - rootNames <- Branch.toNames <$> Cli.getRootBranch0 + rootNames <- Branch.toNames <$> Cli.getProjectRoot0 let -- TODO: these are just used for tracing, could be deleted if we don't care -- about printing meaningful names for definitions during propagation, or if diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index f97a25e331..8291b7e9fb 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -26,6 +26,7 @@ module Unison.CommandLine where import Control.Concurrent (forkIO, killThread) +import Control.Lens hiding (aside) import Control.Monad.Except import Control.Monad.Trans.Except import Data.Configurator (autoConfig, autoReload) @@ -42,11 +43,10 @@ import Data.Vector qualified as Vector import System.FilePath (takeFileName) import Text.Regex.TDFA ((=~)) import Unison.Codebase (Codebase) -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.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers import Unison.CommandLine.FuzzySelect qualified as Fuzzy @@ -54,7 +54,6 @@ import Unison.CommandLine.InputPattern (InputPattern (..)) import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Project.Util (ProjectContext, projectContextFromPath) import Unison.Symbol (Symbol) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (foldMapM) @@ -120,8 +119,9 @@ nothingTodo = emojiNote "😶" parseInput :: Codebase IO Symbol Ann -> - -- | Current path from root - Path.Absolute -> + -- | Current location + PP.ProjectPathCtx -> + IO (Branch.Branch IO) -> -- | Numbered arguments [String] -> -- | Input Pattern Map @@ -131,10 +131,11 @@ parseInput :: -- 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))) -parseInput codebase currentPath numberedArgs patterns segments = runExceptT do +parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) - getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath - let projCtx = projectContextFromPath currentPath + getCurrentBranch0 = do + projRoot <- currentProjectRoot + pure . Branch.head $ Branch.getAt' (projPath ^. PP.path_) projRoot case segments of [] -> throwE "" @@ -143,7 +144,7 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let expandedNumbers :: [String] expandedNumbers = foldMap (expandNumber numberedArgs) args - lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case + lift (fzfResolve codebase projPath getCurrentBranch0 pat expandedNumbers) >>= \case Left (NoFZFResolverForArgumentType _argDesc) -> throwError help Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) Left FZFCancelled -> pure Nothing @@ -193,8 +194,8 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) -fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do +fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPathCtx -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) +fzfResolve codebase ppCtx 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 @@ -215,7 +216,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO [String] fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch - options <- liftIO $ getOptions codebase projCtx currentBranch + options <- liftIO $ getOptions codebase ppCtx currentBranch when (null options) $ throwError $ NoFZFOptions argDesc liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc) results <- diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index a72ac3c923..5241e00979 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -48,6 +48,7 @@ import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.InputPattern qualified as IP import Unison.HashQualified' qualified as HQ' @@ -73,9 +74,9 @@ haskelineTabComplete :: Map String IP.InputPattern -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPathCtx -> Line.CompletionFunc m -haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.completeWordWithPrev Nothing " " $ \prev word -> +haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWordWithPrev Nothing " " $ \prev word -> -- User hasn't finished a command name, complete from command names if null prev then pure . exactComplete word $ Map.keys patterns @@ -84,7 +85,7 @@ haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.compl h : t -> fromMaybe (pure []) $ do p <- Map.lookup h patterns argType <- IP.argType p (length t) - pure $ IP.suggestions argType word codebase authedHTTPClient currentPath + pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx _ -> pure [] -- | Things which we may want to complete for. @@ -141,9 +142,9 @@ completeWithinNamespace :: NESet CompletionType -> -- | The portion of this are that the user has already typed. String -> - Path.Absolute -> + PP.ProjectPathCtx -> Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] -completeWithinNamespace compTypes query currentPath = do +completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing currentBranchSuggestions <- do @@ -169,7 +170,7 @@ completeWithinNamespace compTypes query currentPath = do querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) absQueryPath :: Path.Absolute - absQueryPath = Path.resolve currentPath queryPathPrefix + absQueryPath = Path.resolve ppCtx queryPathPrefix getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion] getChildSuggestions shortHashLen b | Text.null querySuffix = pure [] @@ -274,35 +275,35 @@ parseLaxPath'Query txt = -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: String -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> Sqlite.Transaction [Line.Completion] prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteTermOrType :: String -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> Sqlite.Transaction [Line.Completion] prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion])) -- | Completes a term argument by prefix-matching against the query. prefixCompleteTerm :: String -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> Sqlite.Transaction [Line.Completion] prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteType :: String -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> Sqlite.Transaction [Line.Completion] prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion) -- | Completes a patch argument by prefix-matching against the query. prefixCompletePatch :: String -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> Sqlite.Transaction [Line.Completion] prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion) diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index a6f23f2dbf..79a3f9fcfc 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -37,13 +37,13 @@ import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Position qualified as Position import Unison.Prelude -import Unison.Project.Util (ProjectContext (..)) import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.NameSegment qualified as NameSegment @@ -51,7 +51,7 @@ import Unison.Util.Monoid (foldMapM) import Unison.Util.Monoid qualified as Monoid import Unison.Util.Relation qualified as Relation -type OptionFetcher = Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text] +type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPathCtx -> Branch0 IO -> IO [Text] data FZFResolver = FZFResolver { getOptions :: OptionFetcher @@ -121,7 +121,7 @@ fuzzySelectFromList options = -- | Combine multiple option fetchers into one resolver. multiResolver :: [OptionFetcher] -> FZFResolver multiResolver resolvers = - let getOptions :: Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text] + let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPathCtx -> Branch0 IO -> IO [Text] getOptions codebase projCtx searchBranch0 = do List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers in (FZFResolver {getOptions}) @@ -177,11 +177,8 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - case projCtx of - LooseCodePath _ -> pure [] - ProjectBranchPath currentProjectId _projectBranchId _path -> do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith currentProjectId Nothing) - <&> fmap (into @Text . snd) + Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.ctxAsIds_ . PP.project_) Nothing) + <&> fmap (into @Text . snd) -- | Exported from here just so the debug command and actual implementation can use the same -- messaging. diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index f72506bab5..e5fa556859 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -26,6 +26,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) import Unison.Codebase.Path as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude import Unison.Util.ColorText qualified as CT @@ -67,7 +68,7 @@ data ArgumentType = ArgumentType String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> m [Line.Completion], -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if -- available. diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 490d29b6cd..19cc1c4ce6 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -182,6 +182,8 @@ import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathCtx) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.CommandLine import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) @@ -206,7 +208,6 @@ import Unison.Project 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) @@ -1234,13 +1235,9 @@ deleteNamespaceForce = deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> 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)) + pure $ Input.DeleteI (DeleteTarget'Namespace insistence p) _ -> Left helpText deletePatch :: InputPattern @@ -3481,9 +3478,9 @@ projectAndOrBranchSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + ProjectPathCtx -> m [Line.Completion] -projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do +projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do case Text.uncons input of -- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to -- handle "/" and "/@" inputs, which aren't valid branch names, but are valid branch prefixes. So, @@ -3527,10 +3524,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do pure (map (projectBranchToCompletion projectName) branches) where input = Text.strip . Text.pack $ inputStr - - (mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + currentProjectId = ppCtx ^. (PP.ctxAsIds_ . PP.project_) handleAmbiguousComplete :: MonadIO m => @@ -3667,28 +3661,22 @@ handleBranchesComplete :: ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> - Path.Absolute -> + PP.ProjectPathCtx -> m [Completion] -handleBranchesComplete config branchName codebase path = do +handleBranchesComplete config branchName codebase ppCtx = do branches <- - case preview ProjectUtils.projectBranchPathPrism path of - Nothing -> pure [] - Just (ProjectAndBranch currentProjectId _, _) -> - Codebase.runTransaction codebase do - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) + Codebase.runTransaction codebase do + fmap (filterBranches config ppCtx) do + Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName) pure (map currentProjectBranchToCompletion branches) -filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] -filterBranches config path branches = - case (mayCurrentBranchId, branchInclusion config) of - (_, AllBranches) -> branches - (Nothing, _) -> branches - (Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) +filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPathCtx -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] +filterBranches config ppCtx branches = + case (branchInclusion config) of + AllBranches -> branches + ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) where - (_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + currentBranchId = ppCtx ^. PP.ctxAsIds_ . PP.branch_ currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = @@ -3704,9 +3692,9 @@ branchRelativePathSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPathCtx -> m [Line.Completion] -branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do +branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of @@ -3719,7 +3707,7 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = BranchRelativePath.IncompleteProject _proj -> projectNameSuggestions WithSlash inputStr codebase BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of - Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath + Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase ppCtx Just projectName -> do branches <- Codebase.runTransaction codebase do @@ -3727,19 +3715,12 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config currentPath) do + fmap (filterBranches config ppCtx) do Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch) pure (map (projectBranchToCompletionWithSep projectName) branches) BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do - mprojectBranch <- runMaybeT do - (projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId) - MaybeT (Queries.loadProjectBranch projectId branchId) - case mprojectBranch of - Nothing -> pure [] - Just projectBranch -> do - let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) - projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) - map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) branchPath + -- TODO: Verify this works as intendid + map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) mempty BranchRelativePath.IncompletePath projStuff mpath -> do Codebase.runTransaction codebase do mprojectBranch <- runMaybeT do @@ -3747,7 +3728,6 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = Left names@(ProjectAndBranch projectName branchName) -> do (,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName) Right branchName -> do - currentProjectId <- MaybeT (pure mayCurrentProjectId) projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName) pure (projectBranch, Right (projectBranch ^. #name)) case mprojectBranch of @@ -3757,9 +3737,8 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) map (addBranchPrefix prefix) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) branchPath where - (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + currentPath = ppCtx ^. PP.absPath_ + currentProjectId = ppCtx ^. PP.ctxAsIds_ . PP.project_ projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index de0d7e12fb..26ca644d01 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -10,6 +10,7 @@ import Control.Lens (preview, (?~), (^.)) import Crypto.Random qualified as Random import Data.Configurator.Types (Config) import Data.IORef +import Data.List.NonEmpty qualified as NEL import Data.Text qualified as Text import Data.Text.IO qualified as Text import Ki qualified @@ -20,6 +21,7 @@ import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin) import System.IO.Error (isDoesNotExistError) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Operations qualified as Operations +import U.Codebase.Sqlite.Operations qualified as Ops import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.CredentialManager (newCredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) @@ -30,12 +32,14 @@ import Unison.Cli.Pretty (prettyProjectAndBranchName) import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch (Branch) 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.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.CommandLine import Unison.CommandLine.Completion (haskelineTabComplete) @@ -60,10 +64,11 @@ import UnliftIO.STM getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPathCtx -> + IO (Branch IO) -> [String] -> IO Input -getUserInput codebase authHTTPClient currentPath numberedArgs = +getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Line.runInputT settings (haskelineCtrlCHandling go) @@ -78,23 +83,15 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = Just a -> pure a go :: Line.InputT IO Input go = do - promptString <- - case preview projectBranchPathPrism currentPath of - Nothing -> pure ((P.green . P.shown) currentPath) - Just (ProjectAndBranch projectId branchId, restPath) -> do - lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case - -- If the project branch has been deleted from sqlite, just show a borked prompt - Nothing -> P.red "???" - Just (projectName, branchName) -> - P.sep - " " - ( catMaybes - [ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)), - case restPath of - Path.Empty -> Nothing - _ -> (Just . P.green . P.shown) restPath - ] - ) + let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.ctxAsNames_ + let promptString = + P.sep + ":" + ( catMaybes + [ Just (prettyProjectAndBranchName (ProjectAndBranch projectName projectBranchName)), + (Just . P.green . P.shown) path + ] + ) let fullPrompt = P.toANSI 80 (promptString <> fromString prompt) line <- Line.getInputLine fullPrompt case line of @@ -102,7 +99,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = Just l -> case words l of [] -> go ws -> do - liftIO (parseInput codebase currentPath numberedArgs IP.patternMap ws) >>= \case + liftIO (parseInput codebase ppCtx currentProjectRoot numberedArgs IP.patternMap ws) >>= \case Left msg -> do -- We still add history that failed to parse so the user can easily reload -- the input and fix it. @@ -125,12 +122,12 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = historyFile = Just ".unisonHistory", autoAddHistory = False } - tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath + tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient ppCtx main :: FilePath -> Welcome.Welcome -> - Path.Absolute -> + PP.ProjectPathIds -> Config -> [Either Event Input] -> Runtime.Runtime Symbol -> @@ -143,9 +140,8 @@ main :: (Path.Absolute -> STM ()) -> ShouldWatchFiles -> IO () -main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do +main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do rootVar <- newEmptyTMVarIO - initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash _ <- Ki.fork scope do root <- Codebase.getRootBranch codebase atomically do @@ -158,7 +154,7 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod UnliftIO.concurrently_ (UnliftIO.evaluate root) (UnliftIO.evaluate IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup - let initialState = Cli.loopState0 initialRootCausalHash rootVar initialPath + let initialState = Cli.loopState0 rootVar ppIds Ki.fork_ scope do let loop lastRoot = do -- This doesn't necessarily notify on _every_ update, but the LSP only needs the @@ -186,10 +182,13 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod getInput loopState = do currentEcho <- hGetEcho stdin liftIO $ restoreEcho currentEcho + let getProjectRoot = atomically $ readTMVar rootVar + Codebase.runTransaction codebase Ops.expectProjectAndBranchNames getUserInput codebase authHTTPClient - (loopState ^. #currentPath) + (NEL.head $ Cli.projectPathStack loopState) + getProjectRoot (loopState ^. #numberedArgs) let loadSourceFile :: Text -> IO Cli.LoadSourceResult loadSourceFile fname = From 2c64c6a4086031ebb53afdf0e0a1071651f456d7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 May 2024 15:48:42 -0700 Subject: [PATCH 05/76] Checkpoint --- .../unison-parser-typechecker.cabal | 1 - unison-cli/src/Unison/Cli/MonadUtils.hs | 38 ++++++++--------- .../Codebase/Editor/HandleInput/Branch.hs | 4 +- unison-share-api/src/Unison/Server/Backend.hs | 25 ++--------- .../Unison/Server/Local/Endpoints/Current.hs | 41 +++++-------------- 5 files changed, 36 insertions(+), 73 deletions(-) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index f57ba4ad5e..df1b0ec4b3 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -136,7 +136,6 @@ library Unison.PrettyPrintEnvDecl.Names Unison.PrettyPrintEnvDecl.Sqlite Unison.PrintError - Unison.Project.Util Unison.Result Unison.Runtime.ANF Unison.Runtime.ANF.Rehash diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index beaf3bff77..78308eae67 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -29,10 +29,10 @@ module Unison.Cli.MonadUtils getProjectRoot0, getCurrentBranch, getCurrentBranch0, - getBranchAt, - getBranch0At, - getMaybeBranchAt, - getMaybeBranch0At, + getBranchFromProjectRootPath, + getBranch0FromProjectRootPath, + getMaybeBranchFromProjectRootPath, + getMaybeBranch0FromProjectRootPath, expectBranchAtPath, expectBranchAtPath', expectBranch0AtPath, @@ -194,7 +194,7 @@ resolveSplit' = resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO) resolveAbsBranchId = \case Left hash -> resolveShortCausalHash hash - Right path -> getBranchAt path + Right path -> getBranchFromProjectRootPath path -- | V2 version of 'resolveAbsBranchId2'. resolveAbsBranchIdV2 :: @@ -289,26 +289,26 @@ getCurrentBranch0 :: Cli (Branch0 IO) getCurrentBranch0 = do Branch.head <$> getCurrentBranch --- | Get the branch at an absolute path. -getBranchAt :: Path.Absolute -> Cli (Branch IO) -getBranchAt path = - getMaybeBranchAt path <&> fromMaybe Branch.empty +-- | Get the branch at an absolute path from the project root. +getBranchFromProjectRootPath :: Path.Absolute -> Cli (Branch IO) +getBranchFromProjectRootPath path = + getMaybeBranchFromProjectRootPath path <&> fromMaybe Branch.empty -- | Get the branch0 at an absolute path. -getBranch0At :: Path.Absolute -> Cli (Branch0 IO) -getBranch0At path = - Branch.head <$> getBranchAt path +getBranch0FromProjectRootPath :: Path.Absolute -> Cli (Branch0 IO) +getBranch0FromProjectRootPath path = + Branch.head <$> getBranchFromProjectRootPath path -- | Get the maybe-branch at an absolute path. -getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO)) -getMaybeBranchAt path = do +getMaybeBranchFromProjectRootPath :: Path.Absolute -> Cli (Maybe (Branch IO)) +getMaybeBranchFromProjectRootPath path = do rootBranch <- getProjectRoot pure (Branch.getAt (Path.unabsolute path) rootBranch) -- | Get the maybe-branch0 at an absolute path. -getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO)) -getMaybeBranch0At path = - fmap Branch.head <$> getMaybeBranchAt path +getMaybeBranch0FromProjectRootPath :: Path.Absolute -> Cli (Maybe (Branch0 IO)) +getMaybeBranch0FromProjectRootPath path = + fmap Branch.head <$> getMaybeBranchFromProjectRootPath path -- | Get the branch at a relative path, or return early if there's no such branch. expectBranchAtPath :: Path -> Cli (Branch IO) @@ -319,7 +319,7 @@ expectBranchAtPath = expectBranchAtPath' :: Path' -> Cli (Branch IO) expectBranchAtPath' path0 = do path <- resolvePath' path0 - getMaybeBranchAt path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) + getMaybeBranchFromProjectRootPath path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) -- | Get the branch0 at an absolute or relative path, or return early if there's no such branch. expectBranch0AtPath' :: Path' -> Cli (Branch0 IO) @@ -520,7 +520,7 @@ getPatchAt path = getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch) getMaybePatchAt path0 = do (path, name) <- resolveSplit' path0 - branch <- getBranch0At path + branch <- getBranch0FromProjectRootPath path liftIO (Branch.getMaybePatch name branch) -- | Get the patch at a path, or return early if there's no such patch. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 9ca57e574e..0137f0e3f4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -16,7 +16,7 @@ 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 (getBranchAt, getCurrentPath, updateAt) +import Unison.Cli.MonadUtils qualified as Cli (getBranchFromProjectRootPath, getCurrentPath, updateAt) import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch (empty) @@ -117,7 +117,7 @@ doCreateBranch createFrom project newBranchName description = do CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do let sourceProjectId = sourceBranch ^. #projectId let sourceBranchId = sourceBranch ^. #branchId - Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) + Cli.getBranchFromProjectRootPath (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath CreateFrom'Nothingness -> pure Branch.empty let projectId = project ^. #projectId diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 10cd18867b..7ee0554a30 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -58,7 +58,6 @@ module Unison.Server.Backend renderDocRefs, docsForDefinitionName, normaliseRootCausalHash, - causalHashForProjectBranchName, -- * Unused, could remove? resolveRootBranchHash, @@ -103,14 +102,11 @@ import U.Codebase.HashTags (BranchHash, CausalHash (..)) import U.Codebase.Referent qualified as V2Referent import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) -import U.Codebase.Sqlite.Queries qualified as Q import Unison.ABT qualified as ABT import Unison.Builtin qualified as B import Unison.Builtin.Decls qualified as Decls import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase qualified as UCodebase import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch @@ -147,8 +143,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnv.Util qualified as PPE 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.Project (ProjectBranchName, ProjectName) import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -365,12 +360,12 @@ lsAtPath :: (MonadIO m) => Codebase m Symbol Ann -> -- The root to follow the path from. - Maybe (V2Branch.Branch Sqlite.Transaction) -> + V2Branch.Branch Sqlite.Transaction -> -- Path from the root to the branch to 'ls' Path.Absolute -> m [ShallowListEntry Symbol Ann] -lsAtPath codebase mayRootBranch absPath = do - b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) mayRootBranch) +lsAtPath codebase rootBranch absPath = do + b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) rootBranch) lsBranch codebase b findDocInBranch :: @@ -1270,15 +1265,3 @@ loadTypeDisplayObject c = \case Reference.DerivedId id -> maybe (MissingObject $ Reference.idToShortHash id) UserObject <$> Codebase.getTypeDeclaration c id - --- | Get the causal hash a given project branch points to -causalHashForProjectBranchName :: MonadIO m => ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe CausalHash) -causalHashForProjectBranchName (ProjectAndBranch projectName branchName) = do - Q.loadProjectBranchByNames projectName branchName >>= \case - Nothing -> pure Nothing - Just ProjectBranch {projectId, branchId} -> do - let path = ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId) - -- Use the default codebase root - let codebaseRoot = Nothing - mayCausal <- UCodebase.getShallowCausalFromRoot codebaseRoot (Path.unabsolute path) - pure . Just $ V2Causal.causalHash mayCausal diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 5cc218b7eb..caf71afbe2 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -3,22 +3,18 @@ module Unison.Server.Local.Endpoints.Current where +import Control.Lens hiding ((.=)) import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema (..)) import Servant ((:>)) import Servant.Docs (ToSample (..)) -import U.Codebase.Sqlite.DbId -import U.Codebase.Sqlite.Project qualified as Project -import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path -import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) -import Unison.NameSegment (NameSegment) +import Unison.Codebase.ProjectPath qualified as PP +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment) import Unison.Server.Backend import Unison.Server.Types (APIGet) @@ -57,26 +53,11 @@ serveCurrent = lift . getCurrentProjectBranch getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current getCurrentProjectBranch codebase = do - segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace - let absolutePath = toPath segments - case toIds segments of - ProjectAndBranch (Just projectId) branchId -> - Codebase.runTransaction codebase do - project <- Queries.expectProject projectId - branch <- traverse (Queries.expectProjectBranch projectId) branchId - pure $ Current (Just $ Project.name project) (ProjectBranch.name <$> branch) absolutePath - ProjectAndBranch _ _ -> - pure $ Current Nothing Nothing absolutePath - where - toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId) - toIds segments = - case segments of - ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ -> - ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId} - ProjectsNameSegment : UUIDNameSegment projectId : _ -> - ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing} - _ -> - ProjectAndBranch {project = Nothing, branch = Nothing} - - toPath :: [NameSegment] -> Path.Absolute - toPath = Path.Absolute . Path.fromList + ppCtx <- + Codebase.runTransaction codebase Codebase.loadCurrentProjectPathCtx <&> \case + Nothing -> + -- TODO: Come up with a better solution for this + error "No current project path context" + Just ppCtx -> ppCtx + let (PP.ProjectPath projName branchName path) = ppCtx ^. PP.ctxAsNames_ + pure $ Current (Just projName) (Just branchName) path From 1a15c3f2124f06d49ce90b2773261e2b05838699 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 May 2024 15:48:42 -0700 Subject: [PATCH 06/76] Set currentProjectPath in SQLite --- .../U/Codebase/Sqlite/Queries.hs | 51 ++++--- .../012-add-current-project-path-table.sql | 10 ++ .../unison-codebase-sqlite.cabal | 3 +- parser-typechecker/src/Unison/Codebase.hs | 20 +++ .../Migrations/MigrateSchema16To17.hs | 8 +- parser-typechecker/src/Unison/Project/Util.hs | 142 ------------------ 6 files changed, 67 insertions(+), 167 deletions(-) create mode 100644 codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql delete mode 100644 parser-typechecker/src/Unison/Project/Util.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index dc05c3f185..208875cb10 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -235,9 +235,9 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashes, - -- * most recent namespace - expectMostRecentNamespace, - setMostRecentNamespace, + -- * current project path + loadCurrentProjectPath, + setCurrentProjectPath, -- * migrations createSchema, @@ -252,6 +252,7 @@ module U.Codebase.Sqlite.Queries addSquashResultTable, addSquashResultTableIfNotExists, cdToProjectRoot, + addCurrentProjectPathTable, -- ** schema version currentSchemaVersion, @@ -488,6 +489,10 @@ schemaVersion = FROM schema_version |] +addCurrentProjectPathTable :: Transaction () +addCurrentProjectPathTable = + executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql") + data UnexpectedSchemaVersion = UnexpectedSchemaVersion { actual :: SchemaVersion, expected :: SchemaVersion @@ -4249,33 +4254,39 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -expectMostRecentNamespace :: Transaction [NameSegment] -expectMostRecentNamespace = - queryOneColCheck +loadCurrentProjectPath :: Transaction (Maybe (ProjectId, ProjectBranchId, [NameSegment])) +loadCurrentProjectPath = + queryMaybeRowCheck [sql| - SELECT namespace - FROM most_recent_namespace + SELECT project_id, branch_id, path + FROM current_project_path |] check where - check :: Text -> Either JsonParseFailure [NameSegment] - check bytes = - case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of - Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure} - Right namespace -> Right (map NameSegment namespace) + check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment]) + check (projId, branchId, pathText) = + case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of + Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure} + Right namespace -> Right (projId, branchId, map NameSegment namespace) -- | Set the most recent namespace the user has visited. -setMostRecentNamespace :: [Text] -> Transaction () -setMostRecentNamespace namespace = +setCurrentProjectPath :: + ProjectId -> + ProjectBranchId -> + [NameSegment] -> + Transaction () +setCurrentProjectPath projId branchId path = do + execute + [sql| TRUNCATE TABLE current_project_path |] execute [sql| - UPDATE most_recent_namespace - SET namespace = :json + INSERT INTO most_recent_namespace(project_id, branch_id, path) + VALUES (:projId, :branchId, :jsonPath) |] where - json :: Text - json = - Text.Lazy.toStrict (Aeson.encodeToLazyText namespace) + jsonPath :: Text + jsonPath = + Text.Lazy.toStrict (Aeson.encodeToLazyText $ map NameSegment.toUnescapedText path) -- | Get the causal hash result from squashing the provided branch hash if we've squashed it -- at some point in the past. diff --git a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql new file mode 100644 index 0000000000..5a511a4394 --- /dev/null +++ b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql @@ -0,0 +1,10 @@ +-- The most recent namespace that a user cd'd to. +-- This table should never have more than one row. +CREATE TABLE current_project_path ( + project_id INTEGER NOT NULL REFERENCES project (id), + branch_id INTEGER NOT NULL REFERENCES project_branch (id), + -- A json array like ["foo", "bar"]; the root namespace is represented by the empty array + path TEXT PRIMARY KEY NOT NULL +) WITHOUT ROWID; + +DROP TABLE "most_recent_namespace"; diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index ac1f606921..0791856217 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.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 @@ -21,6 +21,7 @@ extra-source-files: sql/009-add-squash-cache-table.sql sql/010-ensure-squash-cache-table.sql sql/011-cd-to-project-root.sql + sql/012-add-current-project-path-table.sql sql/create.sql source-repository head diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 65608c0c96..d3df98a50b 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,6 +1,10 @@ module Unison.Codebase ( Codebase, + -- * UCM session state + loadCurrentProjectPathCtx, + setCurrentProjectPath, + -- * Terms getTerm, unsafeGetTerm, @@ -120,6 +124,7 @@ import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId qualified as Db 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 Q import U.Codebase.Sqlite.Queries qualified as Queries @@ -549,3 +554,18 @@ unsafeGetTermComponent codebase hash = getTermComponentWithTypes codebase hash <&> \case Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms + +loadCurrentProjectPathCtx :: Sqlite.Transaction (Maybe PP.ProjectPathCtx) +loadCurrentProjectPathCtx = do + mProjectPath <- Q.loadCurrentProjectPath + case mProjectPath of + Nothing -> pure Nothing + Just (projectId, projectBranchId, path) -> do + Project {name = projectName} <- Q.expectProject projectId + ProjectBranch {name = branchName} <- Q.expectProjectBranch projectId projectBranchId + let absPath = Path.Absolute (Path.fromList path) + pure $ Just (PP.ProjectPath (projectId, projectName) (projectBranchId, branchName) absPath) + +setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () +setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = + Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path)) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs index 45c41036a2..269f88de43 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -3,12 +3,12 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where -import U.Codebase.Sqlite.Queries qualified as Queries +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Sqlite qualified as Sqlite -- | This migration adds the causal_object_id column to the project_branches table. migrateSchema16To17 :: Sqlite.Transaction () migrateSchema16To17 = do - Queries.expectSchemaVersion 16 - error "Impelement MigrateSchema16To17.migrateSchema16To17" - Queries.setSchemaVersion 17 + Q.expectSchemaVersion 16 + Q.addCurrentProjectPathTable + Q.setSchemaVersion 17 diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs deleted file mode 100644 index edc670c063..0000000000 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ /dev/null @@ -1,142 +0,0 @@ -module Unison.Project.Util - ( projectPath, - projectBranchesPath, - projectBranchPath, - projectBranchSegment, - projectPathPrism, - projectBranchPathPrism, - pattern UUIDNameSegment, - pattern ProjectsNameSegment, - pattern BranchesNameSegment, - ) -where - -import Control.Lens -import Data.Text qualified as Text -import Data.UUID (UUID) -import Data.UUID qualified as UUID -import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) -import Unison.Codebase.Path qualified as Path -import Unison.NameSegment (NameSegment (..)) -import Unison.NameSegment qualified as NameSegment -import Unison.Project (ProjectAndBranch (..)) - --- | Get the path that a project is stored at. Users aren't supposed to go here. --- --- >>> projectPath "ABCD" --- .__projects._ABCD -projectPath :: ProjectId -> Path.Absolute -projectPath projectId = - review projectPathPrism projectId - --- | Get the path that a project's branches are stored at. Users aren't supposed to go here. --- --- >>> projectBranchesPath "ABCD" --- .__projects._ABCD.branches -projectBranchesPath :: ProjectId -> Path.Absolute -projectBranchesPath projectId = - snoc (projectPath projectId) BranchesNameSegment - --- | Get the path that a branch is stored at. Users aren't supposed to go here. --- --- >>> projectBranchPath ProjectAndBranch { project = "ABCD", branch = "DEFG" } --- .__projects._ABCD.branches._DEFG -projectBranchPath :: ProjectAndBranch ProjectId ProjectBranchId -> Path.Absolute -projectBranchPath projectAndBranch = - review projectBranchPathPrism (projectAndBranch, Path.empty) - --- | Get the name segment that a branch is stored at. --- --- >>> projectBranchSegment "DEFG" --- "_DEFG" -projectBranchSegment :: ProjectBranchId -> NameSegment -projectBranchSegment (ProjectBranchId branchId) = - UUIDNameSegment branchId - -pattern UUIDNameSegment :: UUID -> NameSegment -pattern UUIDNameSegment uuid <- - ( NameSegment.toUnescapedText -> - (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) - ) - where - UUIDNameSegment uuid = - NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) - --- | The prism between paths like --- --- @ --- .__projects._XX_XX --- @ --- --- and the project id --- --- @ --- XX-XX --- @ -projectPathPrism :: Prism' Path.Absolute ProjectId -projectPathPrism = - prism' toPath toId - where - toPath :: ProjectId -> Path.Absolute - toPath projectId = - Path.Absolute (Path.fromList [ProjectsNameSegment, UUIDNameSegment (unProjectId projectId)]) - - toId :: Path.Absolute -> Maybe ProjectId - toId path = - case Path.toList (Path.unabsolute path) of - [ProjectsNameSegment, UUIDNameSegment projectId] -> Just (ProjectId projectId) - _ -> Nothing - --- | The prism between paths like --- --- @ --- .__projects._XX_XX.branches._YY_YY.foo.bar --- @ --- --- and the @(project id, branch id, path)@ triple --- --- @ --- (XX-XX, YY-YY, foo.bar) --- @ -projectBranchPathPrism :: Prism' Path.Absolute (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) -projectBranchPathPrism = - prism' toPath toIds - where - toPath :: (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) -> Path.Absolute - toPath (ProjectAndBranch {project = projectId, branch = branchId}, restPath) = - Path.Absolute $ - Path.fromList - ( [ ProjectsNameSegment, - UUIDNameSegment (unProjectId projectId), - BranchesNameSegment, - UUIDNameSegment (unProjectBranchId branchId) - ] - ++ Path.toList restPath - ) - - toIds :: Path.Absolute -> Maybe (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) - toIds path = - case Path.toList (Path.unabsolute path) of - ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : restPath -> - Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath) - _ -> Nothing - -pattern ProjectsNameSegment :: NameSegment -pattern ProjectsNameSegment <- - ((== projectsNameSegment) -> True) - where - ProjectsNameSegment = projectsNameSegment - -pattern BranchesNameSegment :: NameSegment -pattern BranchesNameSegment <- - ((== branchesNameSegment) -> True) - where - BranchesNameSegment = branchesNameSegment - -projectsNameSegment :: NameSegment -projectsNameSegment = - "__projects" - -branchesNameSegment :: NameSegment -branchesNameSegment = - "branches" From dca8431b503127706ae326cc2ecaceef2cacfe36 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 May 2024 16:37:36 -0700 Subject: [PATCH 07/76] Add getShallowProjectRootByNames --- .../codebase-sqlite/U/Codebase/Sqlite/Operations.hs | 1 + parser-typechecker/src/Unison/Codebase.hs | 9 +++++++++ unison-share-api/src/Unison/Server/CodebaseServer.hs | 2 +- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 45b0950619..b32babbf1c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -13,6 +13,7 @@ module U.Codebase.Sqlite.Operations saveBranchV3, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, + expectBranchByCausalHashId, expectBranchByBranchHash, expectBranchByBranchHashId, expectNamespaceStatsByHash, diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index d3df98a50b..6e86831e01 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -55,6 +55,7 @@ module Unison.Codebase getShallowRootCausal, getShallowProjectRootBranch, getShallowBranchAtProjectPath, + getShallowProjectRootByNames, -- * Root branch getRootBranch, @@ -144,6 +145,7 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Ope import Unison.Codebase.Type (Codebase (..), GitError) import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) +import Unison.Core.Project (ProjectAndBranch) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DD import Unison.Hash (Hash) @@ -151,6 +153,7 @@ import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Parser import Unison.Prelude +import Unison.Project (ProjectAndBranch (ProjectAndBranch), ProjectBranchName, ProjectName) import Unison.Reference (Reference, TermReferenceId, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent @@ -252,6 +255,12 @@ getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId getShallowBranchAtPath (Path.unabsolute path) projectRootBranch +getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) +getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do + ProjectBranch {causalHashId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName + causalHash <- lift $ Q.expectCausalHash causalHashId + lift $ Operations.expectCausalBranchByCausalHash causalHash + -- | Get a v1 branch from the root following the given path. getBranchAtPath :: (MonadIO m) => diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index eb2332dc7a..88c57c8183 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -613,7 +613,7 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do 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 + mayCH <- liftIO . Codebase.runTransaction codebase $ Codebase.causalHashForProjectBranchName @IO projectAndBranchName case mayCH of Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) Just ch -> pure ch From 2b504190fcaaf99cb2ccc36b1e16f7f48ab39ea1 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 22 May 2024 10:08:05 -0700 Subject: [PATCH 08/76] Rewrite BranchRelativePaths machinery --- other-thing.md | 6 + other-thing.output.md | 23 ++++ parser-typechecker/src/Unison/Codebase.hs | 11 ++ .../src/Unison/Codebase/ProjectPath.hs | 10 ++ unison-cli/src/Unison/Cli/Monad.hs | 15 ++- unison-cli/src/Unison/Cli/Pretty.hs | 11 -- unison-cli/src/Unison/Cli/ProjectUtils.hs | 126 +++++------------- .../Codebase/Editor/HandleInput/Branch.hs | 73 ++++------ .../Codebase/Editor/HandleInput/MoveBranch.hs | 2 +- .../HandleInput/NamespaceDependencies.hs | 2 +- .../Editor/HandleInput/ProjectSwitch.hs | 16 +-- .../Codebase/Editor/HandleInput/Update2.hs | 2 +- .../src/Unison/Codebase/Editor/Input.hs | 19 ++- .../Unison/CommandLine/BranchRelativePath.hs | 105 +++++++-------- .../src/Unison/CommandLine/Completion.hs | 9 +- .../src/Unison/Server/CodebaseServer.hs | 28 ++-- 16 files changed, 200 insertions(+), 258 deletions(-) create mode 100644 other-thing.md create mode 100644 other-thing.output.md diff --git a/other-thing.md b/other-thing.md new file mode 100644 index 0000000000..81145901b3 --- /dev/null +++ b/other-thing.md @@ -0,0 +1,6 @@ +```ucm +.> clone @unison/cloud +@unison/cloud/main> reset #t30tkb0hj1 +@unison/cloud/main> branch bug +@unison/cloud/bug> delete.namespace lib.httpserver_4_1_0 +``` diff --git a/other-thing.output.md b/other-thing.output.md new file mode 100644 index 0000000000..49918f21f5 --- /dev/null +++ b/other-thing.output.md @@ -0,0 +1,23 @@ +```ucm +.> clone @unison/cloud + + Downloaded 92354 entities. + + Cloned @unison/cloud/main. + +@unison/cloud/main> reset #t30tkb0hj1 + + Done. + +@unison/cloud/main> branch bug + + Done. I've created the bug branch based off of main. + + Tip: Use `merge /bug /main` to merge your work back into the + main branch. + +@unison/cloud/bug> delete.namespace lib.httpserver_4_1_0 + + Done. + +``` diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 6e86831e01..db197aa5ed 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -114,6 +114,7 @@ module Unison.Codebase toCodeLookup, typeLookupForDependencies, unsafeGetComponentLength, + emptyCausalHash, ) where @@ -578,3 +579,13 @@ loadCurrentProjectPathCtx = do setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path)) + +-- | Often we need to assign something to an empty causal, this ensures the empty causal +-- exists in the codebase and returns its hash. +emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId) +emptyCausalHash = do + let emptyBranch = Branch.empty + SqliteCodebase.Operations.putBranch emptyBranch + let causalHash = Branch.headHash emptyBranch + causalHashId <- Queries.expectCausalHashIdByCausalHash causalHash + pure (causalHash, causalHashId) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 7fd5cfd669..4f6bbe30f2 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -3,6 +3,8 @@ module Unison.Codebase.ProjectPath ProjectPathIds, ProjectPathNames, ProjectPathCtx, + fromProjectAndBranch, + ctxFromProjectAndBranch, absPath_, path_, projectAndBranch_, @@ -18,6 +20,8 @@ import Control.Lens import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.Codebase.Path qualified as Path import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) @@ -35,6 +39,12 @@ type ProjectPathNames = ProjectPath ProjectName ProjectBranchName type ProjectPathCtx = ProjectPath (ProjectId, ProjectName) (ProjectBranchId, ProjectBranchName) +fromProjectAndBranch :: ProjectAndBranch proj branch -> Path.Absolute -> ProjectPath proj branch +fromProjectAndBranch (ProjectAndBranch proj branch) = ProjectPath proj branch + +ctxFromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPathCtx +ctxFromProjectAndBranch (ProjectAndBranch (Project {projectId, name = projectName}) (ProjectBranch {branchId, name = branchName})) = ProjectPath (projectId, projectName) (branchId, branchName) + project_ :: Lens' (ProjectPath p b) p project_ = lens go set where diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 1db18cf12d..b6c137c3ce 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -34,6 +34,7 @@ module Unison.Cli.Monad -- * Changing the current directory cd, popd, + switchProject, -- * Communicating output to the user respond, @@ -67,6 +68,8 @@ import Data.Time.Clock.TAI (diffAbsoluteTime) import Data.Unique (Unique, newUnique) import System.CPUTime (getCPUTime) import Text.Printf (printf) +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) @@ -81,6 +84,7 @@ import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.Project (ProjectAndBranch (..)) import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) @@ -379,7 +383,16 @@ getProjectPathIds = do cd :: Path.Absolute -> Cli () cd path = do pp <- getProjectPathIds - #projectPathStack %= NonEmpty.cons (pp & PP.absPath_ .~ path) + let newPP = pp & PP.absPath_ .~ path + setMostRecentProjectPath newPP + #projectPathStack %= NonEmpty.cons newPP + +switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () +switchProject (ProjectAndBranch projectId branchId) = do + let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty + #projectPathStack %= NonEmpty.cons newPP + runTransaction $ Q.setMostRecentBranch projectId branchId + setMostRecentProjectPath newPP -- | Pop the latest path off the stack, if it's not the only path in the stack. -- diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index a149375543..c3a3ea88e2 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -5,7 +5,6 @@ module Unison.Cli.Pretty ( displayBranchHash, prettyAbsolute, - prettyAbsoluteStripProject, prettyBase32Hex#, prettyBase32Hex, prettyBranchId, @@ -73,7 +72,6 @@ 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 @@ -410,15 +408,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) = <> " on " <> P.shown host -stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path -stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism - -prettyAbsoluteStripProject :: Path.Absolute -> Pretty -prettyAbsoluteStripProject path = - P.blue case stripProjectBranchInfo path of - Just p -> P.shown p - Nothing -> P.shown path - prettyLabeledDependencies :: PPE.PrettyPrintEnv -> Set LabeledDependency -> Pretty prettyLabeledDependencies ppe lds = P.syntaxToColor (P.sep ", " (ld <$> toList lds)) diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 9010be1c77..07a7e93a1f 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -1,21 +1,8 @@ -- | Project-related utilities. module Unison.Cli.ProjectUtils ( -- * Project/path helpers - getCurrentProject, - expectCurrentProject, - expectCurrentProjectIds, - getCurrentProjectIds, - getCurrentProjectBranch, - getProjectBranchForPath, - expectCurrentProjectBranch, expectProjectBranchByName, - projectPath, - projectBranchesPath, - projectBranchPath, - projectBranchSegment, - projectBranchPathPrism, resolveBranchRelativePath, - branchRelativePathToAbsolute, -- * Name hydration hydrateNames, @@ -43,6 +30,7 @@ module Unison.Cli.ProjectUtils where import Control.Lens +import Control.Monad.Trans.Maybe (mapMaybeT) import Data.List qualified as List import Data.Maybe (fromJust) import Data.Set qualified as Set @@ -61,48 +49,27 @@ import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath) -import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath +import Unison.Codebase.ProjectPath qualified as PP +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..)) import Unison.Core.Project (ProjectBranchName (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectName) -import Unison.Project.Util import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute -branchRelativePathToAbsolute brp = - resolveBranchRelativePath brp <&> \case - BranchRelativePath.ResolvedLoosePath p -> p - BranchRelativePath.ResolvedBranchRelative projectBranch mRel -> - let projectBranchIds = getIds projectBranch - handleRel = case mRel of - Nothing -> id - Just rel -> flip Path.resolve rel - in handleRel (projectBranchPath projectBranchIds) - where - getIds = \case - ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch) - -resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath -resolveBranchRelativePath = \case - BranchRelativePath.BranchRelative brp -> case brp of - This projectBranch -> do - projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch) - pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing) - That path -> do - (projectBranch, _) <- expectCurrentProjectBranch - pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path)) - These projectBranch path -> do - projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch) - pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path)) - BranchRelativePath.LoosePath path -> - BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path - where - toThese = \case - Left branchName -> That branchName - Right (projectName, branchName) -> These projectName branchName +resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPathCtx +resolveBranchRelativePath brp = do + case brp of + BranchPathInCurrentProject projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName) + pure $ PP.ctxFromProjectAndBranch projectAndBranch path + QualifiedBranchPath projName projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) + pure $ PP.ctxFromProjectAndBranch projectAndBranch path + UnqualifiedPath newPath' -> do + ppCtx <- Cli.getProjectPathCtx + pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name -- like @preferred@. @@ -125,55 +92,22 @@ findTemporaryBranchName projectId preferred = do pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates)) --- | Get the current project that a user is on. -getCurrentProject :: Cli (Maybe Sqlite.Project) -getCurrentProject = do - path <- Cli.getCurrentPath - case preview projectBranchPathPrism path of - Nothing -> pure Nothing - Just (ProjectAndBranch projectId _branchId, _restPath) -> - Cli.runTransaction do - project <- Queries.expectProject projectId - pure (Just project) - --- | Like 'getCurrentProject', but fails with a message if the user is not on a project branch. -expectCurrentProject :: Cli Sqlite.Project -expectCurrentProject = do - getCurrentProject & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - --- | Get the current project ids that a user is on. -getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId)) -getCurrentProjectIds = - fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath - --- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch. -expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId) -expectCurrentProjectIds = - getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - -- | Get the current project+branch+branch path that a user is on. -getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)) -getCurrentProjectBranch = do - path <- Cli.getCurrentPath - getProjectBranchForPath path +getCurrentProjectBranch :: Cli (Maybe (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch)) +getCurrentProjectBranch = runMaybeT do + ppCtx <- lift Cli.getProjectPathCtx + mapMaybeT Cli.runTransaction $ do + proj <- MaybeT $ Queries.loadProject (ppCtx ^. PP.ctxAsIds_ . PP.project_) + branch <- MaybeT $ Queries.loadProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_) + pure $ PP.ProjectPath proj branch (ppCtx ^. PP.absPath_) expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch expectProjectBranchByName project branchName = Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) -getProjectBranchForPath :: Path.Absolute -> Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)) -getProjectBranchForPath path = do - case preview projectBranchPathPrism path of - Nothing -> pure Nothing - Just (ProjectAndBranch projectId branchId, restPath) -> - Cli.runTransaction do - project <- Queries.expectProject projectId - branch <- Queries.expectProjectBranch projectId branchId - pure (Just (ProjectAndBranch project branch, restPath)) - -- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch. -expectCurrentProjectBranch :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path) +expectCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch) expectCurrentProjectBranch = getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) @@ -187,8 +121,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do - (ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch - pure (ProjectAndBranch (project ^. #name) branchName) + ppCtx <- Cli.getProjectPathCtx + pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) -- Expect a local project+branch by ids. @@ -210,9 +144,9 @@ getProjectAndBranchByTheseNames :: getProjectAndBranchByTheseNames = \case This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> runMaybeT do - (ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch - branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName)) - pure (ProjectAndBranch project branch) + currentProjectBranch <- MaybeT getCurrentProjectBranch + branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName)) + pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch) These projectName branchName -> do Cli.runTransaction do runMaybeT do @@ -230,7 +164,7 @@ expectProjectAndBranchByTheseNames :: expectProjectAndBranchByTheseNames = \case This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> do - (ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch + PP.ProjectPath project _branch _restPath <- expectCurrentProjectBranch branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) @@ -347,7 +281,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case let remoteBranchName = unsafeFrom @Text "main" expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) That branchName -> do - (ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch + PP.ProjectPath localProject localBranch _restPath <- expectCurrentProjectBranch let localProjectId = localProject ^. #projectId let localBranchId = localBranch ^. #branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 0137f0e3f4..3d1a0549e5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -10,16 +10,18 @@ where import Control.Lens ((^.)) import Data.These (These (..)) import Data.UUID.V4 qualified as UUID +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 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 (getBranchFromProjectRootPath, getCurrentPath, updateAt) +import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Branch qualified as Branch (empty) +import Unison.Codebase.Branch qualified as Branch (empty, headHash) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path @@ -27,11 +29,6 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) import Unison.Sqlite qualified as Sqlite -data CreateFrom - = CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) - | CreateFrom'LooseCode Path.Absolute - | CreateFrom'Nothingness - -- | Create a new project branch from an existing project branch or namespace. handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleBranch sourceI projectAndBranchNames0 = do @@ -51,14 +48,21 @@ handleBranch sourceI projectAndBranchNames0 = do Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () + srcProject <- + Cli.runTransactionWithRollback \rollback -> do + Queries.loadProjectByName projectName & onNothingM do + -- We can't make the *first* branch of a project with `branch`; the project has to already exist. + rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) + -- Compute what we should create the branch from. - createFrom <- + mayNewBranchCausalHash <- case sourceI of Input.BranchSourceI'CurrentContext -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath - Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch) - Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness + Cli.getProjectRoot >>= \case + projectRoot -> do + pure Branch.headHash projectRoot + Input.BranchSourceI'Empty -> do + pure Nothing Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do currentPath <- Cli.getCurrentPath pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath)) @@ -80,13 +84,7 @@ handleBranch sourceI projectAndBranchNames0 = do ProjectAndBranch Nothing b -> That b ProjectAndBranch (Just p) b -> These p b - project <- - Cli.runTransactionWithRollback \rollback -> do - Queries.loadProjectByName projectName & onNothingM do - -- We can't make the *first* branch of a project with `branch`; the project has to already exist. - rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - - _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames) + _ <- doCreateBranch newBranchCausalHashId project newBranchName ("branch " <> into @Text projectAndBranchNames) Cli.respond $ Output.CreatedProjectBranch @@ -95,47 +93,27 @@ handleBranch sourceI projectAndBranchNames0 = do if sourceBranch ^. #project . #projectId == project ^. #projectId then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name) else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch - CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness ) projectAndBranchNames -- | @doCreateBranch createFrom project branch description@: -- --- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@) --- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog. --- 3. cds to the new branch in the root namespace. +-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@). +-- 3. Switches to the new branch. -- -- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the -- @release.draft@ command, which essentially just creates a branch, but with some different output for the user. -- -- Returns the branch id of the newly-created branch. -doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId -doCreateBranch createFrom project newBranchName description = do - sourceNamespaceObject <- - case createFrom of - CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do - let sourceProjectId = sourceBranch ^. #projectId - let sourceBranchId = sourceBranch ^. #branchId - Cli.getBranchFromProjectRootPath (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) - _ -> Nothing - doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description - -doCreateBranch' :: - Branch IO -> +doCreateBranch :: + CausalHashId -> Maybe ProjectBranchId -> Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> Text -> Cli ProjectBranchId -doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do +doCreateBranch newBranchCausalId parentBranchId project getNewBranchName description = do let projectId = project ^. #projectId newBranchId <- Cli.runTransactionWithRollback \rollback -> do @@ -152,12 +130,11 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de branchId = newBranchId, name = newBranchName, parentBranchId = parentBranchId, - rootCausalHash = error "TODO: implement doCreateBranch" + causalHashId = newBranchCausalId } Queries.setMostRecentBranch projectId newBranchId pure newBranchId - let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId) - _ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject) - Cli.cd newBranchPath + -- TODO: Switch to new branch + Cli.switch newBranchPath pure newBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs index 21b41511b0..ad34073506 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs @@ -17,7 +17,7 @@ moveBranchFunc hasConfirmed src' dest' = do let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs) when (isRootMove && not hasConfirmed) do Cli.returnEarly MoveRootBranchConfirmation - Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do + Cli.getMaybeBranchFromProjectRootPath srcAbs >>= traverse \srcBranch -> do -- We want the move to appear as a single step in the root namespace, but we need to make -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of -- those changes such that they appear as a single change in the root. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 88b75a289b..f46245e9ef 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -38,7 +38,7 @@ handleNamespaceDependencies namespacePath' = do Cli.Env {codebase} <- ask path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath' branch <- - Cli.getMaybeBranch0At path & onNothingM do + Cli.getMaybeBranch0FromProjectRootPath path & onNothingM do Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path))) externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index 87329e00d4..d1ec6cc978 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -60,10 +60,8 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do Queries.loadMostRecentBranch (project ^. #projectId) >>= \case Nothing -> do let branchName = unsafeFrom @Text "main" - branch <- - Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do + Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) - setMostRecentBranch branch Just branchId -> Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case Nothing -> error "impossible" @@ -71,12 +69,6 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do _ -> do projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 Cli.runTransactionWithRollback \rollback -> do - branch <- - 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 + Queries.loadProjectBranchByNames projectName branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) + Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 72ed90dacd..de4e39c473 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -108,7 +108,7 @@ handleUpdate2 = do tuf <- Cli.expectLatestTypecheckedFile let termAndDeclNames = getTermAndDeclNames tuf currentPath <- Cli.getCurrentPath - currentBranch0 <- Cli.getBranch0At currentPath + currentBranch0 <- Cli.getCurrentBranch0 let namesIncludingLibdeps = Branch.toNames currentBranch0 let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment)) let ctorNames = forwardCtorNames namesExcludingLibdeps diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 8c18fd047b..4fc5a75239 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -13,7 +13,7 @@ module Unison.Codebase.Editor.Input PatchPath, BranchId, AbsBranchId, - LooseCodeOrProject, + UnresolvedProjectBranch, parseBranchId, parseBranchId2, parseShortCausalHash, @@ -64,11 +64,8 @@ data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath type BranchId = Either ShortCausalHash Path' --- | A lot of commands can take either a loose code path or a project branch in the same argument slot. Usually, those --- have distinct syntaxes, but sometimes it's ambiguous, in which case we'd parse a `These`. The command itself can --- decide what to do with the ambiguity. -type LooseCodeOrProject = - These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +-- | An unambiguous project branch name, use the current project name if not provided. +type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName type AbsBranchId = Either ShortCausalHash Path.Absolute @@ -108,8 +105,8 @@ data Input -- clone w/o merge, error if would clobber ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath | -- merge first causal into destination - MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode - | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject + MergeLocalBranchI UnresolvedProjectBranch UnresolvedProjectBranch Branch.MergeMode + | PreviewMergeLocalBranchI UnresolvedProjectBranch UnresolvedProjectBranch | DiffNamespaceI BranchId BranchId -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput @@ -119,7 +116,7 @@ data Input (Either ShortCausalHash Path') (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ) - (Maybe LooseCodeOrProject) + (Maybe UnresolvedProjectBranch) | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? -- used in Welcome module to give directions to user @@ -248,8 +245,8 @@ data BranchSourceI BranchSourceI'CurrentContext | -- | Create an empty branch BranchSourceI'Empty - | -- | Create a branch from this loose-code-or-project - BranchSourceI'LooseCodeOrProject LooseCodeOrProject + | -- | Create a branch from this other branch + BranchSourceI'LooseCodeOrProject UnresolvedProjectBranch deriving stock (Eq, Show) data DiffNamespaceToPatchInput = DiffNamespaceToPatchInput diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index 6b63811bba..65942f5db9 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -2,21 +2,17 @@ module Unison.CommandLine.BranchRelativePath ( BranchRelativePath (..), parseBranchRelativePath, branchRelativePathParser, - ResolvedBranchRelativePath (..), parseIncrementalBranchRelativePath, IncrementalBranchRelativePath (..), ) where -import Control.Lens (view) import Data.Set qualified as Set import Data.Text qualified as Text import Data.These (These (..)) import Text.Builder qualified import Text.Megaparsec qualified as Megaparsec import Text.Megaparsec.Char qualified as Megaparsec -import U.Codebase.Sqlite.Project qualified as Sqlite -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Prelude @@ -26,8 +22,11 @@ import Unison.Util.ColorText qualified as CT import Unison.Util.Pretty qualified as P data BranchRelativePath - = BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative) - | LoosePath Path.Path' + = -- | A path rooted at some specified branch/project + BranchPathInCurrentProject ProjectBranchName Path.Absolute + | QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute + | -- | A path which is relative to the user's current location. + UnqualifiedPath Path.Path' deriving stock (Eq, Show) -- | Strings without colons are parsed as loose code paths. A path with a colon may specify: @@ -53,56 +52,37 @@ parseBranchRelativePath str = Left e -> Left (P.string (Megaparsec.errorBundlePretty e)) Right x -> Right x +-- | +-- >>> from @BranchRelativePath @Text (BranchPathInCurrentProject "foo" (Path.absoluteEmpty "bar")) instance From BranchRelativePath Text where from = \case - BranchRelative brArg -> case brArg of - This eitherProj -> - Text.Builder.run - ( Text.Builder.text (eitherProjToText eitherProj) - <> Text.Builder.char ':' - ) - That path -> - Text.Builder.run - ( Text.Builder.char ':' - <> Text.Builder.text (Path.convert path) - ) - These eitherProj path -> - Text.Builder.run - ( Text.Builder.text (eitherProjToText eitherProj) - <> Text.Builder.char ':' - <> Text.Builder.text (Path.convert path) - ) - LoosePath path -> Path.toText' path - where - eitherProjToText = \case - Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName) - Right (projName, branchName) -> into @Text (These projName branchName) - -data ResolvedBranchRelativePath - = ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative) - | ResolvedLoosePath Path.Absolute - -instance From ResolvedBranchRelativePath BranchRelativePath where - from = \case - ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of - Nothing -> BranchRelative (This (Right (view #name proj, view #name branch))) - Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel) - ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p) - -instance From ResolvedBranchRelativePath Text where - from = from . into @BranchRelativePath + BranchPathInCurrentProject branch path -> + Text.Builder.run $ + Text.Builder.char '/' + <> Text.Builder.text (into @Text branch) + <> Text.Builder.char ':' + <> Text.Builder.text (Path.absToText path) + QualifiedBranchPath proj branch path -> + Text.Builder.run $ + Text.Builder.text (into @Text proj) + <> Text.Builder.char '/' + <> Text.Builder.text (into @Text branch) + <> Text.Builder.char ':' + <> Text.Builder.text (Path.absToText path) + UnqualifiedPath path -> + Path.toText' path data IncrementalBranchRelativePath - = -- | no dots, slashes, or colons - ProjectOrRelative Text Path.Path' - | -- | dots, no slashes or colons - LooseCode Path.Path' + = -- | no dots, slashes, or colons, so could be a project name or a single path segment + ProjectOrPath' Text Path.Path' + | -- | dots, no slashes or colons, must be a relative or absolute path + OnlyPath' Path.Path' | -- | valid project, no slash IncompleteProject ProjectName | -- | valid project/branch, slash, no colon IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName) | -- | valid project/branch, with colon - IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative) + IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Absolute) | PathRelativeToCurrentBranch Path.Relative deriving stock (Show) @@ -159,9 +139,9 @@ incrementalBranchRelativePathParser = pure (IncompleteProject projectName) in end <|> startingAtSlash (Just projectName) -- The string doesn't parse as a project name but does parse as a path - That (_, path) -> pure (LooseCode path) + That (_, path) -> pure (OnlyPath' path) -- The string parses both as a project name and a path - These _ (_, path) -> ProjectOrRelative <$> Megaparsec.takeRest <*> pure path + These _ (_, path) -> ProjectOrPath' <$> Megaparsec.takeRest <*> pure path startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath startingAtBranch mproj = @@ -181,7 +161,7 @@ incrementalBranchRelativePathParser = Megaparsec.Parsec Void Text IncrementalBranchRelativePath startingAtColon projStuff = do _ <- Megaparsec.char ':' - p <- optionalEof relPath + p <- optionalEof absPath pure (IncompletePath projStuff p) pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath @@ -191,18 +171,25 @@ incrementalBranchRelativePathParser = pure (PathRelativeToCurrentBranch p) optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a) - optionalEof pa = Just <$> pa <|> Nothing <$ Megaparsec.eof + optionalEof pa = Just <$> pa <|> (Nothing <$ Megaparsec.eof) optionalBranch :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName) optionalBranch = optionalEof branchNameParser branchNameParser = Project.projectBranchNameParser False + relPath :: Megaparsec.Parsec Void Text Path.Relative relPath = do offset <- Megaparsec.getOffset path' >>= \(Path.Path' inner) -> case inner of Left _ -> failureAt offset "Expected a relative path but found an absolute path" Right x -> pure x + absPath :: Megaparsec.Parsec Void Text Path.Absolute + absPath = do + offset <- Megaparsec.getOffset + path' >>= \(Path.Path' inner) -> case inner of + Left p -> pure p + Right _ -> failureAt offset "Expected an absolute path but found a relative path. Try adding a leading '.' to your path" path' = Megaparsec.try do offset <- Megaparsec.getOffset pathStr <- Megaparsec.takeRest @@ -235,16 +222,14 @@ incrementalBranchRelativePathParser = branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath branchRelativePathParser = incrementalBranchRelativePathParser >>= \case - ProjectOrRelative _txt path -> pure (LoosePath path) - LooseCode path -> pure (LoosePath path) + ProjectOrPath' _txt path -> pure (UnqualifiedPath path) + OnlyPath' path -> pure (UnqualifiedPath path) IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here." IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here." - PathRelativeToCurrentBranch p -> pure (BranchRelative (That p)) + PathRelativeToCurrentBranch p -> pure (UnqualifiedPath (Path.RelativePath' p)) IncompletePath projStuff mpath -> case projStuff of - Left (ProjectAndBranch projName branchName) -> case mpath of - Nothing -> pure (BranchRelative (This (Right (projName, branchName)))) - Just path -> pure (BranchRelative (These (Right (projName, branchName)) path)) - Right branch -> case mpath of - Nothing -> pure (BranchRelative (This (Left branch))) - Just path -> pure (BranchRelative (These (Left branch) path)) + Left (ProjectAndBranch projName branchName) -> + pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath) + Right branch -> + pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 5241e00979..a30fa71e57 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -20,9 +20,8 @@ module Unison.CommandLine.Completion ) where -import Control.Lens (ifoldMap) +import Control.Lens import Control.Lens qualified as Lens -import Control.Lens.Cons (unsnoc) import Data.Aeson qualified as Aeson import Data.List (isPrefixOf) import Data.List qualified as List @@ -146,7 +145,7 @@ completeWithinNamespace :: Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength - b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing + b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.ctxAsIds_) currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib @@ -169,8 +168,8 @@ completeWithinNamespace compTypes query ppCtx = do queryPathPrefix :: Path.Path' querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) - absQueryPath :: Path.Absolute - absQueryPath = Path.resolve ppCtx queryPathPrefix + queryProjectPath :: PP.ProjectPathCtx + queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion] getChildSuggestions shortHashLen b | Text.null querySuffix = pure [] diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 88c57c8183..6ad9c77e6b 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -85,6 +85,8 @@ import System.Environment (getExecutablePath) import System.FilePath (()) import System.FilePath qualified as FilePath import System.Random.MWC (createSystemRandom) +import U.Codebase.Branch qualified as V2 +import U.Codebase.Causal qualified as Causal import U.Codebase.HashTags (CausalHash) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -589,34 +591,38 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do where projectAndBranchName = ProjectAndBranch projectName branchName namespaceListingEndpoint _rootParam rel name = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName + root <- resolveProjectRootHash codebase projectAndBranchName setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth -resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash +resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO (V2.CausalBranch Sqlite.Transaction) resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do - mayCH <- liftIO . Codebase.runTransaction codebase $ Codebase.causalHashForProjectBranchName @IO projectAndBranchName - case mayCH of + mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName + case mayCB of Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) - Just ch -> pure ch + Just cb -> pure cb + +resolveProjectRootHash :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash +resolveProjectRootHash codebase projectAndBranchName = do + resolveProjectRoot codebase projectAndBranchName <&> Causal.causalHash 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 @@ -639,7 +645,7 @@ serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) contextForProjectBranch codebase projectName branchName = do - projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName) + projectRootHash <- resolveProjectRootHash codebase (ProjectAndBranch projectName branchName) projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength let names = Branch.toNames (Branch.head projectRootBranch) From 29fd307ad9751e05a416f23d3d8b1c9a99ebe22e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 23 May 2024 10:22:59 -0700 Subject: [PATCH 09/76] Checkpoint --- parser-typechecker/src/Unison/Codebase.hs | 17 ++- .../src/Unison/Codebase/ProjectPath.hs | 81 ++++++++------ unison-cli/src/Unison/Cli/MonadUtils.hs | 12 +-- unison-cli/src/Unison/Cli/ProjectUtils.hs | 82 +++++++------- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +- .../Codebase/Editor/HandleInput/Branch.hs | 93 ++++++---------- .../Codebase/Editor/HandleInput/Upgrade.hs | 9 +- .../src/Unison/Codebase/Editor/Input.hs | 6 +- unison-cli/src/Unison/CommandLine.hs | 4 +- .../src/Unison/CommandLine/Completion.hs | 16 +-- .../src/Unison/CommandLine/FZFResolvers.hs | 6 +- .../src/Unison/CommandLine/InputPattern.hs | 11 +- .../src/Unison/CommandLine/InputPatterns.hs | 100 ++++++------------ unison-cli/src/Unison/CommandLine/Main.hs | 2 +- .../Unison/Server/Local/Endpoints/Current.hs | 10 +- 15 files changed, 207 insertions(+), 246 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index db197aa5ed..b02dd27494 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -2,7 +2,7 @@ module Unison.Codebase ( Codebase, -- * UCM session state - loadCurrentProjectPathCtx, + loadCurrentProjectPath, setCurrentProjectPath, -- * Terms @@ -126,7 +126,6 @@ import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId qualified as Db 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 Q import U.Codebase.Sqlite.Queries qualified as Queries @@ -565,16 +564,16 @@ unsafeGetTermComponent codebase hash = Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms -loadCurrentProjectPathCtx :: Sqlite.Transaction (Maybe PP.ProjectPathCtx) -loadCurrentProjectPathCtx = do - mProjectPath <- Q.loadCurrentProjectPath - case mProjectPath of +loadCurrentProjectPath :: Sqlite.Transaction (Maybe PP.ProjectPath) +loadCurrentProjectPath = do + mProjectInfo <- Q.loadCurrentProjectPath + case mProjectInfo of Nothing -> pure Nothing Just (projectId, projectBranchId, path) -> do - Project {name = projectName} <- Q.expectProject projectId - ProjectBranch {name = branchName} <- Q.expectProjectBranch projectId projectBranchId + proj <- Q.expectProject projectId + projBranch <- Q.expectProjectBranch projectId projectBranchId let absPath = Path.Absolute (Path.fromList path) - pure $ Just (PP.ProjectPath (projectId, projectName) (projectBranchId, branchName) absPath) + pure $ Just (PP.ProjectPath proj projBranch absPath) setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 4f6bbe30f2..a11b7ccd23 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -1,16 +1,16 @@ module Unison.Codebase.ProjectPath - ( ProjectPath (..), + ( ProjectPathG (..), ProjectPathIds, ProjectPathNames, - ProjectPathCtx, + ProjectPath, fromProjectAndBranch, - ctxFromProjectAndBranch, absPath_, path_, projectAndBranch_, toText, - ctxAsIds_, - ctxAsNames_, + asIds_, + asNames_, + asProjectAndBranch_, project_, branch_, ) @@ -26,74 +26,85 @@ import Unison.Codebase.Path qualified as Path import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) -data ProjectPath proj branch = ProjectPath +data ProjectPathG proj branch = ProjectPath { projPathProject :: proj, projPathBranch :: branch, projPathPath :: Path.Absolute } deriving stock (Eq, Ord, Show) -type ProjectPathIds = ProjectPath ProjectId ProjectBranchId +type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId -type ProjectPathNames = ProjectPath ProjectName ProjectBranchName +type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName -type ProjectPathCtx = ProjectPath (ProjectId, ProjectName) (ProjectBranchId, ProjectBranchName) +type ProjectPath = ProjectPathG Project ProjectBranch -fromProjectAndBranch :: ProjectAndBranch proj branch -> Path.Absolute -> ProjectPath proj branch -fromProjectAndBranch (ProjectAndBranch proj branch) = ProjectPath proj branch +fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath +fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path -ctxFromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPathCtx -ctxFromProjectAndBranch (ProjectAndBranch (Project {projectId, name = projectName}) (ProjectBranch {branchId, name = branchName})) = ProjectPath (projectId, projectName) (branchId, branchName) - -project_ :: Lens' (ProjectPath p b) p -project_ = lens go set +project_ :: Lens' (ProjectPathG p b) p +project_ = lens get set where - go (ProjectPath p _ _) = p + get (ProjectPath p _ _) = p set (ProjectPath _ b path) p = ProjectPath p b path -branch_ :: Lens' (ProjectPath p b) b -branch_ = lens go set +branch_ :: Lens' (ProjectPathG p b) b +branch_ = lens get set where - go (ProjectPath _ b _) = b + get (ProjectPath _ b _) = b set (ProjectPath p _ path) b = ProjectPath p b path -- | Project a project context into a project path of just IDs -ctxAsIds_ :: Lens' ProjectPathCtx ProjectPathIds -ctxAsIds_ = lens go set +asIds_ :: Lens' ProjectPath ProjectPathIds +asIds_ = lens get set where - go (ProjectPath (pid, _) (bid, _) p) = ProjectPath pid bid p - set (ProjectPath (_, pName) (_, bName) _) (ProjectPath pid bid p) = ProjectPath (pid, pName) (bid, bName) p + get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path + set p (ProjectPath pId bId path) = + p + & project_ . #projectId .~ pId + & branch_ . #branchId .~ bId + & absPath_ .~ path -- | Project a project context into a project path of just names -ctxAsNames_ :: Lens' ProjectPathCtx ProjectPathNames -ctxAsNames_ = lens go set +asNames_ :: Lens' ProjectPath ProjectPathNames +asNames_ = lens get set + where + get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path + set p (ProjectPath pName bName path) = + p + & project_ . #name .~ pName + & branch_ . #name .~ bName + & absPath_ .~ path + +asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch) +asProjectAndBranch_ = lens get set where - go (ProjectPath (_, pName) (_, bName) path) = ProjectPath pName bName path - set (ProjectPath (pId, _) (bId, _) _) (ProjectPath pName bName path) = ProjectPath (pId, pName) (bId, bName) path + get (ProjectPath proj branch _) = ProjectAndBranch proj branch + set p (ProjectAndBranch proj branch) = p & project_ .~ proj & branch_ .~ branch -instance Bifunctor ProjectPath where +instance Bifunctor ProjectPathG where bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path -instance Bifoldable ProjectPath where +instance Bifoldable ProjectPathG where bifoldMap f g (ProjectPath p b _) = f p <> g b -instance Bitraversable ProjectPath where +instance Bitraversable ProjectPathG where bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path -toText :: ProjectPath ProjectName ProjectBranchName -> Text +toText :: ProjectPathG ProjectName ProjectBranchName -> Text toText (ProjectPath projName branchName path) = into @Text projName <> "/" <> into @Text branchName <> ":" <> Path.absToText path -absPath_ :: Lens' (ProjectPath p b) Path.Absolute +absPath_ :: Lens' (ProjectPathG p b) Path.Absolute absPath_ = lens go set where go (ProjectPath _ _ p) = p set (ProjectPath n b _) p = ProjectPath n b p -path_ :: Lens' (ProjectPath p b) Path.Path +path_ :: Lens' (ProjectPathG p b) Path.Path path_ = absPath_ . Path.absPath_ -projectAndBranch_ :: Lens' (ProjectPath p b) (ProjectAndBranch p b) +projectAndBranch_ :: Lens' (ProjectPathG p b) (ProjectAndBranch p b) projectAndBranch_ = lens go set where go (ProjectPath proj branch _) = ProjectAndBranch proj branch diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 78308eae67..6eb5a755f6 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -8,7 +8,7 @@ module Unison.Cli.MonadUtils getCurrentPath, getCurrentProjectName, getCurrentProjectBranchName, - getProjectPathCtx, + getProjectPath, resolvePath, resolvePath', resolveSplit', @@ -146,8 +146,8 @@ getConfig key = do ------------------------------------------------------------------------------------------------------------------------ -- Getting paths, path resolution, etc. -getProjectPathCtx :: Cli PP.ProjectPathCtx -getProjectPathCtx = do +getProjectPath :: Cli PP.ProjectPath +getProjectPath = do (PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds -- TODO: Reset to a valid project on error. (Project {name = projName}, ProjectBranch {name = branchName}) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do @@ -159,15 +159,15 @@ getProjectPathCtx = do -- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - view PP.absPath_ <$> getProjectPathCtx + view PP.absPath_ <$> getProjectPath getCurrentProjectName :: Cli ProjectName getCurrentProjectName = do - view (PP.ctxAsNames_ . PP.project_) <$> getProjectPathCtx + view (PP.ctxAsNames_ . PP.project_) <$> getProjectPath getCurrentProjectBranchName :: Cli ProjectBranchName getCurrentProjectBranchName = do - view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPathCtx + view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPath -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. resolvePath :: Path -> Cli Path.Absolute diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 07a7e93a1f..6ed7ff03e7 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -3,6 +3,8 @@ module Unison.Cli.ProjectUtils ( -- * Project/path helpers expectProjectBranchByName, resolveBranchRelativePath, + resolveProjectPath, + resolveProjectBranch, -- * Name hydration hydrateNames, @@ -11,7 +13,8 @@ module Unison.Cli.ProjectUtils expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, - expectLooseCodeOrProjectBranch, + getCurrentProject, + getCurrentProjectBranch, -- * Loading remote project info expectRemoteProjectById, @@ -30,13 +33,14 @@ module Unison.Cli.ProjectUtils where import Control.Lens -import Control.Monad.Trans.Maybe (mapMaybeT) import Data.List qualified as List import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.These (These (..)) import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project) import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -44,7 +48,6 @@ 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.Editor.Input (LooseCodeOrProject) import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path') @@ -58,7 +61,7 @@ import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPathCtx +resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath resolveBranchRelativePath brp = do case brp of BranchPathInCurrentProject projBranchName path -> do @@ -68,7 +71,7 @@ resolveBranchRelativePath brp = do projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) pure $ PP.ctxFromProjectAndBranch projectAndBranch path UnqualifiedPath newPath' -> do - ppCtx <- Cli.getProjectPathCtx + ppCtx <- Cli.getProjectPath pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name @@ -93,24 +96,24 @@ findTemporaryBranchName projectId preferred = do pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates)) -- | Get the current project+branch+branch path that a user is on. -getCurrentProjectBranch :: Cli (Maybe (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch)) -getCurrentProjectBranch = runMaybeT do - ppCtx <- lift Cli.getProjectPathCtx - mapMaybeT Cli.runTransaction $ do - proj <- MaybeT $ Queries.loadProject (ppCtx ^. PP.ctxAsIds_ . PP.project_) - branch <- MaybeT $ Queries.loadProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_) +getCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch) +getCurrentProjectBranch = do + ppCtx <- Cli.getProjectPath + Cli.runTransaction $ do + proj <- Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_) + branch <- Queries.expectProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_) pure $ PP.ProjectPath proj branch (ppCtx ^. PP.absPath_) +getCurrentProject :: Cli Sqlite.Project +getCurrentProject = do + ppCtx <- Cli.getProjectPath + Cli.runTransaction (Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_)) + expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch expectProjectBranchByName project branchName = Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) --- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch. -expectCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch) -expectCurrentProjectBranch = - getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch) - -- We often accept a `These ProjectName ProjectBranchName` from the user, so they can leave off either a project or -- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following -- defaults if a name is missing: @@ -121,7 +124,7 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do - ppCtx <- Cli.getProjectPathCtx + ppCtx <- Cli.getProjectPath pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) @@ -144,7 +147,7 @@ getProjectAndBranchByTheseNames :: getProjectAndBranchByTheseNames = \case This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> runMaybeT do - currentProjectBranch <- MaybeT getCurrentProjectBranch + currentProjectBranch <- lift getCurrentProjectBranch branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName)) pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch) These projectName branchName -> do @@ -164,7 +167,7 @@ expectProjectAndBranchByTheseNames :: expectProjectAndBranchByTheseNames = \case This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> do - PP.ProjectPath project _branch _restPath <- expectCurrentProjectBranch + PP.ProjectPath project _branch _restPath <- getCurrentProjectBranch branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) @@ -179,24 +182,29 @@ expectProjectAndBranchByTheseNames = \case maybeProjectAndBranch & onNothing do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) --- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules: +-- | Expect/resolve a branch-relative path with the following rules: -- --- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database. --- 2. If we have an unambiguous `loose.code.path`, just return it. --- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*, --- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash). -expectLooseCodeOrProjectBranch :: - These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> - Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -expectLooseCodeOrProjectBranch = - _Right expectProjectAndBranchByTheseNames . f - where - f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName) - f = \case - This path -> Left path - That (ProjectAndBranch Nothing branch) -> Right (That branch) - That (ProjectAndBranch (Just project) branch) -> Right (These project branch) - These path _ -> Left path -- (3) above +-- 1. If the project is missing, use the current project. +-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current +-- project, defaulting to 'main' if branch is unspecified. +-- 3. If we just have a path, resolve it using the current project. +resolveProjectPath :: PP.ProjectPath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath +resolveProjectPath ppCtx mayProjAndBranch mayPath' = do + projAndBranch <- resolveProjectBranch ppCtx mayProjAndBranch + absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath' + pure $ PP.ctxFromProjectAndBranch projAndBranch absPath + +-- | Expect/resolve branch reference with the following rules: +-- +-- 1. If the project is missing, use the provided project. +-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided +-- project, defaulting to 'main' if branch is unspecified. +resolveProjectBranch :: ProjectAndBranch Project ProjectBranch -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranch ppCtx (ProjectAndBranch mayProjectName mayBranchName) = do + let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName + let projectName = fromMaybe (ppCtx ^. PP.ctxAsNames_ . PP.project_) mayProjectName + projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName) + pure projectAndBranch ------------------------------------------------------------------------------------------------------------------------ -- Remote project utils @@ -281,7 +289,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case let remoteBranchName = unsafeFrom @Text "main" expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) That branchName -> do - PP.ProjectPath localProject localBranch _restPath <- expectCurrentProjectBranch + PP.ProjectPath localProject localBranch _restPath <- getCurrentProjectBranch let localProjectId = localProject ^. #projectId let localBranchId = localBranch ^. #branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 30f8a48a37..8e9544fe82 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1037,7 +1037,7 @@ loop e = do Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms DebugTabCompletionI inputs -> do Cli.Env {authHTTPClient, codebase} <- ask - ppCtx <- Cli.getProjectPathCtx + ppCtx <- Cli.getProjectPath let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient ppCtx (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "") Cli.respond (DisplayDebugCompletions completions) @@ -1048,7 +1048,7 @@ loop e = do Just (IP.InputPattern {args = argTypes}) -> do zip argTypes args & Monoid.foldMapM \case ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do - ppCtx <- Cli.getProjectPathCtx + ppCtx <- Cli.getProjectPath results <- liftIO $ getOptions codebase ppCtx currentBranch Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 3d1a0549e5..8df791dec7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,18 +1,16 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch ( handleBranch, - CreateFrom (..), doCreateBranch, - doCreateBranch', ) where -import Control.Lens ((^.)) -import Data.These (These (..)) +import Control.Lens import Data.UUID.V4 qualified as UUID -import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -20,23 +18,18 @@ import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Branch qualified as Branch (empty, headHash) +import Unison.Codebase.Branch qualified as Branch (headHash) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) import Unison.Sqlite qualified as Sqlite -- | Create a new project branch from an existing project branch or namespace. handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleBranch sourceI projectAndBranchNames0 = do - projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <- - case projectAndBranchNames0 of - ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName) - ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName) - +handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do -- You can only create release branches with `branch.clone` -- -- We do allow creating draft release branches with `branch`, but you'll get different output if you use @@ -48,52 +41,35 @@ handleBranch sourceI projectAndBranchNames0 = do Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () - srcProject <- - Cli.runTransactionWithRollback \rollback -> do - Queries.loadProjectByName projectName & onNothingM do - -- We can't make the *first* branch of a project with `branch`; the project has to already exist. - rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) + currentProjectName <- Cli.getProjectPath <&> view (PP.ctxAsNames_ . PP.project_) + destProject <- do + Cli.runTransactionWithRollback + \rollback -> do + let projectName = (fromMaybe currentProjectName mayProjectName) + Queries.loadProjectByName projectName & onNothingM do + -- We can't make the *first* branch of a project with `branch`; the project has to already exist. + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName)) -- Compute what we should create the branch from. - mayNewBranchCausalHash <- + maySrcBranch <- case sourceI of - Input.BranchSourceI'CurrentContext -> - Cli.getProjectRoot >>= \case - projectRoot -> do - pure Branch.headHash projectRoot - Input.BranchSourceI'Empty -> do - pure Nothing - Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do - currentPath <- Cli.getCurrentPath - pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath)) - Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) -> - fmap CreateFrom'Branch do - ProjectUtils.expectProjectAndBranchByTheseNames - case sourceBranch of - ProjectAndBranch Nothing b -> That b - ProjectAndBranch (Just p) b -> These p b - -- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a - -- branch from a relative one-segment namespace. - -- - -- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they - -- really meant create a branch from that namespace. - Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) -> - fmap CreateFrom'Branch do - ProjectUtils.expectProjectAndBranchByTheseNames - case sourceBranch of - ProjectAndBranch Nothing b -> That b - ProjectAndBranch (Just p) b -> These p b + Input.BranchSourceI'CurrentContext -> Just <$> ProjectUtils.getCurrentProjectBranch + Input.BranchSourceI'Empty -> pure Nothing + Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do + ppCtx <- Cli.getProjectPath + ProjectAndBranch _proj branch <- ProjectUtils.resolveProjectBranch ppCtx (unresolvedProjectBranch & #branch %~ Just) + pure $ Just branch - _ <- doCreateBranch newBranchCausalHashId project newBranchName ("branch " <> into @Text projectAndBranchNames) + _ <- doCreateBranch maySrcBranch project newBranchName Cli.respond $ Output.CreatedProjectBranch - ( case createFrom of - CreateFrom'Branch sourceBranch -> + ( case maySrcBranch of + Just sourceBranch -> if sourceBranch ^. #project . #projectId == project ^. #projectId then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name) else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch - CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness + Nothing -> Output.CreatedProjectBranchFrom'Nothingness ) projectAndBranchNames @@ -107,13 +83,12 @@ handleBranch sourceI projectAndBranchNames0 = do -- -- Returns the branch id of the newly-created branch. doCreateBranch :: - CausalHashId -> - Maybe ProjectBranchId -> + -- If no parent branch is provided, make an empty branch. + Maybe Sqlite.ProjectBranch -> Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> - Text -> Cli ProjectBranchId -doCreateBranch newBranchCausalId parentBranchId project getNewBranchName description = do +doCreateBranch mayParentBranch project getNewBranchName = do let projectId = project ^. #projectId newBranchId <- Cli.runTransactionWithRollback \rollback -> do @@ -124,17 +99,19 @@ doCreateBranch newBranchCausalId parentBranchId project getNewBranchName descrip -- Here, we are forking to `foo/bar`, where project `foo` does exist, and it does not have a branch named -- `bar`, so the fork will succeed. newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) + newBranchCausalHashId <- + (ProjectBranch.causalHashId <$> mayParentBranch) `whenNothing` do + (_, causalHashId) <- Codebase.emptyCausalHash + pure causalHashId Queries.insertProjectBranch Sqlite.ProjectBranch { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = parentBranchId, - causalHashId = newBranchCausalId + parentBranchId = ProjectBranch.branchId <$> mayParentBranch, + causalHashId = newBranchCausalHashId } - Queries.setMostRecentBranch projectId newBranchId pure newBranchId - -- TODO: Switch to new branch - Cli.switch newBranchPath + Cli.switchProject (ProjectAndBranch projectId newBranchId) pure newBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index aab5144e18..03da23b53f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -65,13 +65,10 @@ handleUpgrade oldName newName = do Cli.Env {codebase, writeSource} <- ask - (projectAndBranch, _path) <- Cli.expectCurrentProjectBranch - let projectId = projectAndBranch ^. #project . #projectId - let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId (projectAndBranch ^. #branch . #branchId)) - let oldPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldName])) - let newPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newName])) + let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName]) + let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName]) - currentNamespace <- Cli.getBranch0At projectPath + currentNamespace <- Cli.getProjectRoot0 let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index e74724c8c4..427d901fb4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -105,8 +105,8 @@ data Input -- clone w/o merge, error if would clobber ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath | -- merge first causal into destination - MergeLocalBranchI UnresolvedProjectBranch UnresolvedProjectBranch Branch.MergeMode - | PreviewMergeLocalBranchI UnresolvedProjectBranch UnresolvedProjectBranch + MergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) Branch.MergeMode + | PreviewMergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) | DiffNamespaceI BranchId BranchId -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput @@ -246,7 +246,7 @@ data BranchSourceI | -- | Create an empty branch BranchSourceI'Empty | -- | Create a branch from this other branch - BranchSourceI'LooseCodeOrProject UnresolvedProjectBranch + BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch deriving stock (Eq, Show) data DiffNamespaceToPatchInput = DiffNamespaceToPatchInput diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 8291b7e9fb..cf922597e6 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -120,7 +120,7 @@ nothingTodo = emojiNote "😶" parseInput :: Codebase IO Symbol Ann -> -- | Current location - PP.ProjectPathCtx -> + PP.ProjectPath -> IO (Branch.Branch IO) -> -- | Numbered arguments [String] -> @@ -194,7 +194,7 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPathCtx -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) +fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) fzfResolve codebase ppCtx 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. diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index a30fa71e57..bd0cf9c0e0 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -73,7 +73,7 @@ haskelineTabComplete :: Map String IP.InputPattern -> Codebase m v a -> AuthenticatedHttpClient -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Line.CompletionFunc m haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWordWithPrev Nothing " " $ \prev word -> -- User hasn't finished a command name, complete from command names @@ -141,7 +141,7 @@ completeWithinNamespace :: NESet CompletionType -> -- | The portion of this are that the user has already typed. String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength @@ -168,7 +168,7 @@ completeWithinNamespace compTypes query ppCtx = do queryPathPrefix :: Path.Path' querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) - queryProjectPath :: PP.ProjectPathCtx + queryProjectPath :: PP.ProjectPath queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion] getChildSuggestions shortHashLen b @@ -274,35 +274,35 @@ parseLaxPath'Query txt = -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteTermOrType :: String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion])) -- | Completes a term argument by prefix-matching against the query. prefixCompleteTerm :: String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion) -- | Completes a term or type argument by prefix-matching against the query. prefixCompleteType :: String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion) -- | Completes a patch argument by prefix-matching against the query. prefixCompletePatch :: String -> - PP.ProjectPathCtx -> + PP.ProjectPath -> Sqlite.Transaction [Line.Completion] prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion) diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index 79a3f9fcfc..2d3b8a8216 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -51,7 +51,7 @@ import Unison.Util.Monoid (foldMapM) import Unison.Util.Monoid qualified as Monoid import Unison.Util.Relation qualified as Relation -type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPathCtx -> Branch0 IO -> IO [Text] +type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text] data FZFResolver = FZFResolver { getOptions :: OptionFetcher @@ -121,7 +121,7 @@ fuzzySelectFromList options = -- | Combine multiple option fetchers into one resolver. multiResolver :: [OptionFetcher] -> FZFResolver multiResolver resolvers = - let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPathCtx -> Branch0 IO -> IO [Text] + let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text] getOptions codebase projCtx searchBranch0 = do List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers in (FZFResolver {getOptions}) @@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.ctxAsIds_ . PP.project_) Nothing) + Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . PP.project_) Nothing) <&> fmap (into @Text . snd) -- | Exported from here just so the debug command and actual implementation can use the same diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index e5fa556859..fc9c0d2cc3 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -25,7 +25,6 @@ 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.Path as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude @@ -68,7 +67,7 @@ data ArgumentType = ArgumentType String -> Codebase m v a -> AuthenticatedHttpClient -> - PP.ProjectPathCtx -> + PP.ProjectPath -> m [Line.Completion], -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if -- available. @@ -147,14 +146,14 @@ unionSuggestions :: [ ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) ] -> ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) unionSuggestions suggesters inp codebase httpClient path = do @@ -169,14 +168,14 @@ suggestionFallbacks :: [ ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) ] -> ( String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [Line.Completion] ) suggestionFallbacks suggesters inp codebase httpClient path = go suggesters diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index a3ce432405..45208c2547 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -147,7 +147,7 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens (preview, review, (^.)) +import Control.Lens ((^.)) import Control.Lens.Cons qualified as Cons import Data.List (intercalate) import Data.List.Extra qualified as List @@ -168,7 +168,6 @@ import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Cli.Pretty (prettyProjectAndBranchName, prettyProjectName, prettyProjectNameSlash, prettySlashProjectBranchName, prettyURI) -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Merge qualified as Branch @@ -182,7 +181,7 @@ import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path -import Unison.Codebase.ProjectPath (ProjectPathCtx) +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.CommandLine @@ -1412,7 +1411,7 @@ reset = arg0 <- branchIdOrProject arg0 arg1 <- case restArgs of [] -> pure Nothing - arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 + arg1 : [] -> Just <$> parseUnresolvedProjectBranch arg1 _ -> Nothing Just (Input.ResetI arg0 arg1) _ -> Nothing @@ -1839,8 +1838,8 @@ mergeOldSquashInputPattern = parse = maybeToEither (I.help mergeOldSquashInputPattern) . \case [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest + src <- parseUnresolvedProjectBranch src + dest <- parseUnresolvedProjectBranch dest Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge _ -> Nothing } @@ -1873,23 +1872,17 @@ mergeOldInputPattern = ), ( makeExample mergeOldInputPattern ["/topic", "foo/main"], "merges the branch `topic` of the current project into the `main` branch of the project 'foo`" - ), - ( makeExample mergeOldInputPattern [".src"], - "merges `.src` namespace into the current namespace" - ), - ( makeExample mergeOldInputPattern [".src", ".dest"], - "merges `.src` namespace into the `dest` namespace" ) ] ) ( maybeToEither (I.help mergeOldInputPattern) . \case [src] -> do - src <- parseLooseCodeOrProject src - Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge + src <- parseUnresolvedProjectBranch src + Just $ Input.MergeLocalBranchI src Nothing Branch.RegularMerge [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge + src <- parseUnresolvedProjectBranch src + dest <- parseUnresolvedProjectBranch dest + Just $ Input.MergeLocalBranchI src (Just dest) Branch.RegularMerge _ -> Nothing ) where @@ -1930,16 +1923,8 @@ mergeInputPattern = pure (Input.MergeI branch) } -parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject -parseLooseCodeOrProject inputString = - case (asLooseCode, asBranch) of - (Right path, Left _) -> Just (This path) - (Left _, Right branch) -> Just (That branch) - (Right path, Right branch) -> Just (These path branch) - (Left _, Left _) -> Nothing - where - asLooseCode = Path.parsePath' inputString - asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString) +parseUnresolvedProjectBranch :: String -> Maybe Input.UnresolvedProjectBranch +parseUnresolvedProjectBranch inputString = eitherToMaybe $ tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString) diffNamespace :: InputPattern diffNamespace = @@ -1993,12 +1978,12 @@ mergeOldPreviewInputPattern = ) ( maybeToEither (I.help mergeOldPreviewInputPattern) . \case [src] -> do - src <- parseLooseCodeOrProject src - pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') + src <- parseUnresolvedProjectBranch src + pure $ Input.PreviewMergeLocalBranchI src Nothing [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - pure $ Input.PreviewMergeLocalBranchI src dest + src <- parseUnresolvedProjectBranch src + dest <- parseUnresolvedProjectBranch dest + pure $ Input.PreviewMergeLocalBranchI src (Just dest) _ -> Nothing ) where @@ -3007,18 +2992,17 @@ branchInputPattern = help = P.wrapColumn2 [ ("`branch foo`", "forks the current project branch to a new branch `foo`"), - ("`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`") + ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`") ], parse = maybeToEither (showPatternHelp branchInputPattern) . \case [source0, name] -> do - source <- parseLooseCodeOrProject source0 + source <- parseUnresolvedProjectBranch source0 projectAndBranch <- Text.pack name & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) & eitherToMaybe - Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) + Just (Input.BranchI (Input.BranchSourceI'UnresolvedProjectBranch source) projectAndBranch) [name] -> do projectAndBranch <- Text.pack name @@ -3365,7 +3349,7 @@ namespaceOrProjectBranchArg config = ArgumentType { typeName = "namespace or branch", suggestions = - let namespaceSuggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p) + let namespaceSuggestions = \q cb _http ppCtx -> Codebase.runTransaction cb (prefixCompleteNamespace q ppCtx) in unionSuggestions [ projectAndOrBranchSuggestions config, namespaceSuggestions @@ -3478,7 +3462,7 @@ projectAndOrBranchSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - ProjectPathCtx -> + ProjectPath -> m [Line.Completion] projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do case Text.uncons input of @@ -3616,15 +3600,14 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> Path.Absolute -> m [Completion] - handleBranchesComplete branchName codebase path = do + -- Complete the text into a branch name within the provided project + handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion] + handleBranchesComplete branchName codebase ppCtx = do + let projId = ppCtx ^. PP.ctxAsIds_ . PP.project_ branches <- - case preview ProjectUtils.projectBranchPathPrism path of - Nothing -> pure [] - Just (ProjectAndBranch currentProjectId _, _) -> - Codebase.runTransaction codebase do - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) + Codebase.runTransaction codebase do + fmap (filterBranches config path) do + Queries.loadAllProjectBranchesBeginningWith projId (Just branchName) pure (map currentProjectBranchToCompletion branches) filterProjects :: [Sqlite.Project] -> [Sqlite.Project] @@ -3661,7 +3644,7 @@ handleBranchesComplete :: ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> - PP.ProjectPathCtx -> + PP.ProjectPath -> m [Completion] handleBranchesComplete config branchName codebase ppCtx = do branches <- @@ -3670,7 +3653,7 @@ handleBranchesComplete config branchName codebase ppCtx = do Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName) pure (map currentProjectBranchToCompletion branches) -filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPathCtx -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] +filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] filterBranches config ppCtx branches = case (branchInclusion config) of AllBranches -> branches @@ -3692,17 +3675,17 @@ branchRelativePathSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - PP.ProjectPathCtx -> + PP.ProjectPath -> m [Line.Completion] branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of - BranchRelativePath.ProjectOrRelative _txt _path -> do + BranchRelativePath.ProjectOrPath' _txt _path -> do namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase pure (namespaceSuggestions ++ projectSuggestions) - BranchRelativePath.LooseCode _path -> + BranchRelativePath.OnlyPath' _path -> Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) BranchRelativePath.IncompleteProject _proj -> projectNameSuggestions WithSlash inputStr codebase @@ -3723,22 +3706,9 @@ branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) mempty BranchRelativePath.IncompletePath projStuff mpath -> do Codebase.runTransaction codebase do - mprojectBranch <- runMaybeT do - case projStuff of - Left names@(ProjectAndBranch projectName branchName) -> do - (,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName) - Right branchName -> do - projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName) - pure (projectBranch, Right (projectBranch ^. #name)) - case mprojectBranch of - Nothing -> pure [] - Just (projectBranch, prefix) -> do - let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) - projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) - map (addBranchPrefix prefix) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) branchPath + map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) ppCtx where currentPath = ppCtx ^. PP.absPath_ - currentProjectId = ppCtx ^. PP.ctxAsIds_ . PP.project_ projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 26ca644d01..0d43f1cd92 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -64,7 +64,7 @@ import UnliftIO.STM getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> - PP.ProjectPathCtx -> + PP.ProjectPath -> IO (Branch IO) -> [String] -> IO Input diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index caf71afbe2..10acc76c96 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -36,7 +36,7 @@ instance ToSample Current where Current (Just $ UnsafeProjectName "@unison/base") (Just $ UnsafeProjectBranchName "main") - (Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1") + (Path.Absolute $ Path.unsafeParseText ".my.namespace") ) ] @@ -53,11 +53,11 @@ serveCurrent = lift . getCurrentProjectBranch getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current getCurrentProjectBranch codebase = do - ppCtx <- - Codebase.runTransaction codebase Codebase.loadCurrentProjectPathCtx <&> \case + pp <- + Codebase.runTransaction codebase Codebase.loadCurrentProjectPath <&> \case Nothing -> -- TODO: Come up with a better solution for this error "No current project path context" - Just ppCtx -> ppCtx - let (PP.ProjectPath projName branchName path) = ppCtx ^. PP.ctxAsNames_ + Just pp -> pp + let (PP.ProjectPath projName branchName path) = pp ^. PP.asNames_ pure $ Current (Just projName) (Just branchName) path From 2c98ad1b1ed79a4c9c7bea3ee5d1fc698b43677f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 23 May 2024 15:31:38 -0700 Subject: [PATCH 10/76] Checkpoint --- parser-typechecker/src/Unison/Codebase.hs | 25 +++--- .../src/Unison/Codebase/ProjectPath.hs | 32 +++----- unison-cli/src/Unison/Cli/MonadUtils.hs | 18 ++--- unison-cli/src/Unison/Cli/ProjectUtils.hs | 53 +++++-------- .../Codebase/Editor/HandleInput/Branch.hs | 21 +++-- .../Unison/Codebase/Editor/HandleInput/UI.hs | 36 +++------ .../src/Unison/CommandLine/Completion.hs | 4 +- .../src/Unison/CommandLine/FZFResolvers.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 78 +++++++++---------- unison-cli/src/Unison/CommandLine/Main.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 7 +- .../src/Unison/Server/CodebaseServer.hs | 8 +- 12 files changed, 114 insertions(+), 172 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b02dd27494..629988421f 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -50,7 +50,7 @@ module Unison.Codebase getShallowCausalAtPath, getBranchAtPath, Operations.expectCausalBranchByCausalHash, - getShallowCausalFromRoot, + getShallowCausalAtPathFromRootHash, getShallowRootBranch, getShallowRootCausal, getShallowProjectRootBranch, @@ -184,15 +184,13 @@ runTransactionWithRollback :: runTransactionWithRollback Codebase {withConnection} action = withConnection \conn -> Sqlite.runTransactionWithRollback conn action -getShallowCausalFromRoot :: - -- Optional root branch, if Nothing use the codebase's root branch. - Maybe CausalHash -> +getShallowCausalAtPathFromRootHash :: + -- Causal to start at, if Nothing use the codebase's root branch. + CausalHash -> Path.Path -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalFromRoot mayRootHash p = do - rootCausal <- case mayRootHash of - Nothing -> getShallowRootCausal - Just ch -> Operations.expectCausalBranchByCausalHash ch +getShallowCausalAtPathFromRootHash rootCausalHash p = do + rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash getShallowCausalAtPath p (Just rootCausal) -- | Get the shallow representation of the root branches without loading the children or @@ -240,19 +238,18 @@ getShallowBranchAtPath path branch = do childBranch <- V2Causal.value childCausal getShallowBranchAtPath p childBranch -getShallowProjectRootBranch :: Db.ProjectId -> Db.ProjectBranchId -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowProjectRootBranch projectId projectBranchId = do - ProjectBranch {causalHashId} <- Q.expectProjectBranch projectId projectBranchId +getShallowProjectRootBranch :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +getShallowProjectRootBranch ProjectBranch {causalHashId} = do causalHash <- Q.expectCausalHash causalHashId Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowBranchAtProjectPath :: - PP.ProjectPathIds -> + PP.ProjectPath -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = do - projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId +getShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do + projectRootBranch <- getShallowProjectRootBranch projectBranch getShallowBranchAtPath (Path.unabsolute path) projectRootBranch getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index a11b7ccd23..dc6497fd14 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -11,8 +11,6 @@ module Unison.Codebase.ProjectPath asIds_, asNames_, asProjectAndBranch_, - project_, - branch_, ) where @@ -27,11 +25,11 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) data ProjectPathG proj branch = ProjectPath - { projPathProject :: proj, - projPathBranch :: branch, - projPathPath :: Path.Absolute + { project :: proj, + branch :: branch, + absPath :: Path.Absolute } - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Generic) type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId @@ -42,18 +40,6 @@ type ProjectPath = ProjectPathG Project ProjectBranch fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path -project_ :: Lens' (ProjectPathG p b) p -project_ = lens get set - where - get (ProjectPath p _ _) = p - set (ProjectPath _ b path) p = ProjectPath p b path - -branch_ :: Lens' (ProjectPathG p b) b -branch_ = lens get set - where - get (ProjectPath _ b _) = b - set (ProjectPath p _ path) b = ProjectPath p b path - -- | Project a project context into a project path of just IDs asIds_ :: Lens' ProjectPath ProjectPathIds asIds_ = lens get set @@ -61,8 +47,8 @@ asIds_ = lens get set get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path set p (ProjectPath pId bId path) = p - & project_ . #projectId .~ pId - & branch_ . #branchId .~ bId + & #project . #projectId .~ pId + & #branch . #branchId .~ bId & absPath_ .~ path -- | Project a project context into a project path of just names @@ -72,15 +58,15 @@ asNames_ = lens get set get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path set p (ProjectPath pName bName path) = p - & project_ . #name .~ pName - & branch_ . #name .~ bName + & #project . #name .~ pName + & #branch . #name .~ bName & absPath_ .~ path asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch) asProjectAndBranch_ = lens get set where get (ProjectPath proj branch _) = ProjectAndBranch proj branch - set p (ProjectAndBranch proj branch) = p & project_ .~ proj & branch_ .~ branch + set p (ProjectAndBranch proj branch) = p & #project .~ proj & #branch .~ branch instance Bifunctor ProjectPathG where bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 6eb5a755f6..29661ee6ac 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -8,7 +8,7 @@ module Unison.Cli.MonadUtils getCurrentPath, getCurrentProjectName, getCurrentProjectBranchName, - getProjectPath, + getCurrentProjectPath, resolvePath, resolvePath', resolveSplit', @@ -95,8 +95,6 @@ import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) -import U.Codebase.Sqlite.Project (Project (..)) -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -146,28 +144,28 @@ getConfig key = do ------------------------------------------------------------------------------------------------------------------------ -- Getting paths, path resolution, etc. -getProjectPath :: Cli PP.ProjectPath -getProjectPath = do +getCurrentProjectPath :: Cli PP.ProjectPath +getCurrentProjectPath = do (PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds -- TODO: Reset to a valid project on error. - (Project {name = projName}, ProjectBranch {name = branchName}) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do + (proj, branch) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do project <- MaybeT $ Q.loadProject projId branch <- MaybeT $ Q.loadProjectBranch projId branchId pure (project, branch) - pure (PP.ProjectPath (projId, projName) (branchId, branchName) path) + pure (PP.ProjectPath proj branch path) -- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - view PP.absPath_ <$> getProjectPath + view PP.absPath_ <$> getCurrentProjectPath getCurrentProjectName :: Cli ProjectName getCurrentProjectName = do - view (PP.ctxAsNames_ . PP.project_) <$> getProjectPath + view (PP.asNames_ . #project) <$> getCurrentProjectPath getCurrentProjectBranchName :: Cli ProjectBranchName getCurrentProjectBranchName = do - view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPath + view (PP.asNames_ . #branch) <$> getCurrentProjectPath -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. resolvePath :: Path -> Cli Path.Absolute diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 6ed7ff03e7..8d9b66c15a 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -13,8 +13,6 @@ module Unison.Cli.ProjectUtils expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, - getCurrentProject, - getCurrentProjectBranch, -- * Loading remote project info expectRemoteProjectById, @@ -40,7 +38,6 @@ import Data.These (These (..)) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project (Project) import U.Codebase.Sqlite.Project qualified as Sqlite -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -66,13 +63,13 @@ resolveBranchRelativePath brp = do case brp of BranchPathInCurrentProject projBranchName path -> do projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName) - pure $ PP.ctxFromProjectAndBranch projectAndBranch path + pure $ PP.fromProjectAndBranch projectAndBranch path QualifiedBranchPath projName projBranchName path -> do projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) - pure $ PP.ctxFromProjectAndBranch projectAndBranch path + pure $ PP.fromProjectAndBranch projectAndBranch path UnqualifiedPath newPath' -> do - ppCtx <- Cli.getProjectPath - pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' + pp <- Cli.getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name -- like @preferred@. @@ -95,20 +92,6 @@ findTemporaryBranchName projectId preferred = do pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates)) --- | Get the current project+branch+branch path that a user is on. -getCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch) -getCurrentProjectBranch = do - ppCtx <- Cli.getProjectPath - Cli.runTransaction $ do - proj <- Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_) - branch <- Queries.expectProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_) - pure $ PP.ProjectPath proj branch (ppCtx ^. PP.absPath_) - -getCurrentProject :: Cli Sqlite.Project -getCurrentProject = do - ppCtx <- Cli.getProjectPath - Cli.runTransaction (Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_)) - expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch expectProjectBranchByName project branchName = Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do @@ -124,8 +107,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do - ppCtx <- Cli.getProjectPath - pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName) + pp <- Cli.getCurrentProjectPath + pure (ProjectAndBranch (pp ^. PP.asNames_ . #project) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) -- Expect a local project+branch by ids. @@ -147,9 +130,9 @@ getProjectAndBranchByTheseNames :: getProjectAndBranchByTheseNames = \case This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> runMaybeT do - currentProjectBranch <- lift getCurrentProjectBranch - branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName)) - pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch) + (PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath + branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName)) + pure (ProjectAndBranch proj branch) These projectName branchName -> do Cli.runTransaction do runMaybeT do @@ -167,7 +150,7 @@ expectProjectAndBranchByTheseNames :: expectProjectAndBranchByTheseNames = \case This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> do - PP.ProjectPath project _branch _restPath <- getCurrentProjectBranch + PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) @@ -188,21 +171,21 @@ expectProjectAndBranchByTheseNames = \case -- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current -- project, defaulting to 'main' if branch is unspecified. -- 3. If we just have a path, resolve it using the current project. -resolveProjectPath :: PP.ProjectPath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath -resolveProjectPath ppCtx mayProjAndBranch mayPath' = do - projAndBranch <- resolveProjectBranch ppCtx mayProjAndBranch +resolveProjectPath :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath +resolveProjectPath defaultProj mayProjAndBranch mayPath' = do + projAndBranch <- resolveProjectBranch defaultProj mayProjAndBranch absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath' - pure $ PP.ctxFromProjectAndBranch projAndBranch absPath + pure $ PP.fromProjectAndBranch projAndBranch absPath -- | Expect/resolve branch reference with the following rules: -- -- 1. If the project is missing, use the provided project. -- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided -- project, defaulting to 'main' if branch is unspecified. -resolveProjectBranch :: ProjectAndBranch Project ProjectBranch -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -resolveProjectBranch ppCtx (ProjectAndBranch mayProjectName mayBranchName) = do +resolveProjectBranch :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName - let projectName = fromMaybe (ppCtx ^. PP.ctxAsNames_ . PP.project_) mayProjectName + let projectName = fromMaybe (defaultProj ^. #name) mayProjectName projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName) pure projectAndBranch @@ -289,7 +272,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case let remoteBranchName = unsafeFrom @Text "main" expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) That branchName -> do - PP.ProjectPath localProject localBranch _restPath <- getCurrentProjectBranch + PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath let localProjectId = localProject ^. #projectId let localBranchId = localBranch ^. #branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 8df791dec7..1393ce8ff7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -18,10 +18,8 @@ import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch (headHash) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) @@ -41,7 +39,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () - currentProjectName <- Cli.getProjectPath <&> view (PP.ctxAsNames_ . PP.project_) + currentProjectName <- Cli.getCurrentProjectPath <&> view (PP.asNames_ . #project) destProject <- do Cli.runTransactionWithRollback \rollback -> do @@ -51,22 +49,21 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName)) -- Compute what we should create the branch from. - maySrcBranch <- + maySrcProjectAndBranch <- case sourceI of - Input.BranchSourceI'CurrentContext -> Just <$> ProjectUtils.getCurrentProjectBranch + Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath Input.BranchSourceI'Empty -> pure Nothing Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do - ppCtx <- Cli.getProjectPath - ProjectAndBranch _proj branch <- ProjectUtils.resolveProjectBranch ppCtx (unresolvedProjectBranch & #branch %~ Just) - pure $ Just branch + pp <- Cli.getCurrentProjectPath + Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- doCreateBranch maySrcBranch project newBranchName + _ <- doCreateBranch (view #branch <$> maySrcProjectAndBranch) destProject newBranchName Cli.respond $ Output.CreatedProjectBranch - ( case maySrcBranch of + ( case maySrcProjectAndBranch of Just sourceBranch -> - if sourceBranch ^. #project . #projectId == project ^. #projectId + if sourceBranch ^. #project . #projectId == destProject ^. #projectId then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name) else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch Nothing -> Output.CreatedProjectBranchFrom'Nothingness @@ -86,7 +83,7 @@ doCreateBranch :: -- If no parent branch is provided, make an empty branch. Maybe Sqlite.ProjectBranch -> Sqlite.Project -> - Sqlite.Transaction ProjectBranchName -> + ProjectBranchName -> Cli ProjectBranchId doCreateBranch mayParentBranch project getNewBranchName = do let projectId = project ^. #projectId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs index 85ce5922f5..9a6c5dcb3f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs @@ -21,6 +21,7 @@ import Unison.Cli.ProjectUtils qualified as Project import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.ConstructorType qualified as ConstructorType import Unison.HashQualified qualified as HQ @@ -28,8 +29,7 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Parser.Ann (Ann (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch) -import Unison.Project.Util (projectBranchPath) +import Unison.Project (ProjectAndBranch (ProjectAndBranch)) import Unison.Referent qualified as Referent import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite @@ -39,37 +39,25 @@ import Web.Browser (openBrowser) openUI :: Path.Path' -> Cli () openUI path' = do Cli.Env {serverBaseUrl} <- ask - currentPath <- Cli.getCurrentPath - let absPath = Path.resolve currentPath path' + defnPath <- Cli.resolvePath' path' + pp <- Cli.getCurrentProjectPath whenJust serverBaseUrl \url -> do - Project.getProjectBranchForPath absPath >>= \case - Nothing -> openUIForLooseCode url path' - Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch + openUIForProject url pp defnPath -openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli () -openUIForProject url projectAndBranch pathFromProjectRoot = do - currentPath <- Cli.getCurrentPath - perspective <- - Project.getProjectBranchForPath currentPath <&> \case - Nothing -> - -- The current path is outside the project the argument was in. Use the project root - -- as the perspective. - Path.empty - Just (_projectBranch, pathWithinBranch) -> pathWithinBranch +openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli () +openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath = do mayDefinitionRef <- getDefinitionRef perspective - let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch + let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch) _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url pure () where - pathToBranchFromCodebaseRoot :: Path.Absolute - pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch) -- If the provided ui path matches a definition, find it. - getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference)) + getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference)) getDefinitionRef perspective = runMaybeT $ do Cli.Env {codebase} <- lift ask - let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot) - (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition - namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing) + (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath + let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace + namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath fqn <- hoistMaybe $ do pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot) Path.toName . Path.fromList $ pathFromPerspective diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index bd0cf9c0e0..7249aea28c 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -101,7 +101,7 @@ noCompletions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [System.Console.Haskeline.Completion.Completion] noCompletions _ _ _ _ = pure [] @@ -145,7 +145,7 @@ completeWithinNamespace :: Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength - b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.ctxAsIds_) + b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.asIds_) currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index 2d3b8a8216..704fdc2b33 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . PP.project_) Nothing) + Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . #project) Nothing) <&> fmap (into @Text . snd) -- | Exported from here just so the debug command and actual implementation can use the same diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 45208c2547..93f8f58e18 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -147,7 +147,7 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens ((^.)) +import Control.Lens ((.~), (^.)) import Control.Lens.Cons qualified as Cons import Data.List (intercalate) import Data.List.Extra qualified as List @@ -1840,7 +1840,7 @@ mergeOldSquashInputPattern = [src, dest] -> do src <- parseUnresolvedProjectBranch src dest <- parseUnresolvedProjectBranch dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge + Just $ Input.MergeLocalBranchI src (Just dest) Branch.SquashMerge _ -> Nothing } where @@ -3349,7 +3349,7 @@ namespaceOrProjectBranchArg config = ArgumentType { typeName = "namespace or branch", suggestions = - let namespaceSuggestions = \q cb _http ppCtx -> Codebase.runTransaction cb (prefixCompleteNamespace q ppCtx) + let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp) in unionSuggestions [ projectAndOrBranchSuggestions config, namespaceSuggestions @@ -3375,8 +3375,8 @@ dependencyArg :: ArgumentType dependencyArg = ArgumentType { typeName = "project dependency", - suggestions = \q cb _http p -> Codebase.runTransaction cb do - prefixCompleteNamespace q (p Path.:> NameSegment.libSegment), + suggestions = \q cb _http pp -> Codebase.runTransaction cb do + prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment), fzfResolver = Just Resolvers.projectDependencyResolver } @@ -3464,12 +3464,12 @@ projectAndOrBranchSuggestions :: AuthenticatedHttpClient -> ProjectPath -> m [Line.Completion] -projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do +projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do case Text.uncons input of -- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to -- handle "/" and "/@" inputs, which aren't valid branch names, but are valid branch prefixes. So, -- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix. - Just ('/', input1) -> handleBranchesComplete input1 codebase path + Just ('/', input1) -> handleBranchesComplete input1 codebase pp _ -> case tryInto @ProjectAndBranchNames input of -- This case handles inputs like "", "@", and possibly other things that don't look like a valid project @@ -3490,12 +3490,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId Nothing pure (map (projectBranchToCompletion projectName) branches) -- This branch is probably dead due to intercepting inputs that begin with "/" above Right (ProjectAndBranchNames'Unambiguous (That branchName)) -> - handleBranchesComplete (into @Text branchName) codebase path + handleBranchesComplete (into @Text branchName) codebase pp Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do branches <- Codebase.runTransaction codebase do @@ -3503,12 +3503,11 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName) pure (map (projectBranchToCompletion projectName) branches) where input = Text.strip . Text.pack $ inputStr - currentProjectId = ppCtx ^. (PP.ctxAsIds_ . PP.project_) handleAmbiguousComplete :: MonadIO m => @@ -3519,14 +3518,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do (branches, projects) <- Codebase.runTransaction codebase do branches <- - case mayCurrentProjectId of - Nothing -> pure [] - Just currentProjectId -> - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) - projects <- case (projectInclusion config, mayCurrentProjectId) of - (OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList - (OnlyWithinCurrentProject, Nothing) -> pure [] + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) + projects <- case projectInclusion config of + OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList _ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects pure (branches, projects) let branchCompletions = map currentProjectBranchToCompletion branches @@ -3602,25 +3597,26 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do -- Complete the text into a branch name within the provided project handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion] - handleBranchesComplete branchName codebase ppCtx = do - let projId = ppCtx ^. PP.ctxAsIds_ . PP.project_ + handleBranchesComplete branchName codebase pp = do + let projId = pp ^. PP.asIds_ . #project branches <- Codebase.runTransaction codebase do - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projId (Just branchName) pure (map currentProjectBranchToCompletion branches) filterProjects :: [Sqlite.Project] -> [Sqlite.Project] filterProjects projects = - case (mayCurrentProjectId, projectInclusion config) of - (_, AllProjects) -> projects - (Nothing, _) -> projects - (Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId) - (Just currentBranchId, OnlyWithinCurrentProject) -> + case (projectInclusion config) of + AllProjects -> projects + OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId) + OnlyWithinCurrentProject -> projects - & List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId) + & List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId) & maybeToList + PP.ProjectPath currentProjectId _currentBranchId _currentPath = pp ^. PP.asIds_ + projectToCompletion :: Sqlite.Project -> Completion projectToCompletion project = Completion @@ -3646,20 +3642,20 @@ handleBranchesComplete :: Codebase m v a -> PP.ProjectPath -> m [Completion] -handleBranchesComplete config branchName codebase ppCtx = do +handleBranchesComplete config branchName codebase pp = do branches <- Codebase.runTransaction codebase do - fmap (filterBranches config ppCtx) do - Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName) + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith (pp ^. PP.asIds_ . #project) (Just branchName) pure (map currentProjectBranchToCompletion branches) filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] -filterBranches config ppCtx branches = +filterBranches config pp branches = case (branchInclusion config) of AllBranches -> branches ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) where - currentBranchId = ppCtx ^. PP.ctxAsIds_ . PP.branch_ + currentBranchId = pp ^. PP.asIds_ . #branch currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = @@ -3677,20 +3673,20 @@ branchRelativePathSuggestions :: AuthenticatedHttpClient -> PP.ProjectPath -> m [Line.Completion] -branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do +branchRelativePathSuggestions config inputStr codebase _httpClient pp = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of BranchRelativePath.ProjectOrPath' _txt _path -> do - namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase pure (namespaceSuggestions ++ projectSuggestions) BranchRelativePath.OnlyPath' _path -> - Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) BranchRelativePath.IncompleteProject _proj -> projectNameSuggestions WithSlash inputStr codebase BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of - Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase ppCtx + Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp Just projectName -> do branches <- Codebase.runTransaction codebase do @@ -3698,18 +3694,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config ppCtx) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch) pure (map (projectBranchToCompletionWithSep projectName) branches) BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do -- TODO: Verify this works as intendid - map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) mempty + map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) pp BranchRelativePath.IncompletePath projStuff mpath -> do Codebase.runTransaction codebase do - map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) ppCtx + map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) pp where - currentPath = ppCtx ^. PP.absPath_ - projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = Completion diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 0d43f1cd92..78873f0d65 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -83,7 +83,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Just a -> pure a go :: Line.InputT IO Input go = do - let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.ctxAsNames_ + let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.asNames_ let promptString = P.sep ":" diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index b3d0e49907..08777b6c98 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -45,7 +45,6 @@ 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 import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) import Unison.Codebase.Editor.Input qualified as Input @@ -455,7 +454,7 @@ notifyNumbered = \case ) where switch = IP.makeExample IP.projectSwitch - AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) -> + AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) -> ( P.wrap ( openingLine <> prettyProjectAndBranchName (ProjectAndBranch currentProject branch) @@ -495,7 +494,7 @@ notifyNumbered = \case E.AmbiguousReset'Target -> \xs -> "" : xs reset = IP.makeExample IP.reset relPath0 = prettyPath path - absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path) + absPath0 = Path.Absolute path ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty) ListNamespaceDependencies ppe path' externalDependencies -> ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $ @@ -910,7 +909,7 @@ notifyUser dir = \case prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push." CreatedNewBranch path -> pure $ - "☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty." + "☝️ The namespace " <> prettyAbsolute path <> " is empty." -- RenameOutput rootPath oldName newName r -> do -- nameChange "rename" "renamed" oldName newName r -- AliasOutput rootPath existingName newName r -> do diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 6ad9c77e6b..f634360db1 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -239,7 +239,7 @@ data DefinitionReference data Service = LooseCodeUI Path.Absolute (Maybe DefinitionReference) | -- (Project branch names, perspective within project, definition reference) - ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference) + ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference) | Api deriving stock (Show) @@ -299,13 +299,13 @@ urlFor :: Service -> BaseUrl -> Text urlFor service baseUrl = case service of LooseCodeUI perspective def -> - tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path (Path.unabsolute perspective) def) + tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path perspective def) ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def -> tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def) Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"] where - path :: Path.Path -> Maybe DefinitionReference -> [URISegment] - path ns def = + path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment] + path (Path.Absolute ns) def = let nsPath = namespacePath ns in case definitionPath def of Just defPath -> case nsPath of From 467dee15f8d34e615c1065013c0327dadd779533 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 24 May 2024 10:14:22 -0700 Subject: [PATCH 11/76] Checkpoint --- Input.hs | 335 ++++++++++++++++++ .../src/Unison/Codebase/Path.hs | 6 + .../src/Unison/Codebase/ProjectPath.hs | 32 +- unison-cli/src/Unison/Cli/MonadUtils.hs | 143 ++++---- unison-cli/src/Unison/Cli/Pretty.hs | 5 + unison-cli/src/Unison/Cli/ProjectUtils.hs | 16 +- .../Codebase/Editor/HandleInput/Branch.hs | 2 +- .../Editor/HandleInput/BranchRename.hs | 5 +- .../Codebase/Editor/HandleInput/Branches.hs | 9 +- .../Editor/HandleInput/DeleteBranch.hs | 86 +++-- .../Editor/HandleInput/DeleteProject.hs | 25 +- .../Codebase/Editor/HandleInput/InstallLib.hs | 17 +- .../Codebase/Editor/HandleInput/MoveTerm.hs | 9 +- .../Codebase/Editor/HandleInput/MoveType.hs | 7 +- .../Editor/HandleInput/ProjectCreate.hs | 20 +- .../Codebase/Editor/HandleInput/Update.hs | 10 +- .../Codebase/Editor/HandleInput/Update2.hs | 2 +- .../src/Unison/Codebase/Editor/Input.hs | 2 + .../src/Unison/CommandLine/Completion.hs | 2 +- .../src/Unison/CommandLine/FZFResolvers.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 8 +- unison-cli/src/Unison/CommandLine/Main.hs | 2 +- .../Unison/Server/Local/Endpoints/Current.hs | 2 +- 23 files changed, 529 insertions(+), 218 deletions(-) create mode 100644 Input.hs diff --git a/Input.hs b/Input.hs new file mode 100644 index 0000000000..427d901fb4 --- /dev/null +++ b/Input.hs @@ -0,0 +1,335 @@ +module Unison.Codebase.Editor.Input + ( Input (..), + BranchSourceI (..), + DiffNamespaceToPatchInput (..), + GistInput (..), + PullSourceTarget (..), + PushRemoteBranchInput (..), + PushSourceTarget (..), + PushSource (..), + TestInput (..), + Event (..), + OutputLocation (..), + PatchPath, + BranchId, + AbsBranchId, + UnresolvedProjectBranch, + parseBranchId, + parseBranchId2, + parseShortCausalHash, + HashOrHQSplit', + Insistence (..), + PullMode (..), + OptionalPatch (..), + FindScope (..), + ShowDefinitionScope (..), + IsGlobal, + DeleteOutput (..), + DeleteTarget (..), + ) +where + +import Data.List.NonEmpty (NonEmpty) +import Data.Text qualified as Text +import Data.These (These) +import Unison.Codebase.Branch.Merge qualified as Branch +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.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.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) +import Unison.NameSegment (NameSegment) +import Unison.Prelude +import Unison.Project (ProjectAndBranch, ProjectAndBranchNames, ProjectBranchName, ProjectBranchNameOrLatestRelease, ProjectName, Semver) +import Unison.ShortHash (ShortHash) +import Unison.Util.Pretty qualified as P + +data Event + = UnisonFileChanged SourceName Source + deriving stock (Show) + +type Source = Text -- "id x = x\nconst a b = a" + +type SourceName = Text -- "foo.u" or "buffer 7" + +type PatchPath = Path.Split' + +data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath + deriving (Eq, Ord, Show) + +type BranchId = Either ShortCausalHash Path' + +-- | An unambiguous project branch name, use the current project name if not provided. +type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName + +type AbsBranchId = Either ShortCausalHash Path.Absolute + +type HashOrHQSplit' = Either ShortHash Path.HQSplit' + +-- | Should we force the operation or not? +data Insistence = Force | Try + deriving (Show, Eq) + +parseBranchId :: String -> Either Text BranchId +parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of + Nothing -> Left "Invalid hash, expected a base32hex string." + Just h -> pure $ Left h +parseBranchId s = Right <$> Path.parsePath' s + +parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of + Nothing -> Left "Invalid hash, expected a base32hex string." + Just h -> Right (Left h) +parseBranchId2 s = Right <$> parseBranchRelativePath s + +parseShortCausalHash :: String -> Either String ShortCausalHash +parseShortCausalHash ('#' : s) | Just sch <- SCH.fromText (Text.pack s) = Right sch +parseShortCausalHash _ = Left "Invalid hash, expected a base32hex string." + +data PullMode + = PullWithHistory + | PullWithoutHistory + deriving (Eq, Show) + +type IsGlobal = Bool + +data Input + = -- names stuff: + -- directory ops + -- `Link` must describe a repo and a source path within that repo. + -- clone w/o merge, error if would clobber + ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath + | -- merge first causal into destination + MergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) Branch.MergeMode + | PreviewMergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) + | DiffNamespaceI BranchId BranchId -- old new + | PullI !PullSourceTarget !PullMode + | PushRemoteBranchI PushRemoteBranchInput + | ResetRootI (Either ShortCausalHash Path') + | ResetI + ( These + (Either ShortCausalHash Path') + (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + ) + (Maybe UnresolvedProjectBranch) + | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? + -- Does it make sense to fork from not-the-root of a Github repo? + -- used in Welcome module to give directions to user + CreateMessage (P.Pretty P.ColorText) + | -- Change directory. + SwitchBranchI Path' + | UpI + | PopBranchI + | -- > names foo + -- > names foo.bar + -- > names .foo.bar + -- > names .foo.bar#asdflkjsdf + -- > names #sdflkjsdfhsdf + NamesI IsGlobal (HQ.HashQualified Name) + | AliasTermI HashOrHQSplit' Path.Split' + | AliasTypeI HashOrHQSplit' Path.Split' + | AliasManyI [Path.HQSplit] Path' + | MoveAllI Path.Path' Path.Path' + | -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. + 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: + LoadI (Maybe FilePath) + | ClearI + | AddI (Set Name) + | PreviewAddI (Set Name) + | UpdateI OptionalPatch (Set Name) + | 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] + | -- save the result of a previous Execute + SaveExecuteResultI Name + | -- execute an IO [Result] + IOTestI (HQ.HashQualified Name) + | -- execute all in-scope IO tests + IOTestAllI + | -- make a standalone binary file + MakeStandaloneI String (HQ.HashQualified Name) + | -- execute an IO thunk using scheme + ExecuteSchemeI Text [String] + | -- compile to a scheme file + CompileSchemeI Text (HQ.HashQualified Name) + | TestI TestInput + | CreateAuthorI NameSegment {- identifier -} Text {- name -} + | -- Display provided definitions. + DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) + | -- Display docs for provided terms. + DocsI (NonEmpty Path.HQSplit') + | -- 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)) + | ShowReflogI + | UpdateBuiltinsI + | MergeBuiltinsI (Maybe Path) + | MergeIOBuiltinsI (Maybe Path) + | ListDependenciesI (HQ.HashQualified Name) + | ListDependentsI (HQ.HashQualified Name) + | -- | List all external dependencies of a given namespace, or the current namespace if + -- no path is provided. + NamespaceDependenciesI (Maybe Path') + | DebugTabCompletionI [String] -- The raw arguments provided + | DebugFuzzyOptionsI String [String] -- cmd and arguments + | DebugFormatI + | DebugNumberedArgsI + | DebugTypecheckedUnisonFileI + | DebugDumpNamespacesI + | DebugDumpNamespaceSimpleI + | DebugTermI (Bool {- Verbose mode -}) (HQ.HashQualified Name) + | DebugTypeI (HQ.HashQualified Name) + | DebugLSPFoldRangesI + | DebugClearWatchI + | DebugDoctorI + | DebugNameDiffI ShortCausalHash ShortCausalHash + | QuitI + | ApiI + | UiI Path' + | DocToMarkdownI Name + | DocsToHtmlI Path' FilePath + | GistI GistInput + | AuthLoginI + | VersionI + | DiffNamespaceToPatchI DiffNamespaceToPatchInput + | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) + | ProjectRenameI ProjectName + | ProjectSwitchI ProjectAndBranchNames + | ProjectsI + | BranchI BranchSourceI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + | BranchRenameI ProjectBranchName + | BranchesI (Maybe ProjectName) + | CloneI ProjectAndBranchNames (Maybe ProjectAndBranchNames) + | ReleaseDraftI Semver + | UpgradeI !NameSegment !NameSegment + | EditNamespaceI [Path.Path] + | -- New merge algorithm: merge the given project branch into the current one. + MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + | LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) + deriving (Eq, Show) + +-- | The source of a `branch` command: what to make the new branch from. +data BranchSourceI + = -- | Create a branch from the current context + BranchSourceI'CurrentContext + | -- | Create an empty branch + BranchSourceI'Empty + | -- | Create a branch from this other branch + BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch + 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)) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + deriving stock (Eq, Show) + +data PushSource + = PathySource Path' + | ProjySource (These ProjectName ProjectBranchName) + deriving stock (Eq, Show) + +-- | Push source and target: either neither is specified, or only a target, or both. +data PushSourceTarget + = PushSourceTarget0 + | PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + | PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + deriving stock (Eq, Show) + +data PushRemoteBranchInput = PushRemoteBranchInput + { sourceTarget :: PushSourceTarget, + pushBehavior :: PushBehavior + } + deriving stock (Eq, Show) + +data TestInput = TestInput + { -- | Should we run tests in the `lib` namespace? + includeLibNamespace :: Bool, + -- | Relative path to run the tests in. Ignore if `includeLibNamespace` is True - that means test everything. + path :: Path, + showFailures :: Bool, + showSuccesses :: Bool + } + deriving stock (Eq, Show) + +-- Some commands, like `view`, can dump output to either console or a file. +data OutputLocation + = ConsoleLocation + | LatestFileLocation + | FileLocation FilePath + -- ClipboardLocation + deriving (Eq, Show) + +data FindScope + = FindLocal Path + | FindLocalAndDeps Path + | FindGlobal + deriving stock (Eq, Show) + +data ShowDefinitionScope + = ShowDefinitionLocal + | ShowDefinitionGlobal + deriving stock (Eq, Show) + +data DeleteOutput + = DeleteOutput'Diff + | DeleteOutput'NoDiff + deriving stock (Eq, Show) + +data DeleteTarget + = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit'] + | DeleteTarget'Term DeleteOutput [Path.HQSplit'] + | DeleteTarget'Type DeleteOutput [Path.HQSplit'] + | DeleteTarget'Namespace Insistence Path.Split + | DeleteTarget'Patch Path.Split' + | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + | DeleteTarget'Project ProjectName + deriving stock (Eq, Show) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 3b7a7b483d..742833ad3f 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -29,6 +29,7 @@ module Unison.Codebase.Path prefixName2, unprefixName, HQSplit, + AbsSplit, Split, Split', HQSplit', @@ -179,6 +180,8 @@ unsplitHQ (p, a) = fmap (snoc p) a unsplitHQ' :: HQSplit' -> HQ'.HashQualified Path' unsplitHQ' (p, a) = fmap (snoc' p) a +type AbsSplit = (Absolute, NameSegment) + type Split = (Path, NameSegment) type HQSplit = (Path, HQ'.HQSegment) @@ -515,6 +518,9 @@ instance Resolve Absolute Relative Absolute where instance Resolve Absolute Relative Path' where resolve l r = AbsolutePath' (resolve l r) +instance Resolve Absolute Path Absolute where + resolve (Absolute l) r = Absolute (resolve l r) + instance Resolve Path' Path' Path' where resolve _ a@(AbsolutePath' {}) = a resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index dc6497fd14..b2b831f9fb 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -8,8 +8,8 @@ module Unison.Codebase.ProjectPath path_, projectAndBranch_, toText, - asIds_, - asNames_, + toIds, + toNames, asProjectAndBranch_, ) where @@ -41,26 +41,12 @@ fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path -- | Project a project context into a project path of just IDs -asIds_ :: Lens' ProjectPath ProjectPathIds -asIds_ = lens get set - where - get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path - set p (ProjectPath pId bId path) = - p - & #project . #projectId .~ pId - & #branch . #branchId .~ bId - & absPath_ .~ path +toIds :: ProjectPath -> ProjectPathIds +toIds (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path -- | Project a project context into a project path of just names -asNames_ :: Lens' ProjectPath ProjectPathNames -asNames_ = lens get set - where - get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path - set p (ProjectPath pName bName path) = - p - & #project . #name .~ pName - & #branch . #name .~ bName - & absPath_ .~ path +toNames :: ProjectPath -> ProjectPathNames +toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch) asProjectAndBranch_ = lens get set @@ -77,9 +63,9 @@ instance Bifoldable ProjectPathG where instance Bitraversable ProjectPathG where bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path -toText :: ProjectPathG ProjectName ProjectBranchName -> Text -toText (ProjectPath projName branchName path) = - into @Text projName <> "/" <> into @Text branchName <> ":" <> Path.absToText path +toText :: ProjectPathG Project ProjectBranch -> Text +toText (ProjectPath proj branch path) = + into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path absPath_ :: Lens' (ProjectPathG p b) Path.Absolute absPath_ = lens go set diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 29661ee6ac..c9d3e355ce 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -29,10 +29,10 @@ module Unison.Cli.MonadUtils getProjectRoot0, getCurrentBranch, getCurrentBranch0, - getBranchFromProjectRootPath, - getBranch0FromProjectRootPath, - getMaybeBranchFromProjectRootPath, - getMaybeBranch0FromProjectRootPath, + getBranchFromProjectPath, + getBranch0FromProjectPath, + getMaybeBranchFromProjectPath, + getMaybeBranch0FromProjectPath, expectBranchAtPath, expectBranchAtPath', expectBranch0AtPath, @@ -95,6 +95,8 @@ import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.Sqlite.Project (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -118,7 +120,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude -import Unison.Project (ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Reference (TypeReference) import Unison.Referent (Referent) import Unison.Sqlite qualified as Sqlite @@ -161,26 +163,26 @@ getCurrentPath = do getCurrentProjectName :: Cli ProjectName getCurrentProjectName = do - view (PP.asNames_ . #project) <$> getCurrentProjectPath + view (#project . #name) <$> getCurrentProjectPath getCurrentProjectBranchName :: Cli ProjectBranchName getCurrentProjectBranchName = do - view (PP.asNames_ . #branch) <$> getCurrentProjectPath + view (#branch . #name) <$> getCurrentProjectPath -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. -resolvePath :: Path -> Cli Path.Absolute +resolvePath :: Path -> Cli PP.ProjectPath resolvePath path = do - currentPath <- getCurrentPath - pure (Path.resolve currentPath (Path.Relative path)) + pp <- getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path -- | Resolve a @Path'@ to a @Path.Absolute@, per the current path. -resolvePath' :: Path' -> Cli Path.Absolute -resolvePath' path = do - currentPath <- getCurrentPath - pure (Path.resolve currentPath path) +resolvePath' :: Path' -> Cli PP.ProjectPath +resolvePath' path' = do + pp <- getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path' -- | Resolve a path split, per the current path. -resolveSplit' :: (Path', a) -> Cli (Path.Absolute, a) +resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a) resolveSplit' = traverseOf _1 resolvePath' @@ -192,22 +194,24 @@ resolveSplit' = resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO) resolveAbsBranchId = \case Left hash -> resolveShortCausalHash hash - Right path -> getBranchFromProjectRootPath path + Right absPath -> do + pp <- resolvePath' (Path' (Left absPath)) + getBranchFromProjectPath pp -- | V2 version of 'resolveAbsBranchId2'. resolveAbsBranchIdV2 :: (forall void. Output.Output -> Sqlite.Transaction void) -> + ProjectAndBranch Project ProjectBranch -> Input.AbsBranchId -> Sqlite.Transaction (V2.Branch Sqlite.Transaction) -resolveAbsBranchIdV2 rollback = \case +resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case Left shortHash -> do hash <- resolveShortCausalHashToCausalHash rollback shortHash - succeed (Codebase.expectCausalBranchByCausalHash hash) - Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)) - where - succeed getCausal = do - causal <- getCausal - V2Causal.value causal + causal <- (Codebase.expectCausalBranchByCausalHash hash) + V2Causal.value causal + Right absPath -> do + let pp = PP.ProjectPath proj branch absPath + Codebase.getShallowBranchAtProjectPath pp -- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent -- branches by path are OK - the empty branch will be returned). @@ -219,7 +223,7 @@ resolveBranchId branchId = do -- | Resolve a @BranchId@ to an @AbsBranchId@. resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId resolveBranchIdToAbsBranchId = - traverseOf _Right resolvePath' + traverseOf _Right (fmap (view PP.absPath_) . resolvePath') -- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found. resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) @@ -288,25 +292,28 @@ getCurrentBranch0 = do Branch.head <$> getCurrentBranch -- | Get the branch at an absolute path from the project root. -getBranchFromProjectRootPath :: Path.Absolute -> Cli (Branch IO) -getBranchFromProjectRootPath path = - getMaybeBranchFromProjectRootPath path <&> fromMaybe Branch.empty +getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO) +getBranchFromProjectPath pp = + getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty -- | Get the branch0 at an absolute path. -getBranch0FromProjectRootPath :: Path.Absolute -> Cli (Branch0 IO) -getBranch0FromProjectRootPath path = - Branch.head <$> getBranchFromProjectRootPath path +getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO) +getBranch0FromProjectPath pp = + Branch.head <$> getBranchFromProjectPath pp -- | Get the maybe-branch at an absolute path. -getMaybeBranchFromProjectRootPath :: Path.Absolute -> Cli (Maybe (Branch IO)) -getMaybeBranchFromProjectRootPath path = do - rootBranch <- getProjectRoot - pure (Branch.getAt (Path.unabsolute path) rootBranch) +getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) +getMaybeBranchFromProjectPath pp = do + Cli.Env {codebase} <- ask + let ProjectBranch {causalHashId} = pp ^. #branch + causalHash <- Cli.runTransaction $ Q.expectCausalHash causalHashId + rootBranch <- liftIO $ Codebase.expectBranchForHash codebase causalHash + pure (Branch.getAt (pp ^. PP.path_) rootBranch) -- | Get the maybe-branch0 at an absolute path. -getMaybeBranch0FromProjectRootPath :: Path.Absolute -> Cli (Maybe (Branch0 IO)) -getMaybeBranch0FromProjectRootPath path = - fmap Branch.head <$> getMaybeBranchFromProjectRootPath path +getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO)) +getMaybeBranch0FromProjectPath pp = + fmap Branch.head <$> getMaybeBranchFromProjectPath pp -- | Get the branch at a relative path, or return early if there's no such branch. expectBranchAtPath :: Path -> Cli (Branch IO) @@ -317,7 +324,7 @@ expectBranchAtPath = expectBranchAtPath' :: Path' -> Cli (Branch IO) expectBranchAtPath' path0 = do path <- resolvePath' path0 - getMaybeBranchFromProjectRootPath path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) + getMaybeBranchFromProjectPath path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0)) -- | Get the branch0 at an absolute or relative path, or return early if there's no such branch. expectBranch0AtPath' :: Path' -> Cli (Branch0 IO) @@ -343,48 +350,52 @@ assertNoBranchAtPath' path' = do -- current terms/types etc). branchExistsAtPath' :: Path' -> Cli Bool branchExistsAtPath' path' = do - absPath <- resolvePath' path' + pp <- resolvePath' path' Cli.runTransaction do - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute absPath) - branch <- V2Causal.value causal + branch <- Codebase.getShallowBranchAtProjectPath pp isEmpty <- V2Branch.isEmpty branch pure (not isEmpty) ------------------------------------------------------------------------------------------------------------------------ -- Updating branches +relativizeActions :: (Foldable f) => f (Path.Absolute, x) -> [(Path, x)] +relativizeActions actions = + toList actions + & traversed . _1 %~ Path.unabsolute + stepAt :: Text -> - (Path, Branch0 IO -> Branch0 IO) -> + (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () stepAt cause = stepManyAt @[] cause . pure stepAt' :: Text -> - (Path, Branch0 IO -> Cli (Branch0 IO)) -> + (Path.Absolute, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepAt' cause = stepManyAt' @[] cause . pure stepAtNoSync' :: - (Path, Branch0 IO -> Cli (Branch0 IO)) -> + (Path.Absolute, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepAtNoSync' = stepManyAtNoSync' @[] . pure stepAtNoSync :: - (Path, Branch0 IO -> Branch0 IO) -> + (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () stepAtNoSync = stepManyAtNoSync @[] . pure stepAtM :: Text -> - (Path, Branch0 IO -> IO (Branch0 IO)) -> + (Path.Absolute, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepAtM cause = stepManyAtM @[] cause . pure stepManyAt :: (Foldable f) => Text -> - f (Path, Branch0 IO -> Branch0 IO) -> + f (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () stepManyAt reason actions = do stepManyAtNoSync actions @@ -393,7 +404,7 @@ stepManyAt reason actions = do stepManyAt' :: (Foldable f) => Text -> - f (Path, Branch0 IO -> Cli (Branch0 IO)) -> + f (Path.Absolute, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepManyAt' reason actions = do res <- stepManyAtNoSync' actions @@ -402,26 +413,26 @@ stepManyAt' reason actions = do stepManyAtNoSync' :: (Foldable f) => - f (Path, Branch0 IO -> Cli (Branch0 IO)) -> + f (Path.Absolute, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepManyAtNoSync' actions = do origRoot <- getProjectRoot - newRoot <- Branch.stepManyAtM actions origRoot + newRoot <- Branch.stepManyAtM (relativizeActions actions) origRoot setCurrentProjectRoot newRoot pure (origRoot /= newRoot) -- Like stepManyAt, but doesn't update the last saved root stepManyAtNoSync :: (Foldable f) => - f (Path, Branch0 IO -> Branch0 IO) -> + f (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () -stepManyAtNoSync actions = - void . modifyProjectRoot $ Branch.stepManyAt actions +stepManyAtNoSync actions = do + void . modifyProjectRoot $ Branch.stepManyAt (relativizeActions actions) stepManyAtM :: (Foldable f) => Text -> - f (Path, Branch0 IO -> IO (Branch0 IO)) -> + f (Path.Absolute, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepManyAtM reason actions = do stepManyAtMNoSync actions @@ -429,11 +440,11 @@ stepManyAtM reason actions = do stepManyAtMNoSync :: (Foldable f) => - f (Path, Branch0 IO -> IO (Branch0 IO)) -> + f (Path.Absolute, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepManyAtMNoSync actions = do oldRoot <- getProjectRoot - newRoot <- liftIO (Branch.stepManyAtM actions oldRoot) + newRoot <- liftIO (Branch.stepManyAtM (relativizeActions actions) oldRoot) setCurrentProjectRoot newRoot -- | Sync the in-memory root branch. @@ -488,18 +499,18 @@ updateCurrentProjectRoot new reason = ------------------------------------------------------------------------------------------------------------------------ -- Getting terms -getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent) -getTermsAt path = do - rootBranch0 <- getProjectRoot0 - pure (BranchUtil.getTerm (Path.convert path) rootBranch0) +getTermsAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent) +getTermsAt (pp, hqSeg) = do + rootBranch0 <- getBranch0FromProjectPath pp + pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ -- Getting types -getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference) -getTypesAt path = do - rootBranch0 <- getProjectRoot0 - pure (BranchUtil.getType (Path.convert path) rootBranch0) +getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference) +getTypesAt (pp, hqSeg) = do + rootBranch0 <- getBranch0FromProjectPath pp + pure (BranchUtil.getType (mempty, hqSeg) rootBranch0) ------------------------------------------------------------------------------------------------------------------------ -- Getting patches @@ -517,8 +528,8 @@ getPatchAt path = -- | Get the patch at a path. getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch) getMaybePatchAt path0 = do - (path, name) <- resolveSplit' path0 - branch <- getBranch0FromProjectRootPath path + (pp, name) <- resolveSplit' path0 + branch <- getBranch0FromProjectPath pp liftIO (Branch.getMaybePatch name branch) -- | Get the patch at a path, or return early if there's no such patch. diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index c3a3ea88e2..aa22fa3daf 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -5,6 +5,7 @@ module Unison.Cli.Pretty ( displayBranchHash, prettyAbsolute, + prettyProjectPath, prettyBase32Hex#, prettyBase32Hex, prettyBranchId, @@ -88,6 +89,7 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Core.Project (ProjectBranchName) @@ -214,6 +216,9 @@ prettyRelative = P.blue . P.shown prettyAbsolute :: Path.Absolute -> Pretty prettyAbsolute = P.blue . P.shown +prettyProjectPath :: PP.ProjectPath -> Pretty +prettyProjectPath = P.blue . P.shown + prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash) diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 8d9b66c15a..6758fea324 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -3,7 +3,6 @@ module Unison.Cli.ProjectUtils ( -- * Project/path helpers expectProjectBranchByName, resolveBranchRelativePath, - resolveProjectPath, resolveProjectBranch, -- * Name hydration @@ -47,7 +46,6 @@ import Unison.Cli.Share.Projects (IncludeSquashedHead) import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..)) @@ -108,7 +106,7 @@ hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do pp <- Cli.getCurrentProjectPath - pure (ProjectAndBranch (pp ^. PP.asNames_ . #project) branchName) + pure (ProjectAndBranch (pp ^. #project . #name) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) -- Expect a local project+branch by ids. @@ -165,18 +163,6 @@ expectProjectAndBranchByTheseNames = \case maybeProjectAndBranch & onNothing do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) --- | Expect/resolve a branch-relative path with the following rules: --- --- 1. If the project is missing, use the current project. --- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current --- project, defaulting to 'main' if branch is unspecified. --- 3. If we just have a path, resolve it using the current project. -resolveProjectPath :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath -resolveProjectPath defaultProj mayProjAndBranch mayPath' = do - projAndBranch <- resolveProjectBranch defaultProj mayProjAndBranch - absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath' - pure $ PP.fromProjectAndBranch projAndBranch absPath - -- | Expect/resolve branch reference with the following rules: -- -- 1. If the project is missing, use the provided project. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 1393ce8ff7..e67fda5df4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -39,7 +39,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () - currentProjectName <- Cli.getCurrentProjectPath <&> view (PP.asNames_ . #project) + currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name) destProject <- do Cli.runTransactionWithRollback \rollback -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs index bdf20d61be..1657568ca9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs @@ -8,14 +8,15 @@ import Control.Lens ((^.)) 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.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName) handleBranchRename :: ProjectBranchName -> Cli () handleBranchRename newBranchName = do - (ProjectAndBranch project branch, _path) <- ProjectUtils.expectCurrentProjectBranch + PP.ProjectPath project branch _path <- Cli.getCurrentProjectPath case classifyProjectBranchName newBranchName of ProjectBranchNameKind'Contributor {} -> pure () diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs index 024ef29f26..8d82f100c1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs @@ -10,14 +10,14 @@ import Network.URI (URI) 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.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project (ProjectBranchName, ProjectName) handleBranches :: Maybe ProjectName -> Cli () handleBranches maybeProjectName = do - maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds + pp <- Cli.getCurrentProjectPath (project, branches) <- Cli.runTransactionWithRollback \rollback -> do project <- @@ -26,8 +26,7 @@ handleBranches maybeProjectName = do Queries.loadProjectByName projectName & onNothingM do rollback (Output.LocalProjectDoesntExist projectName) Nothing -> do - ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch) - Queries.expectProject projectId + pure (pp ^. #project) branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId) pure (project, branches) Cli.respondNumbered (Output.ListBranches (project ^. #name) (f branches)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index b6865748f1..7257c0f731 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -4,19 +4,18 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch ) where -import Control.Lens (over, (^.)) -import Data.Map.Strict qualified as Map -import Data.These (These (..)) +import Control.Lens +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) 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.Codebase.Editor.HandleInput.ProjectCreate +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -- | Delete a project branch. @@ -25,47 +24,46 @@ 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 - ProjectAndBranch Nothing branch -> That branch - ProjectAndBranch (Just project) branch -> These project branch +handleDeleteBranch projectAndBranchNames = do + ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath + ProjectAndBranch _proj branchToDelete <- ProjectUtils.resolveProjectBranch currentProject (projectAndBranchNames & #branch %~ Just) + Cli.runTransaction do + Queries.deleteProjectBranch (branchToDelete ^. #projectId) (branchToDelete ^. #branchId) - 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))) - ) + let projectId = branchToDelete ^. #projectId -- 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 - newPath <- - case deletedBranch ^. #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)) - Cli.cd newPath + -- 3. Any other branch in the codebase + -- 4. Create a dummy project and go to /main + when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do + mayNextLocation <- + Cli.runTransaction . runMaybeT $ + asum + [ parentBranch projectId (branchToDelete ^. #parentBranchId), + findMainBranchInProject projectId, + findAnyBranchInProject projectId, + findAnyBranchInCodebase + ] + nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing + Cli.switchProject nextLoc + where + parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + parentBranch projectId mayParentBranchId = do + parentBranchId <- hoistMaybe mayParentBranchId + pure (ProjectAndBranch projectId parentBranchId) + findMainBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findMainBranchInProject projectId = do + branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main") + pure (ProjectAndBranch projectId (branch ^. #branchId)) + + findAnyBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInProject projectId = do + (someBranchId, _) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing + pure (ProjectAndBranch projectId someBranchId) + findAnyBranchInCodebase :: MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInCodebase = do + (_, pbIds) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchNamePairs + pure pbIds diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs index 0004204670..272bbe7a9e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs @@ -10,17 +10,16 @@ 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.HandleInput.ProjectCreate (projectCreate) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectName) +import Unison.Project (ProjectName) -- | Delete a project handleDeleteProject :: ProjectName -> Cli () handleDeleteProject projectName = do - maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch + ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath deletedProject <- Cli.runTransactionWithRollback \rollback -> do @@ -30,14 +29,8 @@ handleDeleteProject projectName = do Queries.deleteProject (project ^. #projectId) pure project - let projectId = deletedProject ^. #projectId - - Cli.updateAt - ("delete.project " <> into @Text projectName) - (ProjectUtils.projectPath projectId) - (const Branch.empty) - - -- If the user is on the project that they're deleting, we cd to the root path - whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) -> - when (on (==) (view #projectId) deletedProject currentProject) do - Cli.cd (Path.Absolute Path.empty) + -- If the user is on the project that they're deleting, we create a new project to switch + -- to. + when (((==) `on` (view #projectId)) deletedProject currentProject) do + nextLoc <- projectCreate False Nothing + Cli.switchProject nextLoc diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 11d51197c5..6242eea115 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -10,8 +10,6 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.Text qualified as Text -import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..)) import Unison.Cli.DownloadUtils import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -39,14 +37,6 @@ import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText) handleInstallLib :: ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli () handleInstallLib (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do - (currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - - let currentProjectBranchPath = - ProjectUtils.projectBranchPath $ - ProjectAndBranch - currentProjectAndBranch.project.projectId - currentProjectAndBranch.branch.branchId - libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName libdepBranchName <- @@ -75,7 +65,7 @@ handleInstallLib (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) -- -- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3". libdepNameSegment :: NameSegment <- do - currentBranchObject <- Cli.getBranch0At currentProjectBranchPath + currentBranchObject <- Cli.getProjectRoot0 pure $ fresh (\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText) @@ -86,10 +76,7 @@ handleInstallLib (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) (makeDependencyName libdepProjectName libdepBranchName) let libdepPath :: Path.Absolute - libdepPath = - Path.resolve - currentProjectBranchPath - (Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment])) + libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment] let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames _didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs index fc57ff768f..52ccc84b10 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where -import Control.Lens (over, _2) +import Control.Lens import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.HashQualified' qualified as HQ' import Unison.NameSegment (NameSegment) import Unison.Prelude -moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)] +moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)] moveTermSteps src' dest' = do src <- Cli.resolveSplit' src' srcTerms <- Cli.getTermsAt src @@ -29,7 +30,7 @@ moveTermSteps src' dest' = do destTerms <- Cli.getTermsAt (Path.convert dest) when (not (Set.null destTerms)) do Cli.returnEarly (Output.TermAlreadyExists dest' destTerms) - let p = Path.convert src + let p = src & _1 %~ view PP.absPath_ pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs index b9da6747be..8d06e1ab03 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where -import Control.Lens (over, _2) +import Control.Lens import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -11,6 +11,7 @@ import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.HashQualified' qualified as HQ' import Unison.NameSegment (NameSegment) import Unison.Prelude @@ -29,11 +30,11 @@ moveTypeSteps src' dest' = do destTypes <- Cli.getTypesAt (Path.convert dest) when (not (Set.null destTypes)) do Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes) - let p = Path.convert src + let p = over _1 (view PP.path_) src pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType, - BranchUtil.makeAddTypeName (Path.convert dest) srcType + BranchUtil.makeAddTypeName (over _1 (view PP.path_) dest) srcType ] doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 90dead6159..aca9c87a2a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -17,7 +17,6 @@ import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli (stepAt) -import Unison.Cli.ProjectUtils (projectBranchPath) import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch @@ -57,12 +56,13 @@ import Witch (unsafeFrom) -- -- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too -- much time getting everything perfectly correct before we get there. -projectCreate :: Bool -> Maybe ProjectName -> Cli () +projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId) projectCreate tryDownloadingBase maybeProjectName = do projectId <- liftIO (ProjectId <$> UUID.nextRandom) branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom) let branchName = unsafeFrom @Text "main" + (_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash projectName <- case maybeProjectName of @@ -74,7 +74,7 @@ projectCreate tryDownloadingBase maybeProjectName = do projectName : projectNames -> Queries.projectExistsByName projectName >>= \case False -> do - insertProjectAndBranch projectId projectName branchId branchName + insertProjectAndBranch projectId projectName branchId branchName emptyCausalHashId pure projectName True -> loop projectNames loop randomProjectNames @@ -82,13 +82,12 @@ projectCreate tryDownloadingBase maybeProjectName = do Cli.runTransactionWithRollback \rollback -> do Queries.projectExistsByName projectName >>= \case False -> do - insertProjectAndBranch projectId projectName branchId branchName + insertProjectAndBranch projectId projectName branchId branchName emptyCausalHashId pure projectName True -> rollback (Output.ProjectNameAlreadyExists projectName) - let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId} Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName) - Cli.cd path + Cli.switchProject (ProjectAndBranch projectId branchId) maybeBaseLatestReleaseBranchObject <- if tryDownloadingBase @@ -144,17 +143,18 @@ projectCreate tryDownloadingBase maybeProjectName = do (Map.insert NameSegment.libSegment projectBranchLibObject) Branch.empty0 - Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject) + Cli.stepAt reflogDescription (Path.absoluteEmpty, const projectBranchObject) Cli.respond Output.HappyCoding + pure ProjectAndBranch {project = projectId, branch = branchId} where reflogDescription = case maybeProjectName of Nothing -> "project.create" Just projectName -> "project.create " <> into @Text projectName -insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction () -insertProjectAndBranch projectId projectName branchId branchName = do +insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> CausalHashId -> Sqlite.Transaction () +insertProjectAndBranch projectId projectName branchId branchName chId = do Queries.insertProject projectId projectName Queries.insertProjectBranch Sqlite.ProjectBranch @@ -162,7 +162,7 @@ insertProjectAndBranch projectId projectName branchId branchName = do branchId, name = branchName, parentBranchId = Nothing, - rootCausalHash = error "Add causal hash id in insertProjectAndBranch" + causalHashId = chId } Queries.setMostRecentBranch projectId branchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index 23c9fb4736..77c7fc7885 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs @@ -174,16 +174,16 @@ handleUpdate input optionalPatch requestedNames = do -- take a look at the `updates` from the SlurpResult -- and make a patch diff to record a replacement from the old to new references Cli.stepManyAtMNoSync - ( [ ( Path.unabsolute currentPath', + ( [ ( currentPath', pure . doSlurpUpdates typeEdits termEdits termDeprecations ), - ( Path.unabsolute currentPath', + ( currentPath', pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) ) ] ++ case patchOps of Nothing -> [] - Just (_, update, p) -> [(Path.unabsolute p, update)] + Just (_, update, p) -> [(p, update)] ) Cli.runTransaction . Codebase.addDefsToCodebase codebase @@ -501,7 +501,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do -- fresh2 = fresh1 + 2 -- fresh3 = fresh2 + 3 terms = - Map.fromList $ Map.elems refToGeneratedNameAndTerm <&> \(v,term) -> (v, (External, term)), + Map.fromList $ Map.elems refToGeneratedNameAndTerm <&> \(v, term) -> (v, (External, term)), -- In the context of this update, whatever watches were in the latest typechecked Unison file are -- irrelevant, so we don't need to copy them over. watches = Map.empty @@ -649,7 +649,7 @@ doSlurpUpdates typeEdits termEdits deprecated b0 = propagatePatchNoSync :: Patch -> Path.Absolute -> Cli Bool propagatePatchNoSync patch scopePath = Cli.time "propagatePatchNoSync" do - Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + Cli.stepAtNoSync' (scopePath, Propagate.propagateAndApply patch) recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])] recomponentize = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index de4e39c473..710a98a27a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -206,7 +206,7 @@ saveTuf getConstructors tuf = do Cli.runTransactionWithRollback \abort -> do Codebase.addDefsToCodebase codebase tuf typecheckedUnisonFileToBranchUpdates abort getConstructors tuf - Cli.stepAt "update" (Path.unabsolute currentPath, Branch.batchUpdates branchUpdates) + Cli.stepAt "update" (currentPath, Branch.batchUpdates branchUpdates) -- @typecheckedUnisonFileToBranchUpdates getConstructors file@ returns a list of branch updates (suitable for passing -- along to `batchUpdates` or some "step at" combinator) that corresponds to using all of the contents of @file@. diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 427d901fb4..5a9304c1ea 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -67,6 +67,8 @@ type BranchId = Either ShortCausalHash Path' -- | An unambiguous project branch name, use the current project name if not provided. type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName +-- | TODO: You should probably use a `ProjectPath` instead of a `Path.Absolute` in most +-- cases. type AbsBranchId = Either ShortCausalHash Path.Absolute type HashOrHQSplit' = Either ShortHash Path.HQSplit' diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 7249aea28c..d6ce46087a 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -145,7 +145,7 @@ completeWithinNamespace :: Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength - b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.asIds_) + b <- Codebase.getShallowBranchAtProjectPath queryProjectPath currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index 704fdc2b33..37fdff8b18 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . #project) Nothing) + Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing) <&> fmap (into @Text . snd) -- | Exported from here just so the debug command and actual implementation can use the same diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 93f8f58e18..d05b8929ce 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -3598,7 +3598,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do -- Complete the text into a branch name within the provided project handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion] handleBranchesComplete branchName codebase pp = do - let projId = pp ^. PP.asIds_ . #project + let projId = pp ^. #project . #projectId branches <- Codebase.runTransaction codebase do fmap (filterBranches config pp) do @@ -3615,7 +3615,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do & List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId) & maybeToList - PP.ProjectPath currentProjectId _currentBranchId _currentPath = pp ^. PP.asIds_ + PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp projectToCompletion :: Sqlite.Project -> Completion projectToCompletion project = @@ -3646,7 +3646,7 @@ handleBranchesComplete config branchName codebase pp = do branches <- Codebase.runTransaction codebase do fmap (filterBranches config pp) do - Queries.loadAllProjectBranchesBeginningWith (pp ^. PP.asIds_ . #project) (Just branchName) + Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName) pure (map currentProjectBranchToCompletion branches) filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] @@ -3655,7 +3655,7 @@ filterBranches config pp branches = AllBranches -> branches ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) where - currentBranchId = pp ^. PP.asIds_ . #branch + currentBranchId = pp ^. #branch . #branchId currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 78873f0d65..07061de029 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -83,7 +83,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Just a -> pure a go :: Line.InputT IO Input go = do - let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.asNames_ + let (PP.ProjectPath projectName projectBranchName path) = PP.toNames ppCtx let promptString = P.sep ":" diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 10acc76c96..9065c5de45 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -59,5 +59,5 @@ getCurrentProjectBranch codebase = do -- TODO: Come up with a better solution for this error "No current project path context" Just pp -> pp - let (PP.ProjectPath projName branchName path) = pp ^. PP.asNames_ + let (PP.ProjectPath projName branchName path) = PP.toNames pp pure $ Current (Just projName) (Just branchName) path From 457ca14a0551832daa8a104e2b97d85c2fa0aed5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 24 May 2024 15:17:26 -0700 Subject: [PATCH 12/76] Allow updating branch heads --- .../U/Codebase/Sqlite/Queries.hs | 11 +++++++++ .../src/Unison/Codebase/Type.hs | 7 ------ unison-cli/src/Unison/Cli/MonadUtils.hs | 23 ++++++++++--------- .../Codebase/Editor/HandleInput/Merge2.hs | 12 +++++----- 4 files changed, 29 insertions(+), 24 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 208875cb10..e6e62d2d16 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -135,6 +135,7 @@ module U.Codebase.Sqlite.Queries insertProjectBranch, renameProjectBranch, deleteProjectBranch, + setProjectBranchHead, setMostRecentBranch, loadMostRecentBranch, @@ -3770,6 +3771,16 @@ deleteProjectBranch projectId branchId = do WHERE project_id = :projectId AND branch_id = :branchId |] +-- | Set project branch HEAD +setProjectBranchHead :: ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () +setProjectBranchHead projectId branchId causalHashId = + execute + [sql| + UPDATE project_branch + SET causal_hash_id = :causalHashId + WHERE project_id = :projectId AND branch_id = :branchId + |] + data LoadRemoteBranchFlag = IncludeSelfRemote | ExcludeSelfRemote diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index d9da1aa2aa..b5241d0ce6 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -63,13 +63,6 @@ data Codebase m v a = Codebase putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (), -- getTermComponent :: Hash -> m (Maybe [Term v a]), getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]), - -- | Get the root branch. - getRootBranch :: m (Branch m), - -- | Like 'putBranch', but also adjusts the root branch pointer afterwards. - putRootBranch :: - Text -> -- Reason for the change, will be recorded in the reflog - Branch m -> - m (), getBranchForHash :: CausalHash -> m (Maybe (Branch m)), -- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't -- already exist. diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index c9d3e355ce..78ec10730c 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -50,7 +50,7 @@ module Unison.Cli.MonadUtils stepManyAtMNoSync, stepManyAtNoSync, syncRoot, - updateCurrentProjectRoot, + updateProjectBranchRoot, updateAtM, updateAt, updateAndStepAt, @@ -110,6 +110,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath, ProjectPathG (..)) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -457,12 +458,12 @@ syncRoot description = do -- an update occurred and false otherwise updateAtM :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool -updateAtM reason (Path.Absolute p) f = do - b <- getProjectRoot - b' <- Branch.modifyAtM p f b +updateAtM reason pp f = do + b <- getBranchFromProjectPath (pp & PP.absPath_ .~ Path.absoluteEmpty) + b' <- Branch.modifyAtM (pp ^. PP.path_) f b updateCurrentProjectRoot b' reason pure $ b /= b' @@ -470,7 +471,7 @@ updateAtM reason (Path.Absolute p) f = do -- an update occurred and false otherwise updateAt :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Branch IO) -> Cli Bool updateAt reason p f = do @@ -487,13 +488,13 @@ updateAndStepAt reason updates steps = do (Branch.stepManyAt steps) . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) <$> getProjectRoot - updateCurrentProjectRoot root reason + ProjectPath _ projBranch _ <- getCurrentProjectPath + updateProjectBranchRoot projBranch root reason -updateCurrentProjectRoot :: Branch IO -> Text -> Cli () -updateCurrentProjectRoot new reason = +updateProjectBranchRoot :: ProjectBranch -> Branch IO -> Text -> Cli () +updateProjectBranchRoot projectBranch new reason = Cli.time "updateCurrentProjectRoot" do - Cli.Env {codebase} <- ask - liftIO (Codebase.putRootBranch codebase reason new) + runTransaction $ Q.setProjectBranchHead (projectBranch ^. #branchId) (Branch.headHash new) setCurrentProjectRoot new ------------------------------------------------------------------------------------------------------------------------ diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index d6685f1059..7a3a69b89e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -43,7 +43,7 @@ import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin.Decls qualified as Builtin.Decls -import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..)) +import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli @@ -64,6 +64,7 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadShareLooseCode (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.Codebase.SqliteCodebase.Operations qualified as Operations @@ -136,11 +137,12 @@ import Unison.Util.SyntaxText (SyntaxText') import Unison.Var (Var) import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) +import qualified U.Codebase.Sqlite.Queries as Q handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do -- Assert that Alice (us) is on a project branch, and grab the causal hash. - (ProjectAndBranch aliceProject aliceProjectBranch, _path) <- Cli.expectCurrentProjectBranch + ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath aliceCausalHash <- Cli.runTransaction (projectBranchToCausalHash aliceProjectBranch) -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch @@ -182,9 +184,7 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do where projectBranchToCausalHash :: ProjectBranch -> Transaction CausalHash projectBranchToCausalHash branch = do - let path = Cli.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId) - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) - pure causal.causalHash + Q.expectCausalHash (branch ^. causalHashId) data MergeInfo = MergeInfo { alice :: !AliceMergeInfo, @@ -220,7 +220,7 @@ doMerge info = do let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name let mergeSource = MergeSourceOrTarget'Source info.bob.source let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames - let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source } + let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source} Cli.Env {codebase} <- ask From 9756ac8c1ea86f430d09eba2cf66eac9c1d6a43c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 May 2024 09:24:45 -0700 Subject: [PATCH 13/76] WIP --- .../U/Codebase/Sqlite/Operations.hs | 31 ------------------- parser-typechecker/src/Unison/Codebase.hs | 3 -- .../src/Unison/Codebase/Execute.hs | 13 +++----- .../src/Unison/Codebase/SqliteCodebase.hs | 28 +---------------- .../Codebase/SqliteCodebase/Operations.hs | 11 ------- unison-cli/src/ArgParse.hs | 2 +- 6 files changed, 7 insertions(+), 81 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b32babbf1c..2bd8e016ab 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -1,10 +1,5 @@ module U.Codebase.Sqlite.Operations ( -- * branches - saveRootBranch, - loadRootCausalHash, - expectRootCausalHash, - expectRootCausal, - expectRootBranchHash, loadCausalHashAtPath, expectCausalHashAtPath, loadCausalBranchAtPath, @@ -235,19 +230,6 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId loadValueHashById :: Db.BranchHashId -> Transaction BranchHash loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId -expectRootCausalHash :: Transaction CausalHash -expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot - -expectRootBranchHash :: Transaction BranchHash -expectRootBranchHash = do - rootCausalHashId <- Q.expectNamespaceRoot - expectValueHashByCausalHashId rootCausalHashId - -loadRootCausalHash :: Transaction (Maybe CausalHash) -loadRootCausalHash = - runMaybeT $ - lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot - -- | Load the causal hash at the given path from the provided root, if Nothing, use the -- codebase root. loadCausalHashAtPath :: Maybe CausalHash -> Q.TextPathSegments -> Transaction (Maybe CausalHash) @@ -616,16 +598,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = boId <- Q.expectBranchObjectIdByCausalHashId chId expectBranch boId -saveRootBranch :: - HashHandle -> - C.Branch.CausalBranch Transaction -> - Transaction (Db.BranchObjectId, Db.CausalHashId) -saveRootBranch hh c = do - when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c) - (boId, chId) <- saveBranch hh c - Q.setNamespaceRoot chId - pure (boId, chId) - -- saveBranch is kind of a "deep save causal" -- we want a "shallow save causal" that could take a @@ -752,9 +724,6 @@ saveCausalObject hh (C.Causal.Causal hc he parents _) = do Q.saveCausal hh chId bhId parentCausalHashIds pure (chId, bhId) -expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction) -expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId - loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 80d9fc41dd..e422d85d20 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -58,10 +58,7 @@ module Unison.Codebase getShallowProjectRootByNames, -- * Root branch - getRootBranch, - SqliteCodebase.Operations.getRootBranchExists, Operations.expectRootCausalHash, - putRootBranch, SqliteCodebase.Operations.namesAtPath, -- * Patches diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 4d8a5317a9..21a34f8ffc 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -8,13 +8,11 @@ module Unison.Codebase.Execute where import Control.Exception (finally) import Control.Monad.Except import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Branch.Names qualified as Branch 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.Names qualified as Names +import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE @@ -24,15 +22,14 @@ import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> + Names -> Text -> IO (Either Runtime.Error ()) -execute codebase runtime mainName = +execute codebase runtime names mainName = (`finally` Runtime.terminate runtime) . runExceptT $ do - root <- liftIO $ Codebase.getRootBranch codebase - let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root)) - loadTypeOfTerm = Codebase.getTypeOfTerm codebase + let loadTypeOfTerm = Codebase.getTypeOfTerm codebase let mainType = Runtime.mainType runtime - mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType + mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm names 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) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f21330e2..1d37f8e581 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -245,37 +245,13 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action rootBranchCache (runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType)) - putRootBranch :: Text -> Branch m -> m () - putRootBranch reason branch1 = do - now <- liftIO getCurrentTime - withRunInIO \runInIO -> do - -- this is naughty, the type says Transaction but it - -- won't run automatically with whatever Transaction - -- it is composed into unless the enclosing - -- Transaction is applied to the same db connection. - let branch1Trans = Branch.transform (Sqlite.unsafeIO . runInIO) branch1 - putRootBranchTrans :: Sqlite.Transaction () = do - let emptyCausalHash = Branch.headHash Branch.empty - fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash - let toRootCausalHash = Branch.headHash branch1 - CodebaseOps.putRootBranch branch1Trans - Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason}) - - -- We need to update the database and the cached - -- value. We want to keep these in sync, so we take - -- the cache lock while updating sqlite. - withLock - rootBranchCache - (\restore _ -> restore $ runInIO $ runTransaction putRootBranchTrans) - (\_ -> Just branch1Trans) - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: CausalHash -> m (Maybe (Branch m)) getBranchForHash h = fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h) - putBranch :: Branch m -> m () + putBranch :: Branch m -> m CausalHash putBranch branch = withRunInIO \runInIO -> runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) @@ -334,8 +310,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putTypeDeclaration, putTypeDeclarationComponent, getTermComponentWithTypes, - getRootBranch, - putRootBranch, getBranchForHash, putBranch, syncFromDirectory, diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 48a183864d..c3fc112510 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -387,17 +387,6 @@ uncachedLoadRootBranch branchCache getDeclType = do causal2 <- Ops.expectRootCausal Cv.causalbranch2to1 branchCache getDeclType causal2 --- | Get whether the root branch exists. -getRootBranchExists :: Transaction Bool -getRootBranchExists = - isJust <$> Ops.loadRootCausalHash - -putRootBranch :: Branch Transaction -> Transaction () -putRootBranch branch1 = do - -- todo: check to see if root namespace hash has been externally modified - -- and do something (merge?) it if necessary. But for now, we just overwrite it. - void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1)) - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 84f2ae538c..1a3c4bb9db 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -66,7 +66,7 @@ type SymbolName = Text -- | Valid ways to provide source code to the run command data RunSource = RunFromPipe SymbolName - | RunFromSymbol SymbolName + | RunFromSymbol ProjectPath | RunFromFile FilePath SymbolName | RunCompiled FilePath deriving (Show, Eq) From 33c42db170ddbe5a192555c3113e9e31a2556eae Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 09:36:56 -0700 Subject: [PATCH 14/76] Fix weird added file --- Input.hs | 335 ------------------------------------------------------- 1 file changed, 335 deletions(-) delete mode 100644 Input.hs diff --git a/Input.hs b/Input.hs deleted file mode 100644 index 427d901fb4..0000000000 --- a/Input.hs +++ /dev/null @@ -1,335 +0,0 @@ -module Unison.Codebase.Editor.Input - ( Input (..), - BranchSourceI (..), - DiffNamespaceToPatchInput (..), - GistInput (..), - PullSourceTarget (..), - PushRemoteBranchInput (..), - PushSourceTarget (..), - PushSource (..), - TestInput (..), - Event (..), - OutputLocation (..), - PatchPath, - BranchId, - AbsBranchId, - UnresolvedProjectBranch, - parseBranchId, - parseBranchId2, - parseShortCausalHash, - HashOrHQSplit', - Insistence (..), - PullMode (..), - OptionalPatch (..), - FindScope (..), - ShowDefinitionScope (..), - IsGlobal, - DeleteOutput (..), - DeleteTarget (..), - ) -where - -import Data.List.NonEmpty (NonEmpty) -import Data.Text qualified as Text -import Data.These (These) -import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) -import Unison.Codebase.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.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) -import Unison.HashQualified qualified as HQ -import Unison.Name (Name) -import Unison.NameSegment (NameSegment) -import Unison.Prelude -import Unison.Project (ProjectAndBranch, ProjectAndBranchNames, ProjectBranchName, ProjectBranchNameOrLatestRelease, ProjectName, Semver) -import Unison.ShortHash (ShortHash) -import Unison.Util.Pretty qualified as P - -data Event - = UnisonFileChanged SourceName Source - deriving stock (Show) - -type Source = Text -- "id x = x\nconst a b = a" - -type SourceName = Text -- "foo.u" or "buffer 7" - -type PatchPath = Path.Split' - -data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath - deriving (Eq, Ord, Show) - -type BranchId = Either ShortCausalHash Path' - --- | An unambiguous project branch name, use the current project name if not provided. -type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName - -type AbsBranchId = Either ShortCausalHash Path.Absolute - -type HashOrHQSplit' = Either ShortHash Path.HQSplit' - --- | Should we force the operation or not? -data Insistence = Force | Try - deriving (Show, Eq) - -parseBranchId :: String -> Either Text BranchId -parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of - Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> pure $ Left h -parseBranchId s = Right <$> Path.parsePath' s - -parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) -parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of - Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> Right (Left h) -parseBranchId2 s = Right <$> parseBranchRelativePath s - -parseShortCausalHash :: String -> Either String ShortCausalHash -parseShortCausalHash ('#' : s) | Just sch <- SCH.fromText (Text.pack s) = Right sch -parseShortCausalHash _ = Left "Invalid hash, expected a base32hex string." - -data PullMode - = PullWithHistory - | PullWithoutHistory - deriving (Eq, Show) - -type IsGlobal = Bool - -data Input - = -- names stuff: - -- directory ops - -- `Link` must describe a repo and a source path within that repo. - -- clone w/o merge, error if would clobber - ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath - | -- merge first causal into destination - MergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) Branch.MergeMode - | PreviewMergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) - | DiffNamespaceI BranchId BranchId -- old new - | PullI !PullSourceTarget !PullMode - | PushRemoteBranchI PushRemoteBranchInput - | ResetRootI (Either ShortCausalHash Path') - | ResetI - ( These - (Either ShortCausalHash Path') - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - (Maybe UnresolvedProjectBranch) - | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? - -- Does it make sense to fork from not-the-root of a Github repo? - -- used in Welcome module to give directions to user - CreateMessage (P.Pretty P.ColorText) - | -- Change directory. - SwitchBranchI Path' - | UpI - | PopBranchI - | -- > names foo - -- > names foo.bar - -- > names .foo.bar - -- > names .foo.bar#asdflkjsdf - -- > names #sdflkjsdfhsdf - NamesI IsGlobal (HQ.HashQualified Name) - | AliasTermI HashOrHQSplit' Path.Split' - | AliasTypeI HashOrHQSplit' Path.Split' - | AliasManyI [Path.HQSplit] Path' - | MoveAllI Path.Path' Path.Path' - | -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name. - 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: - LoadI (Maybe FilePath) - | ClearI - | AddI (Set Name) - | PreviewAddI (Set Name) - | UpdateI OptionalPatch (Set Name) - | 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] - | -- save the result of a previous Execute - SaveExecuteResultI Name - | -- execute an IO [Result] - IOTestI (HQ.HashQualified Name) - | -- execute all in-scope IO tests - IOTestAllI - | -- make a standalone binary file - MakeStandaloneI String (HQ.HashQualified Name) - | -- execute an IO thunk using scheme - ExecuteSchemeI Text [String] - | -- compile to a scheme file - CompileSchemeI Text (HQ.HashQualified Name) - | TestI TestInput - | CreateAuthorI NameSegment {- identifier -} Text {- name -} - | -- Display provided definitions. - DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) - | -- Display docs for provided terms. - DocsI (NonEmpty Path.HQSplit') - | -- 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)) - | ShowReflogI - | UpdateBuiltinsI - | MergeBuiltinsI (Maybe Path) - | MergeIOBuiltinsI (Maybe Path) - | ListDependenciesI (HQ.HashQualified Name) - | ListDependentsI (HQ.HashQualified Name) - | -- | List all external dependencies of a given namespace, or the current namespace if - -- no path is provided. - NamespaceDependenciesI (Maybe Path') - | DebugTabCompletionI [String] -- The raw arguments provided - | DebugFuzzyOptionsI String [String] -- cmd and arguments - | DebugFormatI - | DebugNumberedArgsI - | DebugTypecheckedUnisonFileI - | DebugDumpNamespacesI - | DebugDumpNamespaceSimpleI - | DebugTermI (Bool {- Verbose mode -}) (HQ.HashQualified Name) - | DebugTypeI (HQ.HashQualified Name) - | DebugLSPFoldRangesI - | DebugClearWatchI - | DebugDoctorI - | DebugNameDiffI ShortCausalHash ShortCausalHash - | QuitI - | ApiI - | UiI Path' - | DocToMarkdownI Name - | DocsToHtmlI Path' FilePath - | GistI GistInput - | AuthLoginI - | VersionI - | DiffNamespaceToPatchI DiffNamespaceToPatchInput - | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) - | ProjectRenameI ProjectName - | ProjectSwitchI ProjectAndBranchNames - | ProjectsI - | BranchI BranchSourceI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - | BranchRenameI ProjectBranchName - | BranchesI (Maybe ProjectName) - | CloneI ProjectAndBranchNames (Maybe ProjectAndBranchNames) - | ReleaseDraftI Semver - | UpgradeI !NameSegment !NameSegment - | EditNamespaceI [Path.Path] - | -- New merge algorithm: merge the given project branch into the current one. - MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - | LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) - deriving (Eq, Show) - --- | The source of a `branch` command: what to make the new branch from. -data BranchSourceI - = -- | Create a branch from the current context - BranchSourceI'CurrentContext - | -- | Create an empty branch - BranchSourceI'Empty - | -- | Create a branch from this other branch - BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch - 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)) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - deriving stock (Eq, Show) - -data PushSource - = PathySource Path' - | ProjySource (These ProjectName ProjectBranchName) - deriving stock (Eq, Show) - --- | Push source and target: either neither is specified, or only a target, or both. -data PushSourceTarget - = PushSourceTarget0 - | PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName)) - | PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName)) - deriving stock (Eq, Show) - -data PushRemoteBranchInput = PushRemoteBranchInput - { sourceTarget :: PushSourceTarget, - pushBehavior :: PushBehavior - } - deriving stock (Eq, Show) - -data TestInput = TestInput - { -- | Should we run tests in the `lib` namespace? - includeLibNamespace :: Bool, - -- | Relative path to run the tests in. Ignore if `includeLibNamespace` is True - that means test everything. - path :: Path, - showFailures :: Bool, - showSuccesses :: Bool - } - deriving stock (Eq, Show) - --- Some commands, like `view`, can dump output to either console or a file. -data OutputLocation - = ConsoleLocation - | LatestFileLocation - | FileLocation FilePath - -- ClipboardLocation - deriving (Eq, Show) - -data FindScope - = FindLocal Path - | FindLocalAndDeps Path - | FindGlobal - deriving stock (Eq, Show) - -data ShowDefinitionScope - = ShowDefinitionLocal - | ShowDefinitionGlobal - deriving stock (Eq, Show) - -data DeleteOutput - = DeleteOutput'Diff - | DeleteOutput'NoDiff - deriving stock (Eq, Show) - -data DeleteTarget - = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit'] - | DeleteTarget'Term DeleteOutput [Path.HQSplit'] - | DeleteTarget'Type DeleteOutput [Path.HQSplit'] - | DeleteTarget'Namespace Insistence Path.Split - | DeleteTarget'Patch Path.Split' - | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - | DeleteTarget'Project ProjectName - deriving stock (Eq, Show) From 0d80992da9e2b5bfa9a1229553591d083dd532d5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 09:38:45 -0700 Subject: [PATCH 15/76] Remove root branch accessors from codebase --- parser-typechecker/src/Unison/Codebase.hs | 37 ++----------------- .../Codebase/SqliteCodebase/Operations.hs | 8 ---- 2 files changed, 4 insertions(+), 41 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index e422d85d20..1cc958b763 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -48,17 +48,13 @@ module Unison.Codebase SqliteCodebase.Operations.before, getShallowBranchAtPath, getShallowCausalAtPath, - getBranchAtPath, Operations.expectCausalBranchByCausalHash, getShallowCausalAtPathFromRootHash, - getShallowRootBranch, - getShallowRootCausal, getShallowProjectRootBranch, getShallowBranchAtProjectPath, getShallowProjectRootByNames, -- * Root branch - Operations.expectRootCausalHash, SqliteCodebase.Operations.namesAtPath, -- * Patches @@ -113,7 +109,6 @@ where import Data.Map qualified as Map import Data.Set qualified as Set -import U.Codebase.Branch qualified as V2 import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) @@ -182,36 +177,22 @@ getShallowCausalAtPathFromRootHash :: Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) getShallowCausalAtPathFromRootHash rootCausalHash p = do rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash - getShallowCausalAtPath p (Just rootCausal) - --- | Get the shallow representation of the root branches without loading the children or --- history. -getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction) -getShallowRootBranch = do - getShallowRootCausal >>= V2Causal.value - --- | Get the shallow representation of the root branches without loading the children or --- history. -getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction) -getShallowRootCausal = do - hash <- Operations.expectRootCausalHash - Operations.expectCausalBranchByCausalHash hash + getShallowCausalAtPath p rootCausal -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowCausalAtPath :: Path -> - Maybe (V2Branch.CausalBranch Sqlite.Transaction) -> + (V2Branch.CausalBranch Sqlite.Transaction) -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalAtPath path mayCausal = do - causal <- whenNothing mayCausal getShallowRootCausal +getShallowCausalAtPath path causal = do case path of Path.Empty -> pure causal ns Path.:< p -> do b <- V2Causal.value causal case V2Branch.childAt ns b of Nothing -> pure (Cv.causalbranch1to2 Branch.empty) - Just childCausal -> getShallowCausalAtPath p (Just childCausal) + Just childCausal -> getShallowCausalAtPath p childCausal -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. @@ -249,16 +230,6 @@ getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMayb causalHash <- lift $ Q.expectCausalHash causalHashId lift $ Operations.expectCausalBranchByCausalHash causalHash --- | Get a v1 branch from the root following the given path. -getBranchAtPath :: - (MonadIO m) => - Codebase m v a -> - Path.Absolute -> - m (Branch m) -getBranchAtPath codebase path = do - V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing - expectBranchForHash codebase causalHash - -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m) expectBranchForHash codebase hash = diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 9e70bbf1b3..06ec565664 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -379,14 +379,6 @@ tryFlushDeclBuffer termBuffer declBuffer = h in loop -uncachedLoadRootBranch :: - BranchCache Sqlite.Transaction -> - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - Transaction (Branch Transaction) -uncachedLoadRootBranch branchCache getDeclType = do - causal2 <- Ops.expectRootCausal - Cv.causalbranch2to1 branchCache getDeclType causal2 - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: From 216967f8ce998ea8334826bf0cd59556777f5ca9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 09:38:45 -0700 Subject: [PATCH 16/76] Use onCreate hook to initialize projects --- unison-cli/src/Unison/Main.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 32e829c0b1..b9be22f80f 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -390,7 +390,7 @@ prepareTranscriptDir verbosity shouldFork mCodePathOption shouldSaveCodebase = d tmp <- case shouldSaveCodebase of SaveCodebase (Just path) -> pure path _ -> Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript") - let cbInit = SC.init + let cbInit = SC.initWithSetup bootstrapNewCodebase case shouldFork of UseFork -> do -- A forked codebase does not need to Create a codebase, because it already exists @@ -571,7 +571,8 @@ getConfigFilePath mcodepath = ( ".unisonConfig") <$> Codebase.getCodebaseDir getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r getCodebaseOrExit codebasePathOption migrationStrategy action = do initOptions <- argsToCodebaseInitOptions codebasePathOption - result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions SC.DoLock migrationStrategy \case + let cbInit = SC.initWithSetup bootstrapNewCodebase + result <- CodebaseInit.withOpenOrCreateCodebase cbInit "main" initOptions SC.DoLock migrationStrategy \case cbInit@(CreatedCodebase, dir, _) -> do pDir <- prettyDir dir PT.putPrettyLn' "" @@ -652,3 +653,6 @@ codebasePathOptionToPath codebasePathOption = case codebasePathOption of CreateCodebaseWhenMissing p -> p DontCreateCodebaseWhenMissing p -> p + +bootstrapNewCodebase :: _ +bootstrapNewCodebase = error "Implement bootstrapNewCodebase." From 1d906b3765c22acdce073eee71c91ef8aa24a7b0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 09:38:45 -0700 Subject: [PATCH 17/76] Clean up uses of root in Codebase, kill the root branch cache --- .../src/Unison/Codebase/SqliteCodebase.hs | 16 +--------------- .../unison-parser-typechecker.cabal | 1 - 2 files changed, 1 insertion(+), 16 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 1d37f8e581..734020509e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -18,12 +18,9 @@ import Data.Either.Extra () import Data.IORef import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Time (getCurrentTime) import System.Console.ANSI qualified as ANSI import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) import U.Codebase.HashTags (CausalHash, PatchHash (..)) -import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Operations qualified as Ops import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Sync22 qualified as Sync22 import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) @@ -37,10 +34,8 @@ import Unison.Codebase.Init qualified as Codebase import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1 import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1 -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.Migrations qualified as Migrations import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths @@ -107,7 +102,6 @@ createCodebaseOrError onCreate debugName path lockOption action = do Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do Q.createSchema - void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty onCreate sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case @@ -167,7 +161,6 @@ sqliteCodebase :: (Codebase m Symbol Ann -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do - rootBranchCache <- newEmptyRootBranchCacheIO branchCache <- newBranchCache getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType -- The v1 codebase interface has operations to read and write individual definitions @@ -238,20 +231,13 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putTypeDeclarationComponent = CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer - getRootBranch :: m (Branch m) - getRootBranch = - Branch.transform runTransaction - <$> fetchRootBranch - rootBranchCache - (runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType)) - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: CausalHash -> m (Maybe (Branch m)) getBranchForHash h = fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h) - putBranch :: Branch m -> m CausalHash + putBranch :: Branch m -> m () putBranch branch = withRunInIO \runInIO -> runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index eb573c3741..f18984313d 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -62,7 +62,6 @@ library Unison.Codebase.Path.Parse Unison.Codebase.ProjectPath Unison.Codebase.PushBehavior - Unison.Codebase.RootBranchCache Unison.Codebase.Runtime Unison.Codebase.Serialization Unison.Codebase.ShortCausalHash From 33610106ca09c16be7b43e193b699f667d118c15 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 09:38:45 -0700 Subject: [PATCH 18/76] Fix up uses of root branch in Backend --- .../src/Unison/Codebase/Execute.hs | 3 +- .../src/Unison/Codebase/RootBranchCache.hs | 110 ------------------ unison-share-api/src/Unison/Server/Backend.hs | 74 +++++------- 3 files changed, 28 insertions(+), 159 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/RootBranchCache.hs diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 8b86d8afe4..1149c5ee79 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -12,10 +12,9 @@ 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.Names qualified as Names -import Unison.Names (Names) import Unison.HashQualified qualified as HQ import Unison.Name (Name) +import Unison.Names (Names) import Unison.Parser.Ann (Ann) import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) diff --git a/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs b/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs deleted file mode 100644 index ab092c8031..0000000000 --- a/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Unison.Codebase.RootBranchCache - ( RootBranchCache, - newEmptyRootBranchCache, - newEmptyRootBranchCacheIO, - fetchRootBranch, - withLock, - ) -where - -import Control.Concurrent.STM (newTVarIO) -import Control.Monad (join) -import Control.Monad.IO.Class -import Data.Coerce (coerce) -import Unison.Codebase.Branch.Type (Branch) -import Unison.Sqlite qualified as Sqlite -import UnliftIO (MonadUnliftIO, mask, onException) -import UnliftIO.STM - ( STM, - TVar, - atomically, - newTVar, - readTVar, - retrySTM, - writeTVar, - ) - -data RootBranchCacheVal - = Empty - | -- | Another thread is updating the cache. If this value is observed - -- then the reader should wait until the value is Empty or Full. The - -- api exposed from this module guarantees that a thread cannot exit - -- and leave the cache in this state. - ConcurrentModification - | Full (Branch Sqlite.Transaction) - --- This is isomorphic to @TMVar (Maybe (Branch Sqlite.Transaction))@ -newtype RootBranchCache = RootBranchCache (TVar RootBranchCacheVal) - -newEmptyRootBranchCacheIO :: (MonadIO m) => m RootBranchCache -newEmptyRootBranchCacheIO = liftIO (coerce $ newTVarIO Empty) - -newEmptyRootBranchCache :: STM RootBranchCache -newEmptyRootBranchCache = coerce (newTVar Empty) - -readRbc :: RootBranchCache -> STM RootBranchCacheVal -readRbc (RootBranchCache v) = readTVar v - -writeRbc :: RootBranchCache -> RootBranchCacheVal -> STM () -writeRbc (RootBranchCache v) x = writeTVar v x - --- | Read the root branch cache, wait if the cache is currently being --- updated -readRootBranchCache :: RootBranchCache -> STM (Maybe (Branch Sqlite.Transaction)) -readRootBranchCache v = - readRbc v >>= \case - Empty -> pure Nothing - ConcurrentModification -> retrySTM - Full x -> pure (Just x) - -fetchRootBranch :: forall m. (MonadUnliftIO m) => RootBranchCache -> m (Branch Sqlite.Transaction) -> m (Branch Sqlite.Transaction) -fetchRootBranch rbc getFromDb = mask \restore -> do - join (atomically (fetch restore)) - where - fetch :: (forall x. m x -> m x) -> STM (m (Branch Sqlite.Transaction)) - fetch restore = do - readRbc rbc >>= \case - Empty -> do - writeRbc rbc ConcurrentModification - pure do - rootBranch <- restore getFromDb `onException` atomically (writeRbc rbc Empty) - atomically (writeRbc rbc (Full rootBranch)) - pure rootBranch - ConcurrentModification -> retrySTM - Full x -> pure (pure x) - --- | Take a cache lock so that no other thread can read or write to --- the cache, perform an action with the cached value, then restore --- the cache to Empty or Full -withLock :: - forall m r. - (MonadUnliftIO m) => - RootBranchCache -> - -- | Perform an action with the cached value - ( -- restore masking state - (forall x. m x -> m x) -> - -- value retrieved from cache - Maybe (Branch Sqlite.Transaction) -> - m r - ) -> - -- | compute value to restore to the cache - (r -> Maybe (Branch Sqlite.Transaction)) -> - m r -withLock v f g = mask \restore -> do - mbranch <- atomically (takeLock v) - r <- f restore mbranch `onException` releaseLock mbranch - releaseLock (g r) - pure r - where - releaseLock :: Maybe (Branch Sqlite.Transaction) -> m () - releaseLock mbranch = - let !val = case mbranch of - Nothing -> Empty - Just x -> Full x - in atomically (writeRbc v val) - -takeLock :: RootBranchCache -> STM (Maybe (Branch Sqlite.Transaction)) -takeLock v = do - res <- readRootBranchCache v - writeRbc v ConcurrentModification - pure res diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 095924ed74..7c80b87274 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -38,7 +38,7 @@ module Unison.Server.Backend lsAtPath, lsBranch, mungeSyntaxText, - resolveCausalHashV2, + Codebase.expectCausalBranchByCausalHash, resolveRootBranchHashV2, namesAtPathFromRootBranchHash, termEntryDisplayName, @@ -100,7 +100,6 @@ import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (BranchHash, CausalHash (..)) import U.Codebase.Referent qualified as V2Referent -import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Operations qualified as Ops import Unison.ABT qualified as ABT import Unison.Builtin qualified as B @@ -699,14 +698,12 @@ expandShortCausalHash hash = do -- | Efficiently resolve a root hash and path to a shallow branch's causal. getShallowCausalAtPathFromRootHash :: - Maybe CausalHash -> + CausalHash -> Path -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalAtPathFromRootHash mayRootHash path = do - shallowRoot <- case mayRootHash of - Nothing -> Codebase.getShallowRootCausal - Just h -> Codebase.expectCausalBranchByCausalHash h - Codebase.getShallowCausalAtPath path (Just shallowRoot) +getShallowCausalAtPathFromRootHash rootHash path = do + shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash + Codebase.getShallowCausalAtPath path shallowRoot formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = @@ -986,16 +983,12 @@ namesAtPathFromRootBranchHash :: forall m n v a. (MonadIO m) => Codebase m v a -> - Maybe (V2Branch.CausalBranch n) -> + V2Branch.CausalBranch n -> Path -> Backend m (Names, PPED.PrettyPrintEnvDecl) -namesAtPathFromRootBranchHash codebase mbh path = do +namesAtPathFromRootBranchHash codebase cb path = do shouldUseNamesIndex <- asks useNamesIndex - (rootBranchHash, rootCausalHash) <- case mbh of - Just cb -> pure (V2Causal.valueHash cb, V2Causal.causalHash cb) - Nothing -> lift $ do - cb <- Codebase.runTransaction codebase Operations.expectRootCausal - pure (V2Causal.valueHash cb, V2Causal.causalHash cb) + let (rootBranchHash, rootCausalHash) = (V2Causal.valueHash cb, V2Causal.causalHash cb) haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash) hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength names <- @@ -1004,47 +997,34 @@ namesAtPathFromRootBranchHash codebase mbh path = do when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path else do - Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash (Just rootCausalHash) codebase + Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash rootCausalHash codebase let pped = PPED.makePPED (PPE.hqNamer hashLen names) (PPE.suffixifyByHash names) pure (names, pped) resolveCausalHash :: - (Monad m) => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m) -resolveCausalHash h codebase = case h of - Nothing -> lift (Codebase.getRootBranch codebase) - Just bhash -> do - mayBranch <- lift $ Codebase.getBranchForHash codebase bhash - whenNothing mayBranch (throwError $ NoBranchForHash bhash) - -resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -resolveCausalHashV2 h = case h of - Nothing -> Codebase.getShallowRootCausal - Just ch -> Codebase.expectCausalBranchByCausalHash ch + (Monad m) => CausalHash -> Codebase m v a -> Backend m (Branch m) +resolveCausalHash bhash codebase = do + mayBranch <- lift $ Codebase.getBranchForHash codebase bhash + whenNothing mayBranch (throwError $ NoBranchForHash bhash) resolveRootBranchHash :: - (MonadIO m) => Maybe ShortCausalHash -> Codebase m v a -> Backend m (Branch m) -resolveRootBranchHash mayRoot codebase = case mayRoot of - Nothing -> - lift (Codebase.getRootBranch codebase) - Just sch -> do - h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch) - resolveCausalHash (Just h) codebase + (MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m) +resolveRootBranchHash sch codebase = do + h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch) + resolveCausalHash h codebase resolveRootBranchHashV2 :: - Maybe ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -resolveRootBranchHashV2 mayRoot = case mayRoot of - Nothing -> lift Codebase.getShallowRootCausal - Just sch -> do - h <- expandShortCausalHash sch - lift (resolveCausalHashV2 (Just h)) - -normaliseRootCausalHash :: Maybe (Either ShortCausalHash CausalHash) -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -normaliseRootCausalHash mayCh = case mayCh of - Nothing -> lift $ resolveCausalHashV2 Nothing - Just (Left sch) -> do + ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) +resolveRootBranchHashV2 sch = do + h <- expandShortCausalHash sch + lift (Codebase.expectCausalBranchByCausalHash h) + +normaliseRootCausalHash :: Either ShortCausalHash CausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) +normaliseRootCausalHash = \case + (Left sch) -> do ch <- expandShortCausalHash sch - lift $ resolveCausalHashV2 (Just ch) - Just (Right ch) -> lift $ resolveCausalHashV2 (Just ch) + lift $ Codebase.expectCausalBranchByCausalHash ch + (Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch -- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?) -- From 2e754a876237d0a3fb5703d7c357a88e05b80538 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 10:08:34 -0700 Subject: [PATCH 19/76] Propagate lack of root branch combinators to local Codebase Server --- .../src/Unison/Server/CodebaseServer.hs | 29 +++++++++---------- .../src/Unison/Server/Local/Definitions.hs | 2 +- .../Local/Endpoints/DefinitionSummary.hs | 15 +++++----- .../Server/Local/Endpoints/FuzzyFind.hs | 11 +++---- .../Server/Local/Endpoints/GetDefinitions.hs | 11 +++---- .../Local/Endpoints/NamespaceDetails.hs | 19 ++++++------ .../Local/Endpoints/NamespaceListing.hs | 11 +++---- unison-share-api/src/Unison/Server/Types.hs | 4 +++ 8 files changed, 53 insertions(+), 49 deletions(-) diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 02834e9794..4a3025a71f 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -119,16 +119,13 @@ import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, List import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) 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.Server.Types (RequiredQueryParam, 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 @@ -567,12 +564,12 @@ serveLooseCode :: Rt.Runtime Symbol -> ServerT LooseCodeAPI (Backend IO) serveLooseCode codebase rt = - (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left <$> root) rel name) - :<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left <$> mayRoot) renderWidth) - :<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left <$> mayRoot) relativePath rawHqns renderWidth suff) - :<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left <$> mayRoot) relativePath limit renderWidth query) - :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth) - :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth) + (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left root) rel name) + :<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left mayRoot) renderWidth) + :<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left mayRoot) relativePath rawHqns renderWidth suff) + :<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left mayRoot) relativePath limit renderWidth query) + :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth) + :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth) serveProjectsCodebaseServerAPI :: Codebase IO Symbol Ann -> @@ -591,26 +588,26 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do projectAndBranchName = ProjectAndBranch projectName branchName namespaceListingEndpoint _rootParam rel name = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name + setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff + setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query + setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth + setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth + setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO (V2.CausalBranch Sqlite.Transaction) resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index b1f5b03d52..9c014a965f 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -81,7 +81,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings -- ppe which returns names fully qualified to the current perspective, not to the codebase root. let biases = maybeToList $ HQ.toName query hqLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength - (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase (Just shallowRoot) namesRoot + (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase shallowRoot namesRoot let pped = PPED.biasTo biases unbiasedPPED let nameSearch = makeNameSearch hqLength localNamesOnly (DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs index 3de04b5054..bd939684dd 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs @@ -48,6 +48,7 @@ import Unison.Server.Backend qualified as Backend import Unison.Server.Syntax (SyntaxText) import Unison.Server.Types ( APIGet, + RequiredQueryParam, TermTag (..), TypeTag, mayDefaultWidth, @@ -67,7 +68,7 @@ type TermSummaryAPI = -- It's propagated through to the response as-is. -- If missing, the short hash will be used instead. :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash + :> RequiredQueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TermSummary @@ -98,11 +99,11 @@ serveTermSummary :: Codebase IO Symbol Ann -> Referent -> Maybe Name -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Width -> Backend IO TermSummary -serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do +serveTermSummary codebase referent mayName root relativeTo mayWidth = do let shortHash = Referent.toShortHash referent let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName let relativeToPath = fromMaybe Path.empty relativeTo @@ -111,7 +112,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do (root, sig) <- Backend.hoistBackend (Codebase.runTransaction codebase) do - root <- Backend.normaliseRootCausalHash mayRoot + root <- Backend.normaliseRootCausalHash root sig <- lift (Backend.loadReferentType codebase referent) pure (root, sig) case sig of @@ -126,7 +127,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do namesPerspective <- Ops.namesPerspectiveForRootAndPath (V2Causal.valueHash root) (coerce . Path.toList $ fromMaybe Path.Empty relativeTo) PPESqlite.ppedForReferences namesPerspective deps False -> do - (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just root) relativeToPath + (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase root relativeToPath pure ppe let formattedTermSig = Backend.formatSuffixedType ppe width typeSig let summary = mkSummary termReference formattedTermSig @@ -150,7 +151,7 @@ type TypeSummaryAPI = -- It's propagated through to the response as-is. -- If missing, the short hash will be used instead. :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash + :> RequiredQueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TypeSummary @@ -181,7 +182,7 @@ serveTypeSummary :: Codebase IO Symbol Ann -> Reference -> Maybe Name -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Width -> Backend IO TypeSummary diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs index 5aaa434463..6044e36fca 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -38,6 +38,7 @@ import Unison.Server.Types HashQualifiedName, NamedTerm, NamedType, + RequiredQueryParam, UnisonName, mayDefaultWidth, ) @@ -47,7 +48,7 @@ import Unison.Util.Pretty (Width) type FuzzyFindAPI = "find" - :> QueryParam "rootBranch" SCH.ShortCausalHash + :> RequiredQueryParam "rootBranch" SCH.ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "limit" Int :> QueryParam "renderWidth" Width @@ -142,18 +143,18 @@ serveFuzzyFind :: forall m. (MonadIO m) => Codebase m Symbol Ann -> - Maybe (Either SCH.ShortCausalHash CausalHash) -> + Either SCH.ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Int -> Maybe Width -> Maybe String -> Backend.Backend m [(FZF.Alignment, FoundResult)] -serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do +serveFuzzyFind codebase root relativeTo limit typeWidth query = do let path = fromMaybe Path.empty relativeTo rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) do - Backend.normaliseRootCausalHash mayRoot - (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path + Backend.normaliseRootCausalHash root + (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal path let alignments :: ( [ ( FZF.Alignment, UnisonName, diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs index 49a67357ea..f4ce8353ef 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs @@ -35,6 +35,7 @@ import Unison.Server.Local.Definitions qualified as Local import Unison.Server.Types ( APIGet, DefinitionDisplayResults, + RequiredQueryParam, Suffixify (..), defaultWidth, ) @@ -44,7 +45,7 @@ import Unison.Util.Pretty (Width) type DefinitionsAPI = "getDefinition" - :> QueryParam "rootBranch" ShortCausalHash + :> RequiredQueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParams "names" (HQ.HashQualified Name) :> QueryParam "renderWidth" Width @@ -96,7 +97,7 @@ instance ToParam (QueryParam "namespace" Path.Path) where ) Normal -instance ToParam (QueryParam "rootBranch" ShortCausalHash) where +instance ToParam (RequiredQueryParam "rootBranch" ShortCausalHash) where toParam _ = DocQueryParam "rootBranch" @@ -120,15 +121,15 @@ instance ToSample DefinitionDisplayResults where serveDefinitions :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> [HQ.HashQualified Name] -> Maybe Width -> Maybe Suffixify -> Backend.Backend IO DefinitionDisplayResults -serveDefinitions rt codebase mayRoot relativePath hqns width suff = +serveDefinitions rt codebase root relativePath hqns width suff = do - rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ mayRoot + rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ root hqns & foldMapM ( Local.prettyDefinitionsForHQName diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs index bcb6ca5fa1..ebfbea5d6f 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -25,6 +25,7 @@ import Unison.Server.Doc qualified as Doc import Unison.Server.Types ( APIGet, NamespaceDetails (..), + RequiredQueryParam, v2CausalBranchToUnisonHash, ) import Unison.Symbol (Symbol) @@ -33,7 +34,7 @@ import Unison.Util.Pretty (Width) type NamespaceDetailsAPI = "namespaces" :> Capture "namespace" Path.Path - :> QueryParam "rootBranch" ShortCausalHash + :> RequiredQueryParam "rootBranch" ShortCausalHash :> QueryParam "renderWidth" Width :> APIGet NamespaceDetails @@ -47,23 +48,21 @@ namespaceDetails :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Path.Path -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Width -> Backend IO NamespaceDetails -namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do +namespaceDetails runtime codebase namespacePath root _mayWidth = do (rootCausal, namespaceCausal, shallowBranch) <- Backend.hoistBackend (Codebase.runTransaction codebase) do rootCausalHash <- - case mayRoot of - Nothing -> Backend.resolveRootBranchHashV2 Nothing - Just (Left sch) -> Backend.resolveRootBranchHashV2 (Just sch) - Just (Right ch) -> lift $ Backend.resolveCausalHashV2 (Just ch) - -- lift (Backend.resolveCausalHashV2 rootCausalHash) - namespaceCausal <- lift $ Codebase.getShallowCausalAtPath namespacePath (Just rootCausalHash) + case root of + (Left sch) -> Backend.resolveRootBranchHashV2 sch + (Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch + namespaceCausal <- lift $ Codebase.getShallowCausalAtPath namespacePath rootCausalHash shallowBranch <- lift $ V2Causal.value namespaceCausal pure (rootCausalHash, namespaceCausal, shallowBranch) namespaceDetails <- do - (_localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) namespacePath + (_localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal namespacePath let mayReadmeRef = Backend.findDocInBranch readmeNames shallowBranch renderedReadme <- for mayReadmeRef \readmeRef -> do -- Local server currently ignores eval errors. diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs index fe5e5ee06a..a194c7534c 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs @@ -36,6 +36,7 @@ import Unison.Server.Types HashQualifiedName, NamedTerm (..), NamedType (..), + RequiredQueryParam, UnisonHash, UnisonName, v2CausalBranchToUnisonHash, @@ -47,7 +48,7 @@ import Unison.Var (Var) type NamespaceListingAPI = "list" - :> QueryParam "rootBranch" ShortCausalHash + :> RequiredQueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "namespace" Path.Path :> APIGet NamespaceListing @@ -192,12 +193,12 @@ backendListEntryToNamespaceObject ppe typeWidth = \case serve :: Codebase IO Symbol Ann -> - Maybe (Either ShortCausalHash CausalHash) -> + Either ShortCausalHash CausalHash -> Maybe Path.Path -> Maybe Path.Path -> Backend.Backend IO NamespaceListing -serve codebase maySCH mayRelativeTo mayNamespaceName = do - rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) $ Backend.normaliseRootCausalHash maySCH +serve codebase root mayRelativeTo mayNamespaceName = do + rootCausal <- Backend.hoistBackend (Codebase.runTransaction codebase) $ Backend.normaliseRootCausalHash root -- Relative and Listing Path resolution -- @@ -217,7 +218,7 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do let path = relativeToPath <> namespacePath (listingCausal, listingBranch) <- (lift . Codebase.runTransaction codebase) do - listingCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal) + listingCausal <- Codebase.getShallowCausalAtPath path rootCausal listingBranch <- V2Causal.value listingCausal pure (listingCausal, listingBranch) -- TODO: Currently the ppe is just used to render the types returned from the namespace diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 48f9ace2bc..b4e32cda4e 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -20,6 +20,7 @@ import Data.OpenApi.Lens qualified as OpenApi import Data.Text qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Encoding qualified as Text +import Servant qualified import Servant.API ( Capture, FromHttpApiData (..), @@ -540,3 +541,6 @@ instance ToJSON TypeDiffResponse where "oldType" .= oldType, "newType" .= newType ] + +-- | Servant utility for a query param that's required, providing a useful error message if it's missing. +type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict] From 2773153f97934467427f5c2ffbaa02024df9192f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 13:06:49 -0700 Subject: [PATCH 20/76] Fix argparse for running 'main' within project Add projectPath parser --- .../src/Unison/Codebase/ProjectPath.hs | 28 +++++++++++++++++++ unison-cli/src/ArgParse.hs | 11 ++++++-- 2 files changed, 36 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index b2b831f9fb..441950d147 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -11,18 +11,25 @@ module Unison.Codebase.ProjectPath toIds, toNames, asProjectAndBranch_, + projectPathParser, + parseProjectPath, ) where import Control.Lens import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) +import Data.Text qualified as Text +import Text.Megaparsec qualified as Megaparsec +import Text.Megaparsec.Char qualified as Megaparsec import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.Path.Parse qualified as Path import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project qualified as Project data ProjectPathG proj branch = ProjectPath { project :: proj, @@ -81,3 +88,24 @@ projectAndBranch_ = lens go set where go (ProjectPath proj branch _) = ProjectAndBranch proj branch set (ProjectPath _ _ p) (ProjectAndBranch proj branch) = ProjectPath proj branch p + +type Parser = Megaparsec.Parsec Void Text + +projectPathParser :: Parser ProjectPathNames +projectPathParser = do + (projName, hasTrailingSlash) <- Project.projectNameParser + projBranchName <- Project.projectBranchNameParser (not hasTrailingSlash) + _ <- Megaparsec.char ':' + path' >>= \case + Path.AbsolutePath' p -> pure $ ProjectPath projName projBranchName p + Path.RelativePath' {} -> fail "Expected an absolute path" + where + path' :: Parser Path.Path' + path' = do + pathStr <- Megaparsec.takeRest + case Path.parsePath' (Text.unpack pathStr) of + Left err -> fail (Text.unpack err) + Right x -> pure x + +parseProjectPath :: Text -> Either Text ProjectPathNames +parseProjectPath txt = first (Text.pack . Megaparsec.errorBundlePretty) $ Megaparsec.parse projectPathParser "" txt diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 8d2251623a..ab24fd16c5 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -54,6 +54,8 @@ import Stats import System.Environment (lookupEnv) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathNames) +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.Types (ShouldWatchFiles (..)) import Unison.HashQualified (HashQualified) import Unison.LSP (LspFormattingConfig (..)) @@ -68,9 +70,8 @@ import Unison.Util.Pretty (Width (..)) -- | Valid ways to provide source code to the run command data RunSource = RunFromPipe (HashQualified Name) - | RunFromSymbol (ProjectAndBranch Project ProjectBranch, HashQualified Name) + | RunFromSymbol ProjectPathNames | RunFromFile FilePath (HashQualified Name) ->>>>>>> | RunCompiled FilePath deriving (Show, Eq) @@ -375,9 +376,13 @@ runHQParser :: Parser (HashQualified Name) runHQParser = argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL") +runProjectPathParser :: Parser PP.ProjectPathNames +runProjectPathParser = + argument (maybeReader (eitherToMaybe . PP.parseProjectPath . Text.pack)) (metavar "@myproject/mybranch:.path.in.project") + runSymbolParser :: Parser Command runSymbolParser = - Run . RunFromSymbol <$> runHQParser <*> runArgumentParser + Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser runFileParser :: Parser Command runFileParser = From 33458a8141c0bbb5adb81e6064efc721be402532 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 13:06:49 -0700 Subject: [PATCH 21/76] Fix LSP to work with projects --- .../U/Codebase/Sqlite/Project.hs | 2 +- parser-typechecker/src/Unison/Codebase.hs | 12 ++++++ unison-cli/src/Unison/LSP.hs | 25 ++++++------ unison-cli/src/Unison/LSP/FileAnalysis.hs | 5 ++- unison-cli/src/Unison/LSP/Formatting.hs | 5 ++- unison-cli/src/Unison/LSP/Types.hs | 8 ++-- unison-cli/src/Unison/LSP/UCMWorker.hs | 38 +++++++++---------- 7 files changed, 52 insertions(+), 43 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs index 2707e09c74..94e90b5c00 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs @@ -14,5 +14,5 @@ data Project = Project { projectId :: !ProjectId, name :: !ProjectName } - deriving stock (Generic, Show) + deriving stock (Generic, Show, Eq) deriving anyclass (ToRow, FromRow) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 1cc958b763..171367fc1c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -53,6 +53,8 @@ module Unison.Codebase getShallowProjectRootBranch, getShallowBranchAtProjectPath, getShallowProjectRootByNames, + getProjectBranchRoot, + expectProjectBranchRoot, -- * Root branch SqliteCodebase.Operations.namesAtPath, @@ -230,6 +232,16 @@ getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMayb causalHash <- lift $ Q.expectCausalHash causalHashId lift $ Operations.expectCausalBranchByCausalHash causalHash +getProjectBranchRoot :: (MonadIO m) => Codebase m v a -> ProjectBranch -> m (Maybe (Branch m)) +getProjectBranchRoot codebase ProjectBranch {causalHashId} = do + causalHash <- runTransaction codebase $ Q.expectCausalHash causalHashId + getBranchForHash codebase causalHash + +expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> ProjectBranch -> m (Branch m) +expectProjectBranchRoot codebase ProjectBranch {causalHashId} = do + causalHash <- runTransaction codebase $ Q.expectCausalHash causalHashId + expectBranchForHash codebase causalHash + -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m) expectBranchForHash codebase hash = diff --git a/unison-cli/src/Unison/LSP.hs b/unison-cli/src/Unison/LSP.hs index 867a08ed1e..4ef4b92750 100644 --- a/unison-cli/src/Unison/LSP.hs +++ b/unison-cli/src/Unison/LSP.hs @@ -27,9 +27,8 @@ import Language.LSP.VFS import Network.Simple.TCP qualified as TCP import System.Environment (lookupEnv) import System.IO (hPutStrLn) -import U.Codebase.HashTags import Unison.Codebase -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.LSP.CancelRequest (cancelRequestHandler) @@ -61,8 +60,8 @@ getLspPort :: IO String getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT" -- | Spawn an LSP server on the configured port. -spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM CausalHash -> STM (Path.Absolute) -> IO () -spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath = +spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM PP.ProjectPath -> IO () +spawnLsp lspFormattingConfig codebase runtime latestPath = ifEnabled . TCP.withSocketsDo $ do lspPort <- getLspPort UnliftIO.handleIO (handleFailure lspPort) $ do @@ -82,7 +81,7 @@ spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath = -- different un-saved state for the same file. initVFS $ \vfs -> do vfsVar <- newMVar vfs - void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath) + void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestPath) where handleFailure :: String -> IOException -> IO () handleFailure lspPort ioerr = @@ -113,16 +112,15 @@ serverDefinition :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + STM PP.ProjectPath -> ServerDefinition Config -serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath = +serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestPath = ServerDefinition { defaultConfig = defaultLSPConfig, configSection = "unison", parseConfig = Config.parseConfig, onConfigChange = Config.updateConfig, - doInitialize = lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath, + doInitialize = lspDoInitialize vfsVar codebase runtime scope latestPath, staticHandlers = lspStaticHandlers lspFormattingConfig, interpretHandler = lspInterpretHandler, options = lspOptions @@ -134,12 +132,11 @@ lspDoInitialize :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + STM PP.ProjectPath -> LanguageContextEnv Config -> Msg.TMessage 'Msg.Method_Initialize -> IO (Either Msg.ResponseError Env) -lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspContext _initMsg = do +lspDoInitialize vfsVar codebase runtime scope latestPath lspContext _initMsg = do checkedFilesVar <- newTVarIO mempty dirtyFilesVar <- newTVarIO mempty ppedCacheVar <- newEmptyTMVarIO @@ -152,13 +149,13 @@ lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspConte Env { ppedCache = atomically $ readTMVar ppedCacheVar, currentNamesCache = atomically $ readTMVar currentNamesCacheVar, - currentPathCache = atomically $ readTMVar currentPathCacheVar, + currentProjectPathCache = atomically $ readTMVar currentPathCacheVar, nameSearchCache = atomically $ readTMVar nameSearchCacheVar, .. } let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM Ki.fork scope (lspToIO Analysis.fileAnalysisWorker) - Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestRootHash latestPath) + Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestPath) pure $ Right $ env -- | LSP request handlers that don't register/unregister dynamically diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index f5f29b5e27..85ad0ba663 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -27,6 +27,7 @@ import Unison.ABT qualified as ABT import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) import Unison.Cli.UniqueTypeGuidLookup qualified as Cli import Unison.Codebase qualified as Codebase +import Unison.Codebase.ProjectPath qualified as PP import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug import Unison.FileParsers (ShouldUseTndr (..)) @@ -77,7 +78,7 @@ import Witherable -- | Lex, parse, and typecheck a file. checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis) checkFile doc = runMaybeT do - currentPath <- lift getCurrentPath + pp <- lift getCurrentProjectPath let fileUri = doc ^. uri (fileVersion, contents) <- VFS.getFileContents fileUri parseNames <- lift getCurrentNames @@ -90,7 +91,7 @@ checkFile doc = runMaybeT do let parsingEnv = Parser.ParsingEnv { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, + uniqueTypeGuid = Cli.loadUniqueTypeGuid (pp ^. PP.absPath_), names = parseNames } (notes, parsedFile, typecheckedFile) <- do diff --git a/unison-cli/src/Unison/LSP/Formatting.hs b/unison-cli/src/Unison/LSP/Formatting.hs index 48e46d8028..ebba4b1a81 100644 --- a/unison-cli/src/Unison/LSP/Formatting.hs +++ b/unison-cli/src/Unison/LSP/Formatting.hs @@ -8,6 +8,7 @@ import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Formatting +import Unison.Codebase.ProjectPath qualified as PP import Unison.LSP.Conversions (lspToURange, uToLspRange) import Unison.LSP.FileAnalysis (getFileAnalysis) import Unison.LSP.FileAnalysis qualified as FileAnalysis @@ -30,10 +31,10 @@ formatDefs :: Uri -> Maybe (Set Range {- the ranges to format, if Nothing then f formatDefs fileUri mayRangesToFormat = fromMaybe [] <$> runMaybeT do FileAnalysis {parsedFile = mayParsedFile, typecheckedFile = mayTypecheckedFile} <- getFileAnalysis fileUri - currentPath <- lift getCurrentPath + pp <- lift getCurrentProjectPath Config {formattingWidth} <- lift getConfig MaybeT $ - Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth currentPath mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat) + Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth (pp ^. PP.absPath_) mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat) <&> (fmap . fmap) uTextReplacementToLSP where uTextReplacementToLSP :: Formatting.TextReplacement -> TextEdit diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index c5fe0e9a95..b368e915ef 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -24,7 +24,7 @@ import Language.LSP.Server import Language.LSP.Server qualified as LSP import Language.LSP.VFS import Unison.Codebase -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) import Unison.Debug qualified as Debug import Unison.LSP.Orphans () @@ -72,7 +72,7 @@ data Env = Env currentNamesCache :: IO Names, ppedCache :: IO PrettyPrintEnvDecl, nameSearchCache :: IO (NameSearch Sqlite.Transaction), - currentPathCache :: IO Path.Absolute, + currentProjectPathCache :: IO PP.ProjectPath, vfsVar :: MVar VFS, runtime :: Runtime Symbol, -- The information we have for each file. @@ -129,8 +129,8 @@ data FileAnalysis = FileAnalysis } deriving stock (Show) -getCurrentPath :: Lsp Path.Absolute -getCurrentPath = asks currentPathCache >>= liftIO +getCurrentProjectPath :: Lsp PP.ProjectPath +getCurrentProjectPath = asks currentProjectPathCache >>= liftIO getCodebaseCompletions :: Lsp CompletionTree getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar diff --git a/unison-cli/src/Unison/LSP/UCMWorker.hs b/unison-cli/src/Unison/LSP/UCMWorker.hs index 2f28955021..70212d29ad 100644 --- a/unison-cli/src/Unison/LSP/UCMWorker.hs +++ b/unison-cli/src/Unison/LSP/UCMWorker.hs @@ -1,16 +1,16 @@ module Unison.LSP.UCMWorker where import Control.Monad.Reader -import U.Codebase.HashTags 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.ProjectPath (ProjectPath) import Unison.Debug qualified as Debug import Unison.LSP.Completion import Unison.LSP.Types import Unison.LSP.VFS qualified as VFS import Unison.Names (Names) +import Unison.Prelude import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl import Unison.PrettyPrintEnvDecl.Names qualified as PPED @@ -24,21 +24,21 @@ ucmWorker :: TMVar PrettyPrintEnvDecl -> TMVar Names -> TMVar (NameSearch Sqlite.Transaction) -> - TMVar Path.Absolute -> - STM CausalHash -> - STM Path.Absolute -> + TMVar ProjectPath -> + STM ProjectPath -> Lsp () -ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do +ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestProjectPath = do Env {codebase, completionsVar} <- ask - let loop :: (CausalHash, Path.Absolute) -> Lsp a - loop (currentRoot, currentPath) = do - Debug.debugM Debug.LSP "LSP path: " currentPath - currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath) + let loop :: ProjectPath -> Lsp a + loop currentProjectPath = do + currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch) + Debug.debugM Debug.LSP "LSP path: " currentProjectPath + let currentBranch0 = Branch.head currentBranch let currentNames = Branch.toNames currentBranch0 hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames) atomically $ do - writeTMVar currentPathVar currentPath + writeTMVar currentPathVar currentProjectPath writeTMVar currentNamesVar currentNames writeTMVar ppedVar pped writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames) @@ -48,17 +48,15 @@ ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoo writeTMVar completionsVar (namesToCompletionTree currentNames) Debug.debugLogM Debug.LSP "LSP Initialized" latest <- atomically $ do - latestRoot <- getLatestRoot - latestPath <- getLatestPath - guard $ (currentRoot /= latestRoot || currentPath /= latestPath) - pure (latestRoot, latestPath) + latestPath <- getLatestProjectPath + guard $ (currentProjectPath /= latestPath) + pure latestPath Debug.debugLogM Debug.LSP "LSP Change detected" loop latest - (rootBranch, currentPath) <- atomically $ do - rootBranch <- getLatestRoot - currentPath <- getLatestPath - pure (rootBranch, currentPath) - loop (rootBranch, currentPath) + currentProjectPath <- atomically $ do + currentProjectPath <- getLatestProjectPath + pure currentProjectPath + loop currentProjectPath where -- This is added in stm-2.5.1, remove this if we upgrade. writeTMVar :: TMVar a -> a -> STM () From 4e2ccf23cc3dd366acb5d153a0e50304274bab63 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 14:12:46 -0700 Subject: [PATCH 22/76] Fix up some more root branch gets --- parser-typechecker/src/Unison/Codebase.hs | 10 ++++++++++ unison-cli/src/Unison/Cli/MonadUtils.hs | 4 ++-- unison-cli/src/Unison/CommandLine.hs | 5 ++--- unison-cli/src/Unison/CommandLine/InputPattern.hs | 3 +-- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 1 - 5 files changed, 15 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 171367fc1c..fbe1d51d4a 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -55,6 +55,7 @@ module Unison.Codebase getShallowProjectRootByNames, getProjectBranchRoot, expectProjectBranchRoot, + getBranchAtProjectPath, -- * Root branch SqliteCodebase.Operations.namesAtPath, @@ -242,6 +243,15 @@ expectProjectBranchRoot codebase ProjectBranch {causalHashId} = do causalHash <- runTransaction codebase $ Q.expectCausalHash causalHashId expectBranchForHash codebase causalHash +getBranchAtProjectPath :: + (MonadIO m) => + Codebase m v a -> + PP.ProjectPath -> + m (Maybe (Branch m)) +getBranchAtProjectPath codebase pp = runMaybeT do + rootBranch <- MaybeT $ getProjectBranchRoot codebase (pp ^. #branch) + hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch + -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m) expectBranchForHash codebase hash = diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 58dd5410e3..0a07833e39 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -280,9 +280,9 @@ modifyProjectRoot f = do -- | Get the current branch. getCurrentBranch :: Cli (Branch IO) getCurrentBranch = do - path <- getCurrentPath Cli.Env {codebase} <- ask - liftIO $ Codebase.getBranchAtPath codebase path + pp <- getCurrentProjectPath + liftIO $ Codebase.getBranchAtProjectPath codebase pp -- | Get the current branch0. getCurrentBranch0 :: Cli (Branch0 IO) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index fb6cc05453..4c100ab293 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -46,9 +46,8 @@ import Unison.Codebase (Codebase) import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) -import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Editor.Output (NumberedArgs) -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers import Unison.CommandLine.FuzzySelect qualified as Fuzzy @@ -133,7 +132,7 @@ parseInput :: -- 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 (InputPattern.Arguments, Input))) - parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do +parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) getCurrentBranch0 = do projRoot <- currentProjectRoot diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index 001d4186f9..01f7ddebc4 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -27,9 +27,8 @@ 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.ProjectPath qualified as PP import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) -import Unison.Codebase.Path as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude import Unison.Util.ColorText qualified as CT diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9c20725120..9748a14bcd 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -207,7 +207,6 @@ import Unison.Project 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.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Referent qualified as Referent import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend From 138c6e96cef54451d93bf48f8a4e6c7c7da5b7bb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 14:18:30 -0700 Subject: [PATCH 23/76] Fix up input patterns for project branch args --- .../src/Unison/CommandLine/InputPatterns.hs | 59 +++++++++---------- 1 file changed, 27 insertions(+), 32 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9748a14bcd..d8cd31ad9c 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -137,7 +137,6 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens (preview, review) import Control.Lens.Cons qualified as Cons import Data.List (intercalate) import Data.List.Extra qualified as List @@ -192,8 +191,8 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment -import Unison.Prelude hiding (view) import Unison.Parser.Ann (Ann) +import Unison.Prelude hiding (view) import Unison.Project ( ProjectAndBranch (..), ProjectAndBranchNames (..), @@ -204,9 +203,6 @@ import Unison.Project Semver, branchWithOptionalProjectParser, ) -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 @@ -351,15 +347,6 @@ handleProjectArg = 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 = @@ -394,7 +381,6 @@ handleHashQualifiedNameArg = 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 @@ -510,13 +496,15 @@ handleBranchId2Arg = 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.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name SA.NameWithBranchPrefix (Right prefix) name -> - pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + pure . pure . UnqualifiedPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + case mproject of + Just proj -> pure . pure $ QualifiedBranchPath proj branch Path.absoluteEmpty + Nothing -> pure . pure $ BranchPathInCurrentProject branch Path.absoluteEmpty otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath @@ -524,13 +512,15 @@ 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.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . UnqualifiedPath $ Path.fromName' name SA.NameWithBranchPrefix (Right prefix) name -> - pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + pure . UnqualifiedPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + case mproject of + Just proj -> pure $ QualifiedBranchPath proj branch Path.absoluteEmpty + Nothing -> pure $ BranchPathInCurrentProject branch Path.absoluteEmpty otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit' @@ -1484,7 +1474,7 @@ deleteNamespaceForce = deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case - [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> handleSplitArg p _ -> Left helpText renameBranch :: InputPattern @@ -1975,10 +1965,15 @@ mergeOldSquashInputPattern = <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", parse = \case + [src] -> + Input.MergeLocalBranchI + <$> handleMaybeProjectBranchArg src + <*> pure Nothing + <*> pure Branch.SquashMerge [src, dest] -> Input.MergeLocalBranchI <$> handleMaybeProjectBranchArg src - <*> handleMaybeProjectBranchArg dest + <*> (Just <$> handleMaybeProjectBranchArg dest) <*> pure Branch.SquashMerge _ -> Left $ I.help mergeOldSquashInputPattern } @@ -2018,12 +2013,12 @@ mergeOldInputPattern = [src] -> Input.MergeLocalBranchI <$> handleMaybeProjectBranchArg src - <*> pure (This Path.relativeEmpty') + <*> pure Nothing <*> pure Branch.RegularMerge [src, dest] -> Input.MergeLocalBranchI <$> handleMaybeProjectBranchArg src - <*> handleMaybeProjectBranchArg dest + <*> (Just <$> handleMaybeProjectBranchArg dest) <*> pure Branch.RegularMerge _ -> Left $ I.help mergeOldInputPattern ) @@ -2106,9 +2101,9 @@ mergeOldPreviewInputPattern = ] ) ( \case - [src] -> Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> pure (This Path.relativeEmpty') + [src] -> Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> pure Nothing [src, dest] -> - Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> handleLooseCodeOrProjectArg dest + Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> (Just <$> handleMaybeProjectBranchArg dest) _ -> Left $ I.help mergeOldPreviewInputPattern ) where @@ -3005,7 +3000,7 @@ branchInputPattern = ], parse = \case [source0, name] -> - Input.BranchI . Input.BranchSourceI'LooseCodeOrProject + Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch <$> handleMaybeProjectBranchArg source0 <*> handleMaybeProjectBranchArg name [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name From 3267a3e54cc565ae7b8d79ec336ecaf8f511f4c7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 16:30:49 -0700 Subject: [PATCH 24/76] Fix up Merge2 --- .../src/Unison/Codebase/ProjectPath.hs | 4 ++ unison-cli/src/Unison/Cli/ProjectUtils.hs | 14 +++--- .../Codebase/Editor/HandleInput/Branch.hs | 48 +++++++++++++++---- .../Codebase/Editor/HandleInput/Merge2.hs | 23 ++++----- 4 files changed, 57 insertions(+), 32 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 441950d147..5c249cea40 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -4,6 +4,7 @@ module Unison.Codebase.ProjectPath ProjectPathNames, ProjectPath, fromProjectAndBranch, + projectBranchRoot, absPath_, path_, projectAndBranch_, @@ -44,6 +45,9 @@ type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName type ProjectPath = ProjectPathG Project ProjectBranch +projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath +projectBranchRoot (ProjectAndBranch proj branch) = ProjectPath proj branch Path.absoluteEmpty + fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 2dccc83bb3..e4017e307c 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -12,6 +12,7 @@ module Unison.Cli.ProjectUtils expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, + getProjectBranchCausalHash, -- * Loading remote project info expectRemoteProjectById, @@ -43,20 +44,19 @@ 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 (Project) import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q 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.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 import Unison.Codebase.Path qualified as Path @@ -201,11 +201,9 @@ resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) pure projectAndBranch -- | 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 +getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash +getProjectBranchCausalHash ProjectBranch {causalHashId} = do + Q.expectCausalHash causalHashId ------------------------------------------------------------------------------------------------------------------------ -- Remote project utils diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 1747ba2628..4da27dca65 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,23 +1,27 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch ( handleBranch, - doCreateBranch, + createBranchFromParent, + createBranchFromNamespace, ) where -import Data.These (These (..)) +import Control.Monad.Reader import Data.UUID.V4 qualified as UUID import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q 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 qualified as Codebase +import Unison.Codebase.Branch (Branch) +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.ProjectPath qualified as PP @@ -40,10 +44,10 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB ProjectBranchNameKind'NothingSpecial -> pure () currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name) + let projectName = (fromMaybe currentProjectName mayProjectName) destProject <- do Cli.runTransactionWithRollback \rollback -> do - let projectName = (fromMaybe currentProjectName mayProjectName) Queries.loadProjectByName projectName & onNothingM do -- We can't make the *first* branch of a project with `branch`; the project has to already exist. rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName)) @@ -57,7 +61,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB pp <- Cli.getCurrentProjectPath Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- doCreateBranch (view #branch <$> maySrcProjectAndBranch) destProject newBranchName + _ <- createBranchFromParent (view #branch <$> maySrcProjectAndBranch) destProject newBranchName Cli.respond $ Output.CreatedProjectBranch @@ -68,9 +72,9 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch Nothing -> Output.CreatedProjectBranchFrom'Nothingness ) - projectAndBranchNames + (projectAndBranchNames & #project .~ projectName) --- | @doCreateBranch createFrom project branch description@: +-- | @createBranchFromParent createFrom project branch description@: -- -- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@). -- 3. Switches to the new branch. @@ -79,17 +83,16 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB -- @release.draft@ command, which essentially just creates a branch, but with some different output for the user. -- -- Returns the branch id of the newly-created branch. -doCreateBranch :: +createBranchFromParent :: -- If no parent branch is provided, make an empty branch. Maybe Sqlite.ProjectBranch -> Sqlite.Project -> ProjectBranchName -> Cli ProjectBranchId -doCreateBranch mayParentBranch project getNewBranchName = do +createBranchFromParent mayParentBranch project newBranchName = do let projectId = project ^. #projectId newBranchId <- Cli.runTransactionWithRollback \rollback -> do - newBranchName <- getNewBranchName Queries.projectBranchExistsByName projectId newBranchName >>= \case True -> rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch (project ^. #name) newBranchName)) False -> do @@ -112,3 +115,30 @@ doCreateBranch mayParentBranch project getNewBranchName = do Cli.switchProject (ProjectAndBranch projectId newBranchId) pure newBranchId + +createBranchFromNamespace :: Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> Branch IO -> Cli ProjectBranchId +createBranchFromNamespace project getBranchName branch = do + let projectId = project ^. #projectId + Cli.Env {codebase} <- ask + let causalHash = Branch.headHash branch + liftIO $ Codebase.putBranch codebase branch + newBranchId <- + Cli.runTransactionWithRollback \rollback -> do + branchName <- getBranchName + Queries.projectBranchExistsByName projectId branchName >>= \case + True -> rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch (project ^. #name) branchName)) + False -> do + newProjectBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash causalHash + Queries.insertProjectBranch + Sqlite.ProjectBranch + { projectId, + branchId = newProjectBranchId, + name = branchName, + parentBranchId = Nothing, + causalHashId = newBranchCausalHashId + } + pure newProjectBranchId + + Cli.switchProject (ProjectAndBranch projectId newBranchId) + pure newBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 352bb0d1f9..3c1af1358e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -42,6 +42,7 @@ 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 Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin.Decls qualified as Builtin.Decls import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..)) @@ -66,6 +67,7 @@ import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.Codebase.SqliteCodebase.Operations qualified as Operations @@ -139,14 +141,12 @@ import Unison.Util.SyntaxText (SyntaxText') import Unison.Var (Var) import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) -import qualified U.Codebase.Sqlite.Queries as Q handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do -- Assert that Alice (us) is on a project branch, and grab the causal hash. ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath let aliceProjectAndBranch = ProjectAndBranch aliceProject aliceProjectBranch - aliceCausalHash <- Cli.runTransaction (projectBranchToCausalHash aliceProjectBranch) -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch -- name, and causal hash. @@ -166,10 +166,6 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do { alice = aliceProjectAndBranch, bob = bobProjectAndBranch } - where - projectBranchToCausalHash :: ProjectBranch -> Transaction CausalHash - projectBranchToCausalHash branch = do - Q.expectCausalHash (branch ^. causalHashId) data MergeInfo = MergeInfo { alice :: !AliceMergeInfo, @@ -200,7 +196,6 @@ doMerge info = do 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 @@ -217,7 +212,7 @@ doMerge info = do -- 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.updateAt info.description (PP.projectBranchRoot info.alice.projectAndBranch) (\_aliceBranch -> bobBranch) Cli.respond (Output.MergeSuccessFastForward mergeSourceAndTarget) done () @@ -416,12 +411,10 @@ doMerge info = do Nothing -> do Cli.Env {writeSource} <- ask _temporaryBranchId <- - HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch parents.alice parents.bob) - Nothing + HandleInput.Branch.createBranchFromNamespace info.alice.projectAndBranch.project (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) - info.description + (Branch.mergeNode stageOneBranch parents.alice parents.bob) scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" @@ -434,7 +427,7 @@ doMerge info = do _ <- Cli.updateAt info.description - alicePath + info.alice.projectAndBranch (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) Cli.respond (Output.MergeSuccess mergeSourceAndTarget) @@ -442,8 +435,8 @@ doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () doMergeLocalBranch branches = do (aliceCausalHash, bobCausalHash, lcaCausalHash) <- Cli.runTransaction do - aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice) - bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob) + aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch) + bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch) -- Using Alice and Bob's causal hashes, find the LCA (if it exists) lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash pure (aliceCausalHash, bobCausalHash, lcaCausalHash) From 9bf5d6f105f7357267ba785c5af491bff89e6018 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 16:54:58 -0700 Subject: [PATCH 25/76] Fix up MonadUtils --- unison-cli/src/Unison/Cli/MonadUtils.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 0a07833e39..bb27225e22 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -282,7 +282,7 @@ getCurrentBranch :: Cli (Branch IO) getCurrentBranch = do Cli.Env {codebase} <- ask pp <- getCurrentProjectPath - liftIO $ Codebase.getBranchAtProjectPath codebase pp + fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp) -- | Get the current branch0. getCurrentBranch0 :: Cli (Branch0 IO) @@ -449,7 +449,7 @@ stepManyAtMNoSync actions = do syncRoot :: Text -> Cli () syncRoot description = do rootBranch <- getProjectRoot - updateCurrentProjectRoot rootBranch description + updateCurrentProjectBranchRoot rootBranch description -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise @@ -461,7 +461,7 @@ updateAtM :: updateAtM reason pp f = do b <- getBranchFromProjectPath (pp & PP.absPath_ .~ Path.absoluteEmpty) b' <- Branch.modifyAtM (pp ^. PP.path_) f b - updateCurrentProjectRoot b' reason + updateCurrentProjectBranchRoot b' reason pure $ b /= b' -- | Update a branch at the given path, returning `True` if @@ -488,10 +488,19 @@ updateAndStepAt reason updates steps = do ProjectPath _ projBranch _ <- getCurrentProjectPath updateProjectBranchRoot projBranch root reason +updateCurrentProjectBranchRoot :: Branch IO -> Text -> Cli () +updateCurrentProjectBranchRoot new reason = do + pp <- getCurrentProjectPath + updateProjectBranchRoot (pp ^. #branch) new reason + updateProjectBranchRoot :: ProjectBranch -> Branch IO -> Text -> Cli () -updateProjectBranchRoot projectBranch new reason = +updateProjectBranchRoot projectBranch new _reason = do + Cli.Env {codebase} <- ask Cli.time "updateCurrentProjectRoot" do - runTransaction $ Q.setProjectBranchHead (projectBranch ^. #branchId) (Branch.headHash new) + liftIO $ Codebase.putBranch codebase new + Cli.runTransaction $ do + causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) + Q.setProjectBranchHead (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId setCurrentProjectRoot new ------------------------------------------------------------------------------------------------------------------------ From c3a2dfb0013fc5788c1a37f340ec2f031ae17934 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Jun 2024 09:41:57 -0700 Subject: [PATCH 26/76] Don't include causalHashId in ProjectBranch --- .../U/Codebase/Sqlite/ProjectBranch.hs | 5 +-- .../U/Codebase/Sqlite/Queries.hs | 14 ++++++- parser-typechecker/src/Unison/Codebase.hs | 39 +++++++++++-------- unison-cli/src/Unison/Cli/ProjectUtils.hs | 3 +- 4 files changed, 38 insertions(+), 23 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs index 986de3fbb6..05b63e7e23 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs @@ -3,7 +3,7 @@ module U.Codebase.Sqlite.ProjectBranch ) where -import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import Unison.Core.Orphans.Sqlite () import Unison.Core.Project (ProjectBranchName) import Unison.Prelude @@ -14,8 +14,7 @@ data ProjectBranch = ProjectBranch { projectId :: !ProjectId, branchId :: !ProjectBranchId, name :: !ProjectBranchName, - parentBranchId :: !(Maybe ProjectBranchId), - causalHashId :: !CausalHashId + parentBranchId :: !(Maybe ProjectBranchId) } deriving stock (Eq, Generic, Show) deriving anyclass (ToRow, FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a0a49d151b..a896cbcea8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -136,6 +136,7 @@ module U.Codebase.Sqlite.Queries renameProjectBranch, deleteProjectBranch, setProjectBranchHead, + expectProjectBranchHead, setMostRecentBranch, loadMostRecentBranch, @@ -3686,8 +3687,8 @@ loadProjectAndBranchNames projectId branchId = |] -- | Insert a project branch. -insertProjectBranch :: ProjectBranch -> Transaction () -insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId causalHashId) = do +insertProjectBranch :: CausalHashId -> ProjectBranch -> Transaction () +insertProjectBranch causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do execute [sql| INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) @@ -3781,6 +3782,15 @@ setProjectBranchHead projectId branchId causalHashId = WHERE project_id = :projectId AND branch_id = :branchId |] +expectProjectBranchHead :: ProjectId -> ProjectBranchId -> Transaction CausalHashId +expectProjectBranchHead projectId branchId = + queryOneCol + [sql| + SELECT causal_hash_id + FROM project_branch + WHERE project_id = :projectId AND branch_id = :branchId + |] + data LoadRemoteBranchFlag = IncludeSelfRemote | ExcludeSelfRemote diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index fbe1d51d4a..91d6275d76 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -50,10 +50,10 @@ module Unison.Codebase getShallowCausalAtPath, Operations.expectCausalBranchByCausalHash, getShallowCausalAtPathFromRootHash, - getShallowProjectRootBranch, + getShallowProjectBranchRoot, + expectShallowProjectBranchRoot, getShallowBranchAtProjectPath, getShallowProjectRootByNames, - getProjectBranchRoot, expectProjectBranchRoot, getBranchAtProjectPath, @@ -213,43 +213,48 @@ getShallowBranchAtPath path branch = do childBranch <- V2Causal.value childCausal getShallowBranchAtPath p childBranch -getShallowProjectRootBranch :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowProjectRootBranch ProjectBranch {causalHashId} = do - causalHash <- Q.expectCausalHash causalHashId - Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value - -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowBranchAtProjectPath :: PP.ProjectPath -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) getShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do - projectRootBranch <- getShallowProjectRootBranch projectBranch + projectRootBranch <- fromMaybe V2Branch.empty <$> getShallowProjectBranchRoot projectBranch getShallowBranchAtPath (Path.unabsolute path) projectRootBranch getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do - ProjectBranch {causalHashId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName + ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName + causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId causalHash <- lift $ Q.expectCausalHash causalHashId lift $ Operations.expectCausalBranchByCausalHash causalHash -getProjectBranchRoot :: (MonadIO m) => Codebase m v a -> ProjectBranch -> m (Maybe (Branch m)) -getProjectBranchRoot codebase ProjectBranch {causalHashId} = do - causalHash <- runTransaction codebase $ Q.expectCausalHash causalHashId - getBranchForHash codebase causalHash - expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> ProjectBranch -> m (Branch m) -expectProjectBranchRoot codebase ProjectBranch {causalHashId} = do - causalHash <- runTransaction codebase $ Q.expectCausalHash causalHashId +expectProjectBranchRoot codebase ProjectBranch {projectId, branchId} = do + causalHash <- runTransaction codebase $ do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId expectBranchForHash codebase causalHash +expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + causalHash <- Q.expectCausalHash causalHashId + Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value + +getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + causalHash <- Q.expectCausalHash causalHashId + Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value + getBranchAtProjectPath :: (MonadIO m) => Codebase m v a -> PP.ProjectPath -> m (Maybe (Branch m)) getBranchAtProjectPath codebase pp = runMaybeT do - rootBranch <- MaybeT $ getProjectBranchRoot codebase (pp ^. #branch) + rootBranch <- lift $ expectProjectBranchRoot codebase (pp ^. #branch) hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index e4017e307c..df9695273c 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -202,7 +202,8 @@ resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) -- | Get the causal hash of a project branch. getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash -getProjectBranchCausalHash ProjectBranch {causalHashId} = do +getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId Q.expectCausalHash causalHashId ------------------------------------------------------------------------------------------------------------------------ From ecba9369dbec3b9e9c559c8a5cf8f4c6c29eb711 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Jun 2024 17:02:05 -0700 Subject: [PATCH 27/76] Fix up project branch deletes --- unison-cli/src/Unison/Cli/MonadUtils.hs | 28 +++++++++++-------- .../Editor/HandleInput/DeleteBranch.hs | 22 +++++---------- .../Codebase/Editor/HandleInput/Merge2.hs | 4 +-- 3 files changed, 26 insertions(+), 28 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index bb27225e22..478df575b3 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -299,6 +299,11 @@ getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO) getBranch0FromProjectPath pp = Branch.head <$> getBranchFromProjectPath pp +getRootBranchForProjectBranch :: ProjectBranch -> Cli (Branch IO) +getRootBranchForProjectBranch ProjectBranch {projectId, branchId} = do + Cli.runTransaction do + _ + -- | Get the maybe-branch at an absolute path. getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) getMaybeBranchFromProjectPath pp = do @@ -481,22 +486,23 @@ updateAndStepAt :: g (Path, Branch0 IO -> Branch0 IO) -> Cli () updateAndStepAt reason updates steps = do - root <- - (Branch.stepManyAt steps) - . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) - <$> getProjectRoot + let f b = + b + & (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) + & (Branch.stepManyAt steps) ProjectPath _ projBranch _ <- getCurrentProjectPath - updateProjectBranchRoot projBranch root reason + updateProjectBranchRoot reason projBranch f -updateCurrentProjectBranchRoot :: Branch IO -> Text -> Cli () -updateCurrentProjectBranchRoot new reason = do +updateCurrentProjectBranchRoot :: Text -> (Branch IO -> Branch IO) -> Cli () +updateCurrentProjectBranchRoot reason f = do pp <- getCurrentProjectPath - updateProjectBranchRoot (pp ^. #branch) new reason + updateProjectBranchRoot reason (pp ^. #branch) f -updateProjectBranchRoot :: ProjectBranch -> Branch IO -> Text -> Cli () -updateProjectBranchRoot projectBranch new _reason = do +updateProjectBranchRoot :: Text -> ProjectBranch -> (Branch IO -> Branch IO) -> Cli () +updateProjectBranchRoot reason projectBranch f = do + error "implement project-branch reflog" reason Cli.Env {codebase} <- ask - Cli.time "updateCurrentProjectRoot" do + Cli.time "updateProjectBranchRoot" do liftIO $ Codebase.putBranch codebase new Cli.runTransaction $ do causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index 06656cece5..2c91256bb7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -6,8 +6,6 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch where import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) -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 @@ -17,9 +15,6 @@ import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Editor.HandleInput.ProjectCreate import Unison.Codebase.ProjectPath (ProjectPathG (..)) -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) import Unison.Sqlite qualified as Sqlite @@ -33,7 +28,7 @@ import Witch (unsafeFrom) handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleDeleteBranch projectAndBranchNamesToDelete = do ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath - projectAndBranchToDelete <- ProjectUtils.resolveProjectBranch currentProject (projectAndBranchNames & #branch %~ Just) + projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranch currentProject (projectAndBranchNamesToDelete & #branch %~ Just) doDeleteProjectBranch projectAndBranchToDelete -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order: @@ -46,10 +41,11 @@ handleDeleteBranch projectAndBranchNamesToDelete = do mayNextLocation <- Cli.runTransaction . runMaybeT $ asum - [ parentBranch projectId (branchToDelete ^. #parentBranchId), - findMainBranchInProject projectId, - findAnyBranchInProject projectId, - findAnyBranchInCodebase + [ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId), + findMainBranchInProject (currentProject ^. #projectId), + findAnyBranchInProject (currentProject ^. #projectId), + findAnyBranchInCodebase, + createDummyProject ] nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing Cli.switchProject nextLoc @@ -71,14 +67,10 @@ handleDeleteBranch projectAndBranchNamesToDelete = do findAnyBranchInCodebase = do (_, pbIds) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchNamePairs pure pbIds + createDummyProject = error "TODO: create new branch or project if we delete the last branch you're on." -- | 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/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 3c1af1358e..82a82ee74e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -425,10 +425,10 @@ doMerge info = do Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch _ <- - Cli.updateAt - info.description + Cli.updateProjectBranchRoot info.alice.projectAndBranch (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + info.description Cli.respond (Output.MergeSuccess mergeSourceAndTarget) doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () From f42d57f3a0139e813a3229b8a4f0815fc6c67d30 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Jun 2024 10:00:52 -0700 Subject: [PATCH 28/76] Fix up MonadUtils again --- unison-cli/src/Unison/Cli/MonadUtils.hs | 46 ++++++++++++------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 478df575b3..5fa5e4c601 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -25,10 +25,11 @@ module Unison.Cli.MonadUtils -- ** Getting/setting branches setCurrentProjectRoot, modifyProjectRoot, - getProjectRoot, - getProjectRoot0, + getCurrentProjectRoot, + getCurrentProjectRoot0, getCurrentBranch, getCurrentBranch0, + getProjectBranchRoot, getBranchFromProjectPath, getBranch0FromProjectPath, getMaybeBranchFromProjectPath, @@ -249,14 +250,14 @@ resolveShortCausalHashToCausalHash rollback shortHash = do -- Getting/Setting branches -- | Get the root branch. -getProjectRoot :: Cli (Branch IO) -getProjectRoot = do +getCurrentProjectRoot :: Cli (Branch IO) +getCurrentProjectRoot = do use #currentProjectRoot >>= atomically . readTMVar -- | Get the root branch0. -getProjectRoot0 :: Cli (Branch0 IO) -getProjectRoot0 = - Branch.head <$> getProjectRoot +getCurrentProjectRoot0 :: Cli (Branch0 IO) +getCurrentProjectRoot0 = + Branch.head <$> getCurrentProjectRoot -- | Set a new root branch. -- @@ -299,19 +300,16 @@ getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO) getBranch0FromProjectPath pp = Branch.head <$> getBranchFromProjectPath pp -getRootBranchForProjectBranch :: ProjectBranch -> Cli (Branch IO) -getRootBranchForProjectBranch ProjectBranch {projectId, branchId} = do - Cli.runTransaction do - _ +getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO) +getProjectBranchRoot projectBranch = do + Cli.Env {codebase} <- ask + liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch -- | Get the maybe-branch at an absolute path. getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) getMaybeBranchFromProjectPath pp = do Cli.Env {codebase} <- ask - let ProjectBranch {causalHashId} = pp ^. #branch - causalHash <- Cli.runTransaction $ Q.expectCausalHash causalHashId - rootBranch <- liftIO $ Codebase.expectBranchForHash codebase causalHash - pure (Branch.getAt (pp ^. PP.path_) rootBranch) + liftIO $ Codebase.getBranchAtProjectPath codebase pp -- | Get the maybe-branch0 at an absolute path. getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO)) @@ -419,7 +417,7 @@ stepManyAtNoSync' :: f (Path.Absolute, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepManyAtNoSync' actions = do - origRoot <- getProjectRoot + origRoot <- getCurrentProjectRoot newRoot <- Branch.stepManyAtM (relativizeActions actions) origRoot setCurrentProjectRoot newRoot pure (origRoot /= newRoot) @@ -446,15 +444,15 @@ stepManyAtMNoSync :: f (Path.Absolute, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepManyAtMNoSync actions = do - oldRoot <- getProjectRoot + oldRoot <- getCurrentProjectRoot newRoot <- liftIO (Branch.stepManyAtM (relativizeActions actions) oldRoot) setCurrentProjectRoot newRoot -- | Sync the in-memory root branch. syncRoot :: Text -> Cli () syncRoot description = do - rootBranch <- getProjectRoot - updateCurrentProjectBranchRoot rootBranch description + rootBranch <- getCurrentProjectRoot + updateCurrentProjectBranchRoot description (const rootBranch) -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise @@ -464,10 +462,10 @@ updateAtM :: (Branch IO -> Cli (Branch IO)) -> Cli Bool updateAtM reason pp f = do - b <- getBranchFromProjectPath (pp & PP.absPath_ .~ Path.absoluteEmpty) - b' <- Branch.modifyAtM (pp ^. PP.path_) f b - updateCurrentProjectBranchRoot b' reason - pure $ b /= b' + old <- getBranchFromProjectPath (pp & PP.absPath_ .~ Path.absoluteEmpty) + new <- Branch.modifyAtM (pp ^. PP.path_) f old + updateCurrentProjectBranchRoot reason (const new) + pure $ old /= new -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise @@ -503,6 +501,8 @@ updateProjectBranchRoot reason projectBranch f = do error "implement project-branch reflog" reason Cli.Env {codebase} <- ask Cli.time "updateProjectBranchRoot" do + old <- getProjectBranchRoot projectBranch + let new = f old liftIO $ Codebase.putBranch codebase new Cli.runTransaction $ do causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) From 5ad808c9bdc5d7c24b2b0826a9e53c397dbc65a5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Jun 2024 10:09:02 -0700 Subject: [PATCH 29/76] Update MoveTerm, MoveType, MoveBranch --- .../src/Unison/Codebase/BranchUtil.hs | 9 ++++--- unison-cli/src/Unison/Cli/NamesUtils.hs | 9 +++++-- .../Codebase/Editor/HandleInput/MoveAll.hs | 6 ++--- .../Codebase/Editor/HandleInput/MoveBranch.hs | 25 +++++++++---------- .../Codebase/Editor/HandleInput/MoveTerm.hs | 4 +-- .../Codebase/Editor/HandleInput/MoveType.hs | 10 ++++---- .../src/Unison/Codebase/Editor/Propagate.hs | 4 +-- 7 files changed, 36 insertions(+), 31 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index d0025cd87e..aff8f08c1b 100644 --- a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs +++ b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs @@ -26,6 +26,7 @@ import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.HashQualified' (HashQualified (HashQualified, NameOnly)) +import Unison.NameSegment (NameSegment) import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Prelude @@ -69,10 +70,10 @@ getBranch (p, seg) b = case Path.toList p of (Branch.head <$> Map.lookup h (b ^. Branch.children)) >>= getBranch (Path.fromList p, seg) -makeAddTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m) +makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m) makeAddTermName (p, name) r = (p, Branch.addTermName r name) -makeDeleteTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m) +makeDeleteTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m) makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name) makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m) @@ -81,10 +82,10 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name) makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m) makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name) -makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) +makeAddTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m) makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) -makeDeleteTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) +makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m) makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name) makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m) diff --git a/unison-cli/src/Unison/Cli/NamesUtils.hs b/unison-cli/src/Unison/Cli/NamesUtils.hs index 8e36020459..0c8e5c1060 100644 --- a/unison-cli/src/Unison/Cli/NamesUtils.hs +++ b/unison-cli/src/Unison/Cli/NamesUtils.hs @@ -1,15 +1,20 @@ -- | Utilities that have to do with constructing names objects. module Unison.Cli.NamesUtils ( currentNames, + projectRootNames, ) where import Unison.Cli.Monad (Cli) -import Unison.Cli.MonadUtils (getCurrentBranch0) +import Unison.Cli.MonadUtils qualified as Cli import Unison.Codebase.Branch.Names qualified as Branch import Unison.Names (Names) -- | Produce a 'Names' object which contains names for the current branch. currentNames :: Cli Names currentNames = do - Branch.toNames <$> getCurrentBranch0 + Branch.toNames <$> Cli.getCurrentBranch0 + +projectRootNames :: Cli Names +projectRootNames = do + Branch.toNames <$> Cli.getCurrentProjectRoot0 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs index 77b4bc8514..49d525011d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs @@ -11,9 +11,9 @@ import Unison.Codebase.Path qualified as Path import Unison.HashQualified' qualified as HQ' import Unison.Prelude -handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli () -handleMoveAll hasConfirmed src' dest' description = do - moveBranchFunc <- moveBranchFunc hasConfirmed src' dest' +handleMoveAll :: Path.Path' -> Path.Path' -> Text -> Cli () +handleMoveAll src' dest' description = do + moveBranchFunc <- moveBranchFunc src' dest' moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of Nothing -> pure [] Just (fmap HQ'.NameOnly -> src, dest) -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs index ad34073506..58e8e1a342 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs @@ -7,17 +7,16 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Output (Output (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude -moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO)) -moveBranchFunc hasConfirmed src' dest' = do - srcAbs <- Cli.resolvePath' src' - destAbs <- Cli.resolvePath' dest' +moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (PP.ProjectPath, Branch IO -> Branch IO)) +moveBranchFunc src' dest' = do + -- We currently only support moving within the same project branch. + srcPP@(PP.ProjectPath proj projBranch srcAbs) <- Cli.resolvePath' src' + PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest' destBranchExists <- Cli.branchExistsAtPath' dest' - let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs) - when (isRootMove && not hasConfirmed) do - Cli.returnEarly MoveRootBranchConfirmation - Cli.getMaybeBranchFromProjectRootPath srcAbs >>= traverse \srcBranch -> do + Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do -- We want the move to appear as a single step in the root namespace, but we need to make -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of -- those changes such that they appear as a single change in the root. @@ -26,16 +25,16 @@ moveBranchFunc hasConfirmed src' dest' = do changeRoot & Branch.modifyAt srcLoc (const Branch.empty) & Branch.modifyAt destLoc (const srcBranch) - if (destBranchExists && not isRootMove) + if destBranchExists then Cli.respond (MovedOverExistingBranch dest') else pure () - pure (Path.Absolute changeRootPath, doMove) + pure (PP.ProjectPath proj projBranch $ Path.Absolute changeRootPath, doMove) -- | Moves a branch and its history from one location to another, and saves the new root -- branch. -doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli () -doMoveBranch actionDescription hasConfirmed src' dest' = do - moveBranchFunc hasConfirmed src' dest' >>= \case +doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli () +doMoveBranch actionDescription src' dest' = do + moveBranchFunc src' dest' >>= \case Nothing -> Cli.respond (BranchNotFound src') Just (path, func) -> do _ <- Cli.updateAt actionDescription path func diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs index 86a5fa56aa..4ea6aa3489 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where -import Control.Lens (_2) +import Control.Lens (_1, _2) import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -34,7 +34,7 @@ moveTermSteps src' dest' = do pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm, - BranchUtil.makeAddTermName (Path.convert dest) srcTerm + BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm ] doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs index 9800dd1946..c4ff4a5a01 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs @@ -1,6 +1,6 @@ module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where -import Control.Lens (_2) +import Control.Lens (_1, _2) import Data.Set qualified as Set import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -9,14 +9,14 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.HashQualified' qualified as HQ' import Unison.NameSegment (NameSegment) import Unison.Prelude -moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)] +moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)] moveTypeSteps src' dest' = do src <- Cli.resolveSplit' src' srcTypes <- Cli.getTypesAt src @@ -30,11 +30,11 @@ moveTypeSteps src' dest' = do destTypes <- Cli.getTypesAt (Path.convert dest) when (not (Set.null destTypes)) do Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes) - let p = over _1 (view PP.path_) src + let p = over _1 (view PP.absPath_) src pure [ -- Mitchell: throwing away any hash-qualification here seems wrong! BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType, - BranchUtil.makeAddTypeName (over _1 (view PP.path_) dest) srcType + BranchUtil.makeAddTypeName (over _1 (view PP.absPath_) dest) srcType ] doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index 7183bad84c..8e847190a6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -14,7 +14,7 @@ import U.Codebase.Reference qualified as Reference 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.NamesUtils qualified as Cli import Unison.Cli.TypeCheck qualified as Cli (computeTypecheckingEnvironment) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -241,7 +241,7 @@ propagate patch b = case validatePatch patch of pure noEdits Just (initialTermEdits, initialTypeEdits) -> do -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent` - rootNames <- Branch.toNames <$> Cli.getProjectRoot0 + rootNames <- Cli.projectRootNames let -- TODO: these are just used for tracing, could be deleted if we don't care -- about printing meaningful names for definitions during propagation, or if From ce1c221bb02fc825347286ce036cc09d1461a746 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 13:51:01 -0700 Subject: [PATCH 30/76] Fixup MoveAll --- unison-cli/src/Unison/Cli/MonadUtils.hs | 14 +++++++------- .../Unison/Codebase/Editor/HandleInput/MoveAll.hs | 3 ++- .../Codebase/Editor/HandleInput/MoveBranch.hs | 13 ++++++++----- 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5fa5e4c601..52828233c7 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -108,7 +108,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ProjectPath (ProjectPath, ProjectPathG (..)) +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -478,18 +478,18 @@ updateAt reason p f = do updateAtM reason p (pure . f) updateAndStepAt :: - (Foldable f, Foldable g) => + (Foldable f, Foldable g, Functor g) => Text -> + ProjectBranch -> f (Path.Absolute, Branch IO -> Branch IO) -> - g (Path, Branch0 IO -> Branch0 IO) -> + g (Path.Absolute, Branch0 IO -> Branch0 IO) -> Cli () -updateAndStepAt reason updates steps = do +updateAndStepAt reason projectBranch updates steps = do let f b = b & (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) - & (Branch.stepManyAt steps) - ProjectPath _ projBranch _ <- getCurrentProjectPath - updateProjectBranchRoot reason projBranch f + & (Branch.stepManyAt (first Path.unabsolute <$> steps)) + updateProjectBranchRoot reason projectBranch f updateCurrentProjectBranchRoot :: Text -> (Branch IO -> Branch IO) -> Cli () updateCurrentProjectBranchRoot reason f = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs index 49d525011d..69b435529e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs @@ -23,5 +23,6 @@ handleMoveAll src' dest' description = do case (moveBranchFunc, moveTermTypeSteps) of (Nothing, []) -> Cli.respond (Output.MoveNothingFound src') (mupdates, steps) -> do - Cli.updateAndStepAt description (maybeToList mupdates) steps + pp <- Cli.getCurrentProjectPath + Cli.updateAndStepAt description (pp ^. #branch) (maybeToList mupdates) steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs index 58e8e1a342..dc5b31cf80 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs @@ -10,10 +10,12 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude -moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (PP.ProjectPath, Branch IO -> Branch IO)) +-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if +-- needed. +moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO)) moveBranchFunc src' dest' = do -- We currently only support moving within the same project branch. - srcPP@(PP.ProjectPath proj projBranch srcAbs) <- Cli.resolvePath' src' + srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src' PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest' destBranchExists <- Cli.branchExistsAtPath' dest' Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do @@ -28,7 +30,7 @@ moveBranchFunc src' dest' = do if destBranchExists then Cli.respond (MovedOverExistingBranch dest') else pure () - pure (PP.ProjectPath proj projBranch $ Path.Absolute changeRootPath, doMove) + pure (Path.Absolute changeRootPath, doMove) -- | Moves a branch and its history from one location to another, and saves the new root -- branch. @@ -36,6 +38,7 @@ doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli () doMoveBranch actionDescription src' dest' = do moveBranchFunc src' dest' >>= \case Nothing -> Cli.respond (BranchNotFound src') - Just (path, func) -> do - _ <- Cli.updateAt actionDescription path func + Just (absPath, func) -> do + pp <- Cli.resolvePath' (Path.AbsolutePath' absPath) + _ <- Cli.updateAt actionDescription pp func Cli.respond Success From a46321faa463c018627f59468820c0ce43b470f0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:08:53 -0700 Subject: [PATCH 31/76] Fix up Branch.hs module --- .../src/Unison/Codebase/Editor/HandleInput/Branch.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 4da27dca65..1533d56ec6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -100,16 +100,16 @@ createBranchFromParent mayParentBranch project newBranchName = do -- `bar`, so the fork will succeed. newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) newBranchCausalHashId <- - (ProjectBranch.causalHashId <$> mayParentBranch) `whenNothing` do + (for mayParentBranch (\ProjectBranch {projectId, branchId} -> Q.expectProjectBranchHead projectId branchId)) `whenNothingM` do (_, causalHashId) <- Codebase.emptyCausalHash pure causalHashId Queries.insertProjectBranch + newBranchCausalHashId Sqlite.ProjectBranch { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = ProjectBranch.branchId <$> mayParentBranch, - causalHashId = newBranchCausalHashId + parentBranchId = ProjectBranch.branchId <$> mayParentBranch } pure newBranchId @@ -131,12 +131,12 @@ createBranchFromNamespace project getBranchName branch = do newProjectBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash causalHash Queries.insertProjectBranch + newBranchCausalHashId Sqlite.ProjectBranch { projectId, branchId = newProjectBranchId, name = branchName, - parentBranchId = Nothing, - causalHashId = newBranchCausalHashId + parentBranchId = Nothing } pure newProjectBranchId From 0016706d1eb5861f1433196968081a80f580c30d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:12:57 -0700 Subject: [PATCH 32/76] Pull cleanup --- .../Codebase/Editor/HandleInput/Pull.hs | 70 +++++++++---------- 1 file changed, 32 insertions(+), 38 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 6165d60bc3..8ff8861dc1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -41,6 +41,7 @@ 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.ProjectPath qualified as PP import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.NameSegment qualified as NameSegment @@ -76,8 +77,7 @@ handlePull unresolvedSourceAndTarget pullMode = do when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source)) - let targetAbsolutePath = - ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId) + let targetProjectPath = PP.projectBranchRoot (ProjectAndBranch target.project target.branch) let description = Text.unwords @@ -92,9 +92,9 @@ handlePull unresolvedSourceAndTarget pullMode = do case pullMode of Input.PullWithHistory -> do - targetBranchObject <- Cli.getBranch0At targetAbsolutePath + targetBranch <- Cli.getBranchFromProjectPath targetProjectPath - if Branch.isEmpty0 targetBranchObject + if Branch.isEmpty0 $ Branch.head targetBranchObject then do Cli.Env {codebase} <- ask remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) @@ -103,11 +103,7 @@ handlePull unresolvedSourceAndTarget pullMode = do else do Cli.respond AboutToMerge - aliceCausalHash <- - Cli.runTransaction do - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath) - pure causal.causalHash - + let aliceCausalHash = Branch.headHash targetBranch lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash) doMerge @@ -167,30 +163,29 @@ resolveSourceAndTarget includeSquashed = \case pure (source, target) resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) -resolveImplicitSource includeSquashed = - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath - Just (localProjectAndBranch, _restPath) -> do - (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- - Cli.runTransactionWithRollback \rollback -> do - 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 - remoteBranchName <- - Queries.expectRemoteProjectBranchName - Share.hardCodedUri - remoteProjectId - remoteBranchId - pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) - _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch) - remoteBranch <- - ProjectUtils.expectRemoteProjectBranchById includeSquashed $ - ProjectAndBranch - (remoteProjectId, remoteProjectName) - (remoteBranchId, remoteBranchName) - pure (ReadShare'ProjectBranch remoteBranch) +resolveImplicitSource includeSquashed = do + pp <- Cli.getCurrentProjectPath + let localProjectAndBranch = pp ^. PP.asProjectAndBranch_ + (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- + Cli.runTransactionWithRollback \rollback -> do + 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 + remoteBranchName <- + Queries.expectRemoteProjectBranchName + Share.hardCodedUri + remoteProjectId + remoteBranchId + pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) + _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch) + remoteBranch <- + ProjectUtils.expectRemoteProjectBranchById includeSquashed $ + ProjectAndBranch + (remoteProjectId, remoteProjectName) + (remoteBranchId, remoteBranchName) + pure (ReadShare'ProjectBranch remoteBranch) resolveExplicitSource :: Share.IncludeSquashedHead -> @@ -208,7 +203,7 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch + localProjectAndBranch <- view PP.asProjectAndBranch_ <$> Cli.getCurrentProjectPath let localProjectId = localProjectAndBranch.project.projectId let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case @@ -243,8 +238,7 @@ resolveExplicitSource includeSquashed = \case resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) resolveImplicitTarget = do - (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - pure projectAndBranch + view PP.asProjectAndBranch_ <$> Cli.getCurrentProjectPath -- | supply `dest0` if you want to print diff messages -- supply unchangedMessage if you want to display it if merge had no effect @@ -253,8 +247,8 @@ mergeBranchAndPropagateDefaultPatch :: Text -> Maybe Output -> Branch IO -> - Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> - Path.Absolute -> + Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> + PP.ProjectPath -> Cli () mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest = ifM From 0799264b540f6bebe07cd16dab1eb5d98d7a189b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:38:14 -0700 Subject: [PATCH 33/76] Remove NoSync primitive usages in Update/Propagate --- .../Codebase/Editor/HandleInput/Update.hs | 63 +++++++++++-------- .../src/Unison/Codebase/Editor/Propagate.hs | 11 ++-- 2 files changed, 41 insertions(+), 33 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index b6bb301056..1f2538891a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs @@ -22,6 +22,7 @@ import Unison.Cli.TypeCheck (computeTypecheckingEnvironment) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names as Branch import Unison.Codebase.BranchUtil qualified as BranchUtil import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output @@ -171,37 +172,46 @@ handleUpdate input optionalPatch requestedNames = do pure (updatePatch ye'ol'Patch, updatePatches, p) when (Slurp.hasAddsOrUpdates sr) $ do - -- take a look at the `updates` from the SlurpResult - -- and make a patch diff to record a replacement from the old to new references - Cli.stepManyAtMNoSync - ( [ ( Path.unabsolute currentPath', - pure . doSlurpUpdates typeEdits termEdits termDeprecations - ), - ( Path.unabsolute currentPath', - pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) - ) - ] - ++ case patchOps of - Nothing -> [] - Just (_, update, p) -> [(Path.unabsolute p, update)] - ) + -- First add the new definitions to the codebase Cli.runTransaction . Codebase.addDefsToCodebase codebase . Slurp.filterUnisonFile sr $ Slurp.originalFile sr + currentBranch <- Cli.getCurrentBranch + -- take a look at the `updates` from the SlurpResult + -- and make a patch diff to record a replacement from the old to new references + updatedBranch <- + currentBranch + & Branch.stepManyAtM + ( [ ( Path.unabsolute currentPath', + pure . doSlurpUpdates typeEdits termEdits termDeprecations + ), + ( Path.unabsolute currentPath', + pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) + ) + ] + ++ case patchOps of + Nothing -> [] + Just (_, update, p) -> [(Path.unabsolute p, update)] + ) + & liftIO + let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames let suffixifiedPPE = PPE.suffixifiedPPE pped Cli.respond $ SlurpOutput input suffixifiedPPE sr - whenJust patchOps \(updatedPatch, _, _) -> - void $ propagatePatchNoSync updatedPatch currentPath' - Cli.syncRoot case patchPath of - Nothing -> "update.nopatch" - Just p -> - p - & Path.unsplit' - & Path.resolve @_ @_ @Path.Absolute currentPath' - & tShow + branchWithPropagatedPatch <- case patchOps of + Nothing -> pure updatedBranch + Just (updatedPatch, _, _) -> do + propagatePatch updatedPatch (Path.unabsolute currentPath') updatedBranch + let description = case patchPath of + Nothing -> "update.nopatch" + Just p -> + p + & Path.unsplit' + & Path.resolve @_ @_ @Path.Absolute currentPath' + & tShow + Cli.updateRoot branchWithPropagatedPatch description getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult getSlurpResultForUpdate requestedNames slurpCheckNames = do @@ -646,10 +656,11 @@ doSlurpUpdates typeEdits termEdits deprecated b0 = split = Path.splitFromName n -- Returns True if the operation changed the namespace, False otherwise. -propagatePatchNoSync :: Patch -> Path.Absolute -> Cli Bool -propagatePatchNoSync patch scopePath = +propagatePatch :: Patch -> Path.Path -> Branch.Branch IO -> Cli (Branch.Branch IO) +propagatePatch patch scopePath b = do Cli.time "propagatePatchNoSync" do - Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + let names = Branch.toNames $ Branch.head b + Branch.stepManyAtM [(scopePath, Propagate.propagateAndApply names patch)] b recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])] recomponentize = diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index f1bf65962c..813a6110ad 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -14,7 +14,6 @@ import U.Codebase.Reference qualified as Reference 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.TypeCheck qualified as Cli (computeTypecheckingEnvironment) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -82,10 +81,11 @@ noEdits :: Edits v noEdits = Edits mempty mempty mempty mempty mempty mempty mempty propagateAndApply :: + Names -> Patch -> Branch0 IO -> Cli (Branch0 IO) -propagateAndApply patch branch = do +propagateAndApply rootNames patch branch = do edits <- propagate patch branch let f = applyPropagate patch edits (pure . f . applyDeprecations patch) branch @@ -234,15 +234,12 @@ debugMode = False -- -- "dirty" means in need of update -- "frontier" means updated definitions responsible for the "dirty" -propagate :: Patch -> Branch0 IO -> Cli (Edits Symbol) -propagate patch b = case validatePatch patch of +propagate :: Names -> Patch -> Branch0 IO -> Cli (Edits Symbol) +propagate rootNames patch b = case validatePatch patch of Nothing -> do Cli.respond PatchNeedsToBeConflictFree pure noEdits Just (initialTermEdits, initialTypeEdits) -> do - -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent` - rootNames <- Branch.toNames <$> Cli.getRootBranch0 - let -- TODO: these are just used for tracing, could be deleted if we don't care -- about printing meaningful names for definitions during propagation, or if -- we want to just remove the tracing. From 07f877481fa14ba07e042da2cbaee44600547bd2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:38:14 -0700 Subject: [PATCH 34/76] Remove nosync usages from AddRun --- unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs | 4 ++-- unison-cli/src/Unison/Codebase/Editor/Propagate.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs index e9d396cb29..7d24986d27 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs @@ -41,12 +41,12 @@ handleAddRun input resultName = do currentNames <- Cli.currentNames let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames let adds = SlurpResult.adds sr - Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf) Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf + let description = (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName) + Cli.stepAt description (Path.unabsolute currentPath, doSlurpAdds adds uf) let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile let suffixifiedPPE = PPE.suffixifiedPPE pped - Cli.syncRoot (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName) Cli.respond $ SlurpOutput input suffixifiedPPE sr addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann) diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index 813a6110ad..abea3e9901 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -86,7 +86,7 @@ propagateAndApply :: Branch0 IO -> Cli (Branch0 IO) propagateAndApply rootNames patch branch = do - edits <- propagate patch branch + edits <- propagate rootNames patch branch let f = applyPropagate patch edits (pure . f . applyDeprecations patch) branch From 14bd8018b37a9669e9e64e032baf46fd323dc3eb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:38:14 -0700 Subject: [PATCH 35/76] Remove NoSync primitive usages --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 3 +-- unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs | 4 +++- unison-cli/src/Unison/Codebase/Editor/Propagate.hs | 1 + 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 9949ef7a42..a52c5b4e21 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -719,12 +719,11 @@ loop e = do currentNames <- Branch.toNames <$> Cli.getCurrentBranch0 let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames let adds = SlurpResult.adds sr - Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf) Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf + Cli.stepAt description (Path.unabsolute currentPath, doSlurpAdds adds uf) pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.respond $ SlurpOutput input suffixifiedPPE sr - Cli.syncRoot description SaveExecuteResultI resultName -> handleAddRun input resultName PreviewAddI requestedNames -> do (sourceName, _) <- Cli.expectLatestFile diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 6165d60bc3..890ad66463 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -28,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.Branch.Names 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 @@ -301,6 +302,7 @@ propagatePatch :: Cli Bool propagatePatch inputDescription patch scopePath = do Cli.time "propagatePatch" do + rootNames <- Branch.toNames <$> Cli.getRootBranch0 Cli.stepAt' (inputDescription <> " (applying patch)") - (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + (Path.unabsolute scopePath, Propagate.propagateAndApply rootNames patch) diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index abea3e9901..5864517034 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -240,6 +240,7 @@ propagate rootNames patch b = case validatePatch patch of Cli.respond PatchNeedsToBeConflictFree pure noEdits Just (initialTermEdits, initialTypeEdits) -> do + -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent` let -- TODO: these are just used for tracing, could be deleted if we don't care -- about printing meaningful names for definitions during propagation, or if -- we want to just remove the tracing. From 8b5859c798983bcaf9c10a8f39f06227e72bf106 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:38:14 -0700 Subject: [PATCH 36/76] Remove NoSync primitives --- unison-cli/src/Unison/Cli/MonadUtils.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5aa583ee4c..c814815a04 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -43,11 +43,7 @@ module Unison.Cli.MonadUtils stepAt', stepAt, stepAtM, - stepAtNoSync', - stepAtNoSync, stepManyAt, - stepManyAtMNoSync, - stepManyAtNoSync, syncRoot, updateRoot, updateAtM, @@ -351,16 +347,6 @@ stepAt' :: Cli Bool stepAt' cause = stepManyAt' @[] cause . pure -stepAtNoSync' :: - (Path, Branch0 IO -> Cli (Branch0 IO)) -> - Cli Bool -stepAtNoSync' = stepManyAtNoSync' @[] . pure - -stepAtNoSync :: - (Path, Branch0 IO -> Branch0 IO) -> - Cli () -stepAtNoSync = stepManyAtNoSync @[] . pure - stepAtM :: Text -> (Path, Branch0 IO -> IO (Branch0 IO)) -> From 87bd96963e58e673abf3f93d5f9b982813df82c3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 15:08:05 -0700 Subject: [PATCH 37/76] Inline nosync versions into their regular forms so people aren't tempted to use them. --- unison-cli/src/Unison/Cli/MonadUtils.hs | 30 +- ...ability-term-conflicts-on-update.output.md | 5 +- .../transcripts/cycle-update-5.output.md | 6 +- .../transcripts/diff-namespace.output.md | 390 +----------------- unison-src/transcripts/fix2254.output.md | 150 +------ unison-src/transcripts/propagate.output.md | 179 +------- unison-src/transcripts/todo.output.md | 252 +---------- 7 files changed, 42 insertions(+), 970 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index c814815a04..72fba2adce 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -44,6 +44,7 @@ module Unison.Cli.MonadUtils stepAt, stepAtM, stepManyAt, + stepManyAtM, syncRoot, updateRoot, updateAtM, @@ -359,7 +360,7 @@ stepManyAt :: f (Path, Branch0 IO -> Branch0 IO) -> Cli () stepManyAt reason actions = do - stepManyAtNoSync actions + void . modifyRootBranch $ Branch.stepManyAt actions syncRoot reason stepManyAt' :: @@ -368,45 +369,22 @@ stepManyAt' :: f (Path, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool stepManyAt' reason actions = do - res <- stepManyAtNoSync' actions - syncRoot reason - pure res - -stepManyAtNoSync' :: - (Foldable f) => - f (Path, Branch0 IO -> Cli (Branch0 IO)) -> - Cli Bool -stepManyAtNoSync' actions = do origRoot <- getRootBranch newRoot <- Branch.stepManyAtM actions origRoot setRootBranch newRoot + syncRoot reason pure (origRoot /= newRoot) --- Like stepManyAt, but doesn't update the last saved root -stepManyAtNoSync :: - (Foldable f) => - f (Path, Branch0 IO -> Branch0 IO) -> - Cli () -stepManyAtNoSync actions = - void . modifyRootBranch $ Branch.stepManyAt actions - stepManyAtM :: (Foldable f) => Text -> f (Path, Branch0 IO -> IO (Branch0 IO)) -> Cli () stepManyAtM reason actions = do - stepManyAtMNoSync actions - syncRoot reason - -stepManyAtMNoSync :: - (Foldable f) => - f (Path, Branch0 IO -> IO (Branch0 IO)) -> - Cli () -stepManyAtMNoSync actions = do oldRoot <- getRootBranch newRoot <- liftIO (Branch.stepManyAtM actions oldRoot) setRootBranch newRoot + syncRoot reason -- | Sync the in-memory root branch. syncRoot :: Text -> Cli () diff --git a/unison-src/transcripts/ability-term-conflicts-on-update.output.md b/unison-src/transcripts/ability-term-conflicts-on-update.output.md index 901446e8d4..0430088f08 100644 --- a/unison-src/transcripts/ability-term-conflicts-on-update.output.md +++ b/unison-src/transcripts/ability-term-conflicts-on-update.output.md @@ -81,12 +81,9 @@ These should fail with a term/ctor conflict since we exclude the ability from th ⍟ I've added these definitions: + ability Channels Channels.send : a -> () thing : '{Channels} () - - ⍟ I've updated these names to your new definition: - - ability Channels ``` If however, `Channels.send` and `thing` _depend_ on `Channels`, updating them should succeed since it pulls in the ability as a dependency. diff --git a/unison-src/transcripts/cycle-update-5.output.md b/unison-src/transcripts/cycle-update-5.output.md index 3e3361f70c..6f9f4ebff4 100644 --- a/unison-src/transcripts/cycle-update-5.output.md +++ b/unison-src/transcripts/cycle-update-5.output.md @@ -62,10 +62,8 @@ inner.ping _ = !pong + 3 .> view inner.ping - inner.ping : 'Nat - inner.ping _ = - use Nat + - !pong + 1 + inner.inner.ping : '##Nat + inner.inner.ping _ = ##Nat.+ !#4t465jk908 3 ``` The bug here is that `inner.ping` still refers to `pong` by name. But if we properly identified the nameless (in the diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index cacb9d1fc4..d0699527da 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -213,399 +213,23 @@ unique type Y a b = Y a b .> diff.namespace ns1 ns2 - Resolved name conflicts: - - 1. ┌ fromJust#gjmq673r1v : Nat - 2. └ fromJust#rnbo52q2sh : Text - ↓ - 3. fromJust#6gn1k53ie0 : Nat - - Updates: - - 4. b : Nat - ↓ - 5. b : Text - - 6. fromJust' : Nat - ↓ - 7. fromJust' : Nat - - Added definitions: - - 8. type Y a b - 9. Y.Y : a -> b -> Y a b - 10. d : Nat - 11. e : Nat - 12. f : Nat - - 13. patch patch (added 2 updates) - -.> alias.term ns2.d ns2.d' - - Done. - -.> alias.type ns2.A ns2.A' - - Done. - -.> alias.type ns2.X ns2.X' - - Done. - -.> diff.namespace ns1 ns2 - - Resolved name conflicts: - - 1. ┌ fromJust#gjmq673r1v : Nat - 2. └ fromJust#rnbo52q2sh : Text - ↓ - 3. fromJust#6gn1k53ie0 : Nat - - Updates: - - 4. b : Nat - ↓ - 5. b : Text - - 6. fromJust' : Nat - ↓ - 7. fromJust' : Nat - - Added definitions: - - 8. type Y a b - 9. Y.Y : a -> b -> Y a b - 10. ┌ d : Nat - 11. └ d' : Nat - 12. e : Nat - 13. f : Nat - - 14. patch patch (added 2 updates) - - Name changes: - - Original Changes - 15. A 16. A' (added) - - 17. X 18. X' (added) - -.> alias.type ns1.X ns1.X2 - - Done. - -.> alias.type ns2.A' ns2.A'' - - Done. - -.> fork ns2 ns3 - - Done. - -.> alias.term ns2.fromJust' ns2.yoohoo - - Done. - -.> delete.term.verbose ns2.fromJust' - - Name changes: - - Original Changes - 1. ns2.fromJust ┐ 2. ns2.fromJust' (removed) - 3. ns2.fromJust' │ - 4. ns2.yoohoo │ - 5. ns3.fromJust │ - 6. ns3.fromJust' ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> diff.namespace ns3 ns2 - - Name changes: - - Original Changes - 1. fromJust ┐ 2. yoohoo (added) - 3. fromJust' ┘ 4. fromJust' (removed) - -``` -```unison -bdependent = "banana" -``` - -```ucm -.ns3> update.old - - ⍟ I've updated these names to your new definition: - - bdependent : ##Text - -.> diff.namespace ns2 ns3 - - Updates: - - 1. bdependent : Nat - ↓ - 2. bdependent : Text - - 3. patch patch (added 1 updates) - - Name changes: - - Original Changes - 4. fromJust ┐ 5. fromJust' (added) - 6. yoohoo ┘ 7. yoohoo (removed) - -``` -## Two different auto-propagated changes creating a name conflict -Currently, the auto-propagated name-conflicted definitions are not explicitly -shown, only their also-conflicted dependency is shown. -```unison -a = 333 -b = a + 1 -``` - -```ucm - ☝️ The namespace .nsx is empty. - -.nsx> add - - ⍟ I've added these definitions: - - a : ##Nat - b : ##Nat - -.> fork nsx nsy - - Done. - -.> fork nsx nsz - - Done. - -``` -```unison -a = 444 -``` - -```ucm -.nsy> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -``` -```unison -a = 555 -``` - -```ucm -.nsz> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -.> merge.old nsy nsw - - Here's what's changed in nsw after the merge: - - Added definitions: - - 1. a : Nat - 2. b : Nat - - 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 -.> merge.old nsz nsw - - Here's what's changed in nsw after the merge: - - New name conflicts: - - 1. a#mdl4vqtu00 : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#unkqhuu66p : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Updates: - - 7. 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. - -``` -```ucm -.> diff.namespace nsx nsw - - New name conflicts: - - 1. a#uiiiv8a86s : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#lhigeb1let : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Added definitions: - - 7. patch patch (added 2 updates) - -.nsw> view a b - - a#mdl4vqtu00 : ##Nat - a#mdl4vqtu00 = 444 - - a#vrs8gtkl2t : ##Nat - a#vrs8gtkl2t = 555 - - b#aapqletas7 : ##Nat - b#aapqletas7 = ##Nat.+ a#vrs8gtkl2t 1 - - b#unkqhuu66p : ##Nat - b#unkqhuu66p = ##Nat.+ a#mdl4vqtu00 1 - -``` -## Should be able to diff a namespace hash from history. - -```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 - ☝️ The namespace .hashdiff is empty. - -.hashdiff> add - - ⍟ I've added these definitions: + ⚠️ - x : ##Nat + The namespace .ns1 is empty. Was there a typo? ``` -```unison -y = 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 new definitions are ok to `add`: - - y : ##Nat - +.ns2> update.old.> diff.namespace ns1 ns2.> alias.term ns2.d ns2.d'.> alias.type ns2.A ns2.A'.> alias.type ns2.X ns2.X'.> diff.namespace ns1 ns2.> alias.type ns1.X ns1.X2.> alias.type ns2.A' ns2.A''.> fork ns2 ns3.> alias.term ns2.fromJust' ns2.yoohoo.> delete.term.verbose ns2.fromJust'.> diff.namespace ns3 ns2 ``` -```ucm -.hashdiff> add - ⍟ I've added these definitions: - - y : ##Nat -.hashdiff> history +🛑 - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ru1hnjofdj - - + Adds / updates: - - y - - □ 2. #i52j9fd57b (start of history) +The transcript failed due to an error in the stanza above. The error is: -.hashdiff> diff.namespace 2 1 - Added definitions: + ⚠️ - 1. y : ##Nat + The namespace .ns1 is empty. Was there a typo? -``` -## - -Updates: -- 1 to 1 - -New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) - - 1. foo#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so - ↓ - 2. ┌ foo#0ja1qfpej6 : Nat - 3. └ foo#jk19sm5bf8 : Nat - -Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one - - 4. ┌ bar#0ja1qfpej6 : Nat - 5. └ bar#jk19sm5bf8 : Nat - ↓ - 6. bar#jk19sm5bf8 : Nat - -## Display issues to fixup - -- [d] Do we want to surface new edit conflicts in patches? -- [t] two different auto-propagated changes creating a name conflict should show - up somewhere besides the auto-propagate count -- [t] Things look screwy when the type signature doesn't fit and has to get broken - up into multiple lines. Maybe just disallow that? -- [d] Delete blank line in between copies / renames entries if all entries are 1 to 1 - see todo in the code -- [x] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) -- [x] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) -- [x] might want unqualified names to be qualified sometimes: -- [x] if a name is updated to a not-yet-named reference, it's shown as both an update and an add -- [x] similarly, if a conflicted name is resolved by deleting the last name to - a reference, I (arya) suspect it will show up as a Remove -- [d] Maybe group and/or add headings to the types, constructors, terms -- [x] add tagging of propagated updates to test propagated updates output -- [x] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) -- [x] delete.term has some bonkers output -- [x] Make a decision about how we want to show constructors in the diff -- [x] 12.patch patch needs a space -- [x] This looks like garbage -- [x] Extra 2 blank lines at the end of the add section -- [x] Fix alignment issues with buildTable, convert to column3M (to be written) -- [x] adding an alias is showing up as an Add and a Copy; should just show as Copy -- [x] removing one of multiple aliases appears in removes + moves + copies section -- [x] some overlapping cases between Moves and Copies^ -- [x] Maybe don't list the type signature twice for aliases? diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md index 61af269b2c..f5993c0f8e 100644 --- a/unison-src/transcripts/fix2254.output.md +++ b/unison-src/transcripts/fix2254.output.md @@ -72,149 +72,35 @@ Let's do the update now, and verify that the definitions all look good and there .a2> view A NeedsA f f2 f3 g - type A a b c d - = B b - | D d - | E a d - | C c - | A a - - structural type NeedsA a b - = Zoink Text - | NeedsA (A a b Nat Nat) - - f : A Nat Nat Nat Nat -> Nat - f = cases - A n -> n - _ -> 42 - - f2 : A Nat Nat Nat Nat -> Nat - f2 a = - use Nat + - n = f a - n + 1 - - f3 : NeedsA Nat Nat -> Nat - f3 = cases - NeedsA a -> f a Nat.+ 20 - _ -> 0 - - g : A Nat Nat Nat Nat -> Nat - g = cases - D n -> n - _ -> 43 + type A a b c d = B b | D d | E a d | C c | A a -.a2> todo - - ✅ + ⚠️ - No conflicts or edits in progress. - -``` -## Record updates - -Here's a test of updating a record: - -```unison -structural type Rec = { uno : Nat, dos : Nat } + The following names were not found in the codebase. Check your spelling. + NeedsA + f + f2 + f3 + g -combine r = uno r + dos r ``` ```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 Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - combine : Rec -> Nat - +.a2> update.old.a2> view A NeedsA f f2 f3 g.a2> todo ``` -```ucm -.a3> add - ⍟ I've added these definitions: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - combine : Rec -> Nat -``` -```unison -structural type Rec = { uno : Nat, dos : Nat, tres : Text } -``` +🛑 -```ucm +The transcript failed due to an error in the stanza above. The error is: - 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`: - - Rec.tres : Rec -> Text - Rec.tres.modify : (Text ->{g} Text) -> Rec ->{g} Rec - Rec.tres.set : Text -> Rec -> Rec - - ⍟ These names already exist. You can `update` them to your - new definition: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - -``` -And checking that after updating this record, there's nothing `todo`: - -```ucm -.> fork a3 a4 - - Done. + The following names were not found in the codebase. Check your spelling. + NeedsA + f + f2 + f3 + g -.a4> update.old - - ⍟ I've added these definitions: - - Rec.tres : Rec -> Text - Rec.tres.modify : (Text ->{g} Text) -> Rec ->{g} Rec - Rec.tres.set : Text -> Rec -> Rec - - ⍟ I've updated these names to your new definition: - - structural type Rec - Rec.dos : Rec -> Nat - Rec.dos.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.dos.set : Nat -> Rec -> Rec - Rec.uno : Rec -> Nat - Rec.uno.modify : (Nat ->{g} Nat) -> Rec ->{g} Rec - Rec.uno.set : Nat -> Rec -> Rec - -.a4> todo - - ✅ - - No conflicts or edits in progress. - -``` diff --git a/unison-src/transcripts/propagate.output.md b/unison-src/transcripts/propagate.output.md index 5f0b72bb35..ce3d37dcdf 100644 --- a/unison-src/transcripts/propagate.output.md +++ b/unison-src/transcripts/propagate.output.md @@ -87,185 +87,22 @@ and update the codebase to use the new type `Foo`... ```ucm .subpath> view fooToInt - fooToInt : Foo -> Int - fooToInt _ = +42 - -``` -### Preserving user type variables - -We make a term that has a dependency on another term and also a non-redundant -user-provided type signature. - -```unison -preserve.someTerm : Optional foo -> Optional foo -preserve.someTerm x = x - -preserve.otherTerm : Optional baz -> Optional baz -preserve.otherTerm y = someTerm y -``` - -```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`: - - preserve.otherTerm : Optional baz -> Optional baz - preserve.someTerm : Optional foo -> Optional foo - -``` -Add that to the codebase: - -```ucm -.subpath> add - - ⍟ I've added these definitions: + ⚠️ - preserve.otherTerm : Optional baz -> Optional baz - preserve.someTerm : Optional foo -> Optional foo - -``` -Let's now edit the dependency: + The following names were not found in the codebase. Check your spelling. + fooToInt -```unison -preserve.someTerm : Optional x -> Optional x -preserve.someTerm _ = None ``` -```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: - - preserve.someTerm : Optional x -> Optional x +🛑 -``` -Update... +The transcript failed due to an error in the stanza above. The error is: -```ucm -.subpath> update.old - ⍟ I've updated these names to your new definition: + ⚠️ - preserve.someTerm : Optional x -> Optional x - -``` -Now the type of `someTerm` should be `Optional x -> Optional x` and the -type of `otherTerm` should remain the same. - -```ucm -.subpath> view preserve.someTerm - - preserve.someTerm : Optional x -> Optional x - preserve.someTerm _ = None - -.subpath> view preserve.otherTerm - - preserve.otherTerm : Optional baz -> Optional baz - preserve.otherTerm y = someTerm y - -``` -### Propagation only applies to the local branch - -Cleaning up a bit... - -```ucm -.> delete.namespace subpath - - Done. - - ☝️ The namespace .subpath.lib is empty. - -.subpath.lib> builtins.merge + The following names were not found in the codebase. Check your spelling. + fooToInt - Done. - -``` -Now, we make two terms, where one depends on the other. - -```unison -one.someTerm : Optional foo -> Optional foo -one.someTerm x = x - -one.otherTerm : Optional baz -> Optional baz -one.otherTerm y = someTerm y -``` - -```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`: - - one.otherTerm : Optional baz -> Optional baz - one.someTerm : Optional foo -> Optional foo - -``` -We'll make two copies of this namespace. - -```ucm -.subpath> add - - ⍟ I've added these definitions: - - one.otherTerm : Optional baz -> Optional baz - one.someTerm : Optional foo -> Optional foo - -.subpath> fork one two - - Done. - -``` -Now let's edit one of the terms... - -```unison -someTerm : Optional x -> Optional x -someTerm _ = None -``` - -```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`: - - someTerm : Optional x -> Optional x - -``` -... in one of the namespaces... - -```ucm -.subpath.one> update.old - - ⍟ I've updated these names to your new definition: - - someTerm : #nirp5os0q6 x -> #nirp5os0q6 x - -``` -The other namespace should be left alone. - -```ucm -.subpath> view two.someTerm - - two.someTerm : Optional foo -> Optional foo - two.someTerm x = x - -``` diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md index b0a9d69c6d..9a38511690 100644 --- a/unison-src/transcripts/todo.output.md +++ b/unison-src/transcripts/todo.output.md @@ -29,264 +29,16 @@ type MyType = MyType Text .simple> todo - 🚧 - - The namespace has 2 transitive dependent(s) left to upgrade. - Your edit frontier is the dependents of these definitions: - - type #vijug0om28 - #gjmq673r1v : Nat - - I recommend working on them in the following order: - - 1. useMyType : Nat - 2. useX : Nat - - - -``` -## A merge with conflicting updates. - -```unison -x = 1 -type MyType = MyType -``` - -Set up two branches with the same starting point. - -Update `x` to a different term in each branch. - -```unison -x = 2 -type MyType = MyType Nat -``` - -```unison -x = 3 -type MyType = MyType Int -``` - -```ucm -.mergeA> merge.old .mergeB - - Here's what's changed in the current namespace after the - merge: - - New name conflicts: - - 1. type MyType#ig1g2ka7lv - ↓ - 2. ┌ type MyType#8c6f40i3tj - 3. └ type MyType#ig1g2ka7lv - - 4. MyType.MyType#ig1g2ka7lv#0 : Nat -> MyType#ig1g2ka7lv - ↓ - 5. ┌ MyType.MyType#8c6f40i3tj#0 : Int -> MyType#8c6f40i3tj - 6. └ MyType.MyType#ig1g2ka7lv#0 : Nat -> MyType#ig1g2ka7lv - - 7. x#dcgdua2lj6 : Nat - ↓ - 8. ┌ x#dcgdua2lj6 : Nat - 9. └ x#f3lgjvjqoo : Nat - - Updates: - - 10. patch patch (added 2 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. - -.mergeA> 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 type 1. #8h7qq3ougl was replaced with - 2. MyType#8c6f40i3tj - 3. MyType#ig1g2ka7lv - The term 4. #gjmq673r1v was replaced with - 5. x#dcgdua2lj6 - 6. x#f3lgjvjqoo - ❓ - - The term MyType.MyType has conflicting definitions: - 7. MyType.MyType#8c6f40i3tj#0 - 8. MyType.MyType#ig1g2ka7lv#0 - - Tip: This occurs when merging branches that both independently - introduce the same name. Use `move.term` or `delete.term` - to resolve the conflicts. - -``` -## A named value that appears on the LHS of a patch isn't shown - -```unison -foo = 801 -``` - -```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`: - - foo : Nat - -``` -```ucm -.lhs> add - - ⍟ I've added these definitions: - - foo : Nat - -``` -```unison -foo = 802 -``` - -```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 -.lhs> update.old - - ⍟ I've updated these names to your new definition: - - foo : Nat - -``` -```unison -oldfoo = 801 -``` - -```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`: - - oldfoo : Nat - -``` -```ucm -.lhs> add - - ⍟ I've added these definitions: - - oldfoo : Nat - -.lhs> todo - ✅ No conflicts or edits in progress. ``` -## A type-changing update to one element of a cycle, which doesn't propagate to the other - -```unison -even = cases - 0 -> true - n -> odd (drop 1 n) -odd = cases - 0 -> false - n -> even (drop 1 n) ``` -```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`: - - even : Nat -> Boolean - odd : Nat -> Boolean +🛑 -``` -```ucm -.cycle2> add - - ⍟ I've added these definitions: - - even : Nat -> Boolean - odd : Nat -> Boolean - -``` -```unison -even = 17 -``` - -```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: - - even : Nat - -``` -```ucm -.cycle2> update.old - - ⍟ I've updated these names to your new definition: - - even : Nat - -``` -```ucm -.cycle2> todo - - 🚧 - - The namespace has 1 transitive dependent(s) left to upgrade. - Your edit frontier is the dependents of these definitions: - - #kkohl7ba1e : Nat -> Boolean - - I recommend working on them in the following order: - - 1. odd : Nat -> Boolean - - - -``` +The transcript was expecting an error in the stanza above, but did not encounter one. From 9f7b82533e63428bf42fad83ab750b85885126e3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 5 Jun 2024 14:12:57 -0700 Subject: [PATCH 38/76] Tweaks --- unison-cli/src/Unison/Cli/MonadUtils.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 52828233c7..e780089ad3 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -433,9 +433,10 @@ stepManyAtNoSync actions = do stepManyAtM :: (Foldable f) => Text -> + ProjectBranch -> f (Path.Absolute, Branch0 IO -> IO (Branch0 IO)) -> Cli () -stepManyAtM reason actions = do +stepManyAtM pb reason actions = do stepManyAtMNoSync actions syncRoot reason @@ -449,8 +450,8 @@ stepManyAtMNoSync actions = do setCurrentProjectRoot newRoot -- | Sync the in-memory root branch. -syncRoot :: Text -> Cli () -syncRoot description = do +syncRoot :: ProjectBranch -> Text -> Cli () +syncRoot pb description = do rootBranch <- getCurrentProjectRoot updateCurrentProjectBranchRoot description (const rootBranch) From 6518e3f3fc4a34ef2673d99581436c9793fa3ed6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 6 Jun 2024 10:41:01 -0700 Subject: [PATCH 39/76] Deleting a bunch of stuff to do with push/pull loose code --- unison-cli/src/Unison/Cli/MonadUtils.hs | 12 +++ .../src/Unison/Cli/UnisonConfigUtils.hs | 90 ------------------- .../Codebase/Editor/HandleInput/Pull.hs | 1 - .../Codebase/Editor/HandleInput/Push.hs | 32 ++----- .../src/Unison/Codebase/Editor/Output.hs | 2 - unison-cli/unison-cli.cabal | 1 - 6 files changed, 18 insertions(+), 120 deletions(-) delete mode 100644 unison-cli/src/Unison/Cli/UnisonConfigUtils.hs diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 01ad211d2e..6f104bf8ce 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -13,6 +13,10 @@ module Unison.Cli.MonadUtils resolvePath', resolveSplit', + -- * Project and branch resolution + getCurrentProjectAndBranch, + getCurrentProjectBranch, + -- * Branches -- ** Resolving branch identifiers @@ -151,6 +155,14 @@ getCurrentProjectPath = do pure (project, branch) pure (PP.ProjectPath proj branch path) +getCurrentProjectAndBranch :: Cli (ProjectAndBranch Project ProjectBranch) +getCurrentProjectAndBranch = do + view PP.asProjectAndBranch_ <$> getCurrentProjectPath + +getCurrentProjectBranch :: Cli ProjectBranch +getCurrentProjectBranch = do + view #branch <$> getCurrentProjectPath + -- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs deleted file mode 100644 index c062c7b476..0000000000 --- a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | @.unisonConfig@ file utilities -module Unison.Cli.UnisonConfigUtils - ( remoteMappingKey, - resolveConfiguredUrl, - ) -where - -import Control.Lens -import Data.Foldable.Extra qualified as Foldable -import Data.Sequence (Seq (..)) -import Data.Sequence qualified as Seq -import Data.Text qualified as Text -import Text.Megaparsec qualified as P -import Unison.Cli.Monad (Cli) -import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli -import Unison.Codebase.Editor.Output -import Unison.Codebase.Editor.Output.PushPull (PushPull) -import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace (..)) -import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo -import Unison.Codebase.Editor.UriParser qualified as UriParser -import Unison.Codebase.Path (Path' (..)) -import Unison.Codebase.Path qualified as Path -import Unison.Prelude -import Unison.Syntax.NameSegment qualified as NameSegment - -configKey :: Text -> Path.Absolute -> Text -configKey k p = - Text.intercalate "." . toList $ - k - :<| fmap - NameSegment.toEscapedText - (Path.toSeq $ Path.unabsolute p) - -remoteMappingKey :: Path.Absolute -> Text -remoteMappingKey = configKey "RemoteMapping" - --- Takes a maybe (namespace address triple); returns it as-is if `Just`; --- otherwise, tries to load a value from .unisonConfig, and complains --- if needed. -resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void) -resolveConfiguredUrl pushPull destPath' = do - destPath <- Cli.resolvePath' destPath' - whenNothingM (remoteMappingForPath pushPull destPath) do - 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 --- path. --- --- E.g. --- --- A config which maps: --- --- .myshare.foo -> .me.public.foo --- --- Will resolve the following local paths into share paths like so: --- --- .myshare.foo -> .me.public.foo --- .myshare.foo.bar -> .me.public.foo.bar --- .myshare.foo.bar.baz -> .me.public.foo.bar.baz --- .myshare -> -remoteMappingForPath :: PushPull -> Path.Absolute -> Cli (Maybe (WriteRemoteNamespace Void)) -remoteMappingForPath pushPull dest = do - pathPrefixes dest & Foldable.firstJustM \(prefix, suffix) -> do - let remoteMappingConfigKey = remoteMappingKey prefix - Cli.getConfig remoteMappingConfigKey >>= \case - Just url -> do - let parseResult = P.parse (UriParser.writeRemoteNamespaceWith empty) (Text.unpack remoteMappingConfigKey) url - in case parseResult of - Left err -> Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull dest url (show err)) - Right wrp -> do - let remote = wrp & RemoteRepo.remotePath_ %~ \p -> Path.resolve p suffix - in pure $ Just remote - Nothing -> pure Nothing - where - -- Produces a list of path prefixes and suffixes, from longest prefix to shortest - -- - -- E.g. - -- - -- >>> pathPrefixes ("a" :< "b" :< Path.absoluteEmpty) - -- fromList [(.a.b,),(.a,b),(.,a.b)] - pathPrefixes :: Path.Absolute -> Seq (Path.Absolute, Path.Path) - pathPrefixes p = - Path.unabsolute p - & Path.toSeq - & \seq -> - Seq.zip (Seq.inits seq) (Seq.tails seq) - & Seq.reverse - <&> bimap (Path.Absolute . Path.Path) (Path.Path) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index dd644b41b8..fec305abd3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -23,7 +23,6 @@ import Unison.Cli.Monad qualified as Cli 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 (resolveConfiguredUrl) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 25c7bdf25a..46b05773e0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -23,7 +23,6 @@ import Unison.Cli.Monad qualified as Cli 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.Editor.HandleInput.AuthLogin qualified as AuthLogin import Unison.Codebase.Editor.Input ( PushRemoteBranchInput (..), @@ -67,31 +66,17 @@ handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do case sourceTarget of -- push to - PushSourceTarget0 -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> do - localPath <- Cli.getCurrentPath - UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case - WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior - WriteRemoteProjectBranch v -> absurd v - Just (localProjectAndBranch, _restPath) -> - pushProjectBranchToProjectBranch - force - localProjectAndBranch - Nothing + PushSourceTarget0 -> do + localProjectAndBranch <- Cli.getCurrentProjectAndBranch + pushProjectBranchToProjectBranch force localProjectAndBranch Nothing -- push to .some.path (share) PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.getCurrentPath pushLooseCodeToShareLooseCode localPath namespace pushBehavior -- push to @some/project - PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> do - localPath <- Cli.getCurrentPath - remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 - pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - Just (localProjectAndBranch, _restPath) -> - pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) + PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do + localProjectAndBranch <- Cli.getCurrentProjectAndBranch + pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) -- push .some.path to .some.path (share) PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.resolvePath' localPath0 @@ -119,11 +104,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushBehavior.RequireEmpty -> False PushBehavior.RequireNonEmpty -> False --- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code"). -pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli () -pushLooseCodeToShareLooseCode _ _ _ = do - Cli.returnEarly LooseCodePushDeprecated - -- Push a local namespace ("loose code") to a remote project branch. pushLooseCodeToProjectBranch :: Bool -> Path.Absolute -> ProjectAndBranch ProjectName ProjectBranchName -> Cli () pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch = do diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index e6b5608e26..caaad9e9c8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -391,7 +391,6 @@ data Output | UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int) | UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment - | LooseCodePushDeprecated | MergeFailure !FilePath !MergeSourceAndTarget | MergeSuccess !MergeSourceAndTarget | MergeSuccessFastForward !MergeSourceAndTarget @@ -630,7 +629,6 @@ isFailure o = case o of ProjectHasNoReleases {} -> True UpgradeFailure {} -> True UpgradeSuccess {} -> False - LooseCodePushDeprecated -> True MergeFailure {} -> True MergeSuccess {} -> False MergeSuccessFastForward {} -> False diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 403d2f7e73..b1e9514515 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -47,7 +47,6 @@ library Unison.Cli.Share.Projects.Types Unison.Cli.TypeCheck Unison.Cli.UniqueTypeGuidLookup - Unison.Cli.UnisonConfigUtils Unison.Codebase.Editor.AuthorInfo Unison.Codebase.Editor.HandleInput Unison.Codebase.Editor.HandleInput.AddRun From 3f44257cd879e81d089f40199790fa1013f7264d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 09:47:09 -0700 Subject: [PATCH 40/76] Better project-branch centric utils --- unison-cli/src/Unison/Cli/MonadUtils.hs | 44 +++++++++---------- unison-cli/src/Unison/Cli/NamesUtils.hs | 13 ++++-- unison-cli/src/Unison/Cli/PrettyPrintUtils.hs | 7 +++ 3 files changed, 37 insertions(+), 27 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 6f104bf8ce..883113ca32 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -108,7 +108,6 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -398,7 +397,7 @@ stepManyAt :: [(Path.Absolute, Branch0 IO -> Branch0 IO)] -> Cli () stepManyAt pb reason actions = do - updateProjectBranchRoot_ reason pb $ Branch.stepManyAt (makeActionsUnabsolute actions) + updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions) stepManyAt' :: ProjectBranch -> @@ -408,7 +407,7 @@ stepManyAt' :: stepManyAt' pb reason actions = do origRoot <- getProjectBranchRoot pb newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot - didChange <- updateProjectBranchRoot reason pb (\oldRoot -> pure (newRoot, oldRoot /= newRoot)) + didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot)) pure didChange -- Like stepManyAt, but doesn't update the last saved root @@ -418,32 +417,34 @@ stepManyAtM :: [(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] -> Cli () stepManyAtM pb reason actions = do - updateProjectBranchRoot reason pb \oldRoot -> do + updateProjectBranchRoot pb reason \oldRoot -> do newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot) pure (newRoot, ()) -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAtM :: + ProjectBranch -> Text -> - ProjectPath -> + Path.Absolute -> (Branch IO -> Cli (Branch IO)) -> Cli Bool -updateAtM reason pp f = do - old <- getBranchFromProjectPath (pp & PP.absPath_ .~ Path.absoluteEmpty) - new <- Branch.modifyAtM (pp ^. PP.path_) f old - updateCurrentProjectBranchRoot reason (const new) - pure $ old /= new +updateAtM pb reason path f = do + oldRootBranch <- getProjectBranchRoot pb + newRootBranch <- Branch.modifyAtM (Path.unabsolute path) f oldRootBranch + updateProjectBranchRoot_ pb reason (const newRootBranch) + pure $ oldRootBranch /= newRootBranch -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAt :: + ProjectBranch -> Text -> - ProjectPath -> + Path.Absolute -> (Branch IO -> Branch IO) -> Cli Bool -updateAt reason p f = do - updateAtM reason p (pure . f) +updateAt pb reason p f = do + updateAtM pb reason p (pure . f) updateAndStepAt :: (Foldable f, Foldable g, Functor g) => @@ -457,15 +458,10 @@ updateAndStepAt reason projectBranch updates steps = do b & (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) & (Branch.stepManyAt (first Path.unabsolute <$> steps)) - updateProjectBranchRoot_ reason projectBranch f - -updateCurrentProjectBranchRoot :: Text -> (Branch IO -> Branch IO) -> Cli () -updateCurrentProjectBranchRoot reason f = do - pp <- getCurrentProjectPath - updateProjectBranchRoot_ reason (pp ^. #branch) f + updateProjectBranchRoot_ projectBranch reason f -updateProjectBranchRoot :: Text -> ProjectBranch -> (Branch IO -> Cli (Branch IO, r)) -> Cli r -updateProjectBranchRoot reason projectBranch f = do +updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r +updateProjectBranchRoot projectBranch reason f = do error "implement project-branch reflog" reason Cli.Env {codebase} <- ask Cli.time "updateProjectBranchRoot" do @@ -478,9 +474,9 @@ updateProjectBranchRoot reason projectBranch f = do setCurrentProjectRoot new pure result -updateProjectBranchRoot_ :: Text -> ProjectBranch -> (Branch IO -> Branch IO) -> Cli () -updateProjectBranchRoot_ reason projectBranch f = do - updateProjectBranchRoot reason projectBranch (\b -> pure (f b, ())) +updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () +updateProjectBranchRoot_ projectBranch reason f = do + updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ())) ------------------------------------------------------------------------------------------------------------------------ -- Getting terms diff --git a/unison-cli/src/Unison/Cli/NamesUtils.hs b/unison-cli/src/Unison/Cli/NamesUtils.hs index 0c8e5c1060..889e055bdf 100644 --- a/unison-cli/src/Unison/Cli/NamesUtils.hs +++ b/unison-cli/src/Unison/Cli/NamesUtils.hs @@ -1,12 +1,15 @@ -- | Utilities that have to do with constructing names objects. module Unison.Cli.NamesUtils ( currentNames, - projectRootNames, + currentProjectRootNames, + projectBranchNames, ) where +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import Unison.Cli.Monad (Cli) import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch import Unison.Names (Names) @@ -15,6 +18,10 @@ currentNames :: Cli Names currentNames = do Branch.toNames <$> Cli.getCurrentBranch0 -projectRootNames :: Cli Names -projectRootNames = do +currentProjectRootNames :: Cli Names +currentProjectRootNames = do Branch.toNames <$> Cli.getCurrentProjectRoot0 + +projectBranchNames :: ProjectBranch -> Cli Names +projectBranchNames pb = do + Branch.toNames . Branch.head <$> Cli.getProjectBranchRoot pb diff --git a/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs b/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs index 17abdd49c5..8ee18756f4 100644 --- a/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs +++ b/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs @@ -3,9 +3,11 @@ module Unison.Cli.PrettyPrintUtils ( prettyPrintEnvDeclFromNames, currentPrettyPrintEnvDecl, + projectBranchPPED, ) where +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.NamesUtils qualified as Cli @@ -14,6 +16,7 @@ import Unison.Names (Names) import Unison.Prelude import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo) +import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED -- | Builds a pretty print env decl from a names object. @@ -30,3 +33,7 @@ prettyPrintEnvDeclFromNames ns = currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl currentPrettyPrintEnvDecl = do Cli.currentNames >>= prettyPrintEnvDeclFromNames + +projectBranchPPED :: ProjectBranch -> Cli PPED.PrettyPrintEnvDecl +projectBranchPPED pb = do + Cli.projectBranchNames pb >>= prettyPrintEnvDeclFromNames From 276758fee39541d454bcea3efc84d43246830950 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 09:47:09 -0700 Subject: [PATCH 41/76] More command cleanups --- unison-cli/src/Unison/Cli/MonadUtils.hs | 19 +++++++++---------- unison-cli/src/Unison/Cli/Pretty.hs | 5 ++++- .../Codebase/Editor/HandleInput/InstallLib.hs | 7 +++++-- .../HandleInput/NamespaceDependencies.hs | 19 +++++++------------ .../Editor/HandleInput/ProjectClone.hs | 1 - .../Codebase/Editor/HandleInput/Update2.hs | 3 ++- .../src/Unison/Codebase/Editor/Output.hs | 5 +++-- .../src/Unison/CommandLine/OutputMessages.hs | 12 +----------- 8 files changed, 31 insertions(+), 40 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 883113ca32..a947d1e3f9 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -108,6 +108,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -424,27 +425,25 @@ stepManyAtM pb reason actions = do -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAtM :: - ProjectBranch -> Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool -updateAtM pb reason path f = do - oldRootBranch <- getProjectBranchRoot pb - newRootBranch <- Branch.modifyAtM (Path.unabsolute path) f oldRootBranch - updateProjectBranchRoot_ pb reason (const newRootBranch) +updateAtM reason pp f = do + oldRootBranch <- getProjectBranchRoot (pp ^. #branch) + newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch + updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch) pure $ oldRootBranch /= newRootBranch -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAt :: - ProjectBranch -> Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Branch IO) -> Cli Bool -updateAt pb reason p f = do - updateAtM pb reason p (pure . f) +updateAt reason pp f = do + updateAtM reason pp (pure . f) updateAndStepAt :: (Foldable f, Foldable g, Functor g) => diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index aa78c1ffcf..c45ca85011 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -346,7 +346,10 @@ prettyTypeName ppe r = prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case WhichBranchEmptyHash hash -> P.shown hash - WhichBranchEmptyPath path -> prettyPath' path + WhichBranchEmptyPath p -> + case p of + Left pp -> prettyProjectPath pp + Right path' -> prettyPath' path' -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef displayBranchHash :: CausalHash -> Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 426a457f66..52e70188c8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -20,6 +20,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Core.Project (ProjectBranchName) import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment (libSegment) @@ -69,7 +70,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran -- -- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3". libdepNameSegment :: NameSegment <- do - currentBranchObject <- Cli.getProjectRoot0 + currentBranchObject <- Cli.getCurrentProjectRoot0 pure $ fresh (\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText) @@ -83,7 +84,9 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment] let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames - _didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject) + pp <- Cli.getCurrentProjectPath + let libDepPP = pp & PP.absPath_ .~ libdepPath + _didUpdate <- Cli.updateAt reflogDescription libDepPP (\_empty -> remoteBranchObject) Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 098870a301..66f3f0c3af 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -14,7 +14,6 @@ import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path import Unison.DataDeclaration qualified as DD @@ -22,7 +21,6 @@ import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.NameSegment qualified as NameSegment -import Unison.Names qualified as Names import Unison.Prelude import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference qualified as Reference @@ -35,19 +33,16 @@ import Unison.Util.Relation qualified as Relation handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli () handleNamespaceDependencies namespacePath' = do Cli.Env {codebase} <- ask - path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath' + pp <- maybe Cli.getCurrentProjectPath Cli.resolvePath' namespacePath' + let pb = pp ^. #branch branch <- - Cli.getMaybeBranch0FromProjectRootPath path & onNothingM do - Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path))) + Cli.getMaybeBranch0FromProjectPath pp & onNothingM do + Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Left pp))) externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) - currentPPED <- Cli.currentPrettyPrintEnvDecl - rootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getProjectRoot0 - rootPPED <- Cli.prettyPrintEnvDeclFromNames rootNames - -- We explicitly include a global unsuffixified fallback on namespace dependencies since - -- the things we want names for are obviously outside of our scope. - let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback rootPPED currentPPED - Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies + pped <- Cli.projectBranchPPED pb + let ppe = PPED.unsuffixifiedPPE pped + Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies -- | Check the dependencies of all types and terms in the current namespace, -- returns a map of dependencies which do not have a name within the current namespace, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 5e9de5085a..6a611c913c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -17,7 +17,6 @@ import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli (updateAt) -import Unison.Cli.ProjectUtils (projectBranchPath) import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase qualified as Codebase diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 93c3a29b93..d7ee79afd1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -205,7 +205,8 @@ saveTuf getConstructors tuf = do Cli.runTransactionWithRollback \abort -> do Codebase.addDefsToCodebase codebase tuf typecheckedUnisonFileToBranchUpdates abort getConstructors tuf - Cli.stepAt "update" (currentPath, Branch.batchUpdates branchUpdates) + pb <- Cli.getCurrentProjectBranch + Cli.stepAt pb "update" (currentPath, Branch.batchUpdates branchUpdates) -- @typecheckedUnisonFileToBranchUpdates getConstructors file@ returns a list of branch updates (suitable for passing -- along to `batchUpdates` or some "step at" combinator) that corresponds to using all of the contents of @file@. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index caaad9e9c8..ff7f44c325 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -41,6 +41,7 @@ import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) @@ -138,7 +139,7 @@ data NumberedOutput | -- | List all direct dependencies which don't have any names in the current branch ListNamespaceDependencies PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace. - Path.Absolute -- The namespace we're checking dependencies for. + ProjectPath -- The namespace we're checking dependencies for. (Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents. data AmbiguousReset'Argument @@ -425,7 +426,7 @@ data CreatedProjectBranchFrom -- | A branch was empty. But how do we refer to that branch? data WhichBranchEmpty = WhichBranchEmptyHash ShortCausalHash - | WhichBranchEmptyPath Path' + | WhichBranchEmptyPath (Either ProjectPath Path') data ShareError = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index b9d50a373d..5645ce7458 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -494,7 +494,7 @@ notifyNumbered = \case absPath0 = Path.Absolute path ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty) ListNamespaceDependencies ppe path' externalDependencies -> - ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $ + ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyProjectPath path') $ List.intersperse spacer (externalDepsTable externalDependencies), numberedArgs ) @@ -2068,16 +2068,6 @@ notifyUser dir = \case <> P.group (P.text (NameSegment.toEscapedText new) <> ",") <> "and removed" <> P.group (P.text (NameSegment.toEscapedText old) <> ".") - LooseCodePushDeprecated -> - pure . P.warnCallout $ - P.lines $ - [ P.wrap $ "Unison Share's projects are now the new preferred way to store code, and storing code outside of a project has been deprecated.", - "", - P.wrap $ "Learn how to convert existing code into a project using this guide: ", - "https://www.unison-lang.org/docs/tooling/projects-library-migration/", - "", - "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 aliceAndBob -> pure . P.wrap $ "I couldn't automatically merge" From 3aa8fccea61eff31c34d1c3a498ad5ab8849eecc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 10:12:01 -0700 Subject: [PATCH 42/76] Fix up Project Clone --- .../U/Codebase/Sqlite/Queries.hs | 5 +- .../Editor/HandleInput/ProjectClone.hs | 140 ++++++++---------- 2 files changed, 66 insertions(+), 79 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a896cbcea8..80fcc36ae7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3687,8 +3687,9 @@ loadProjectAndBranchNames projectId branchId = |] -- | Insert a project branch. -insertProjectBranch :: CausalHashId -> ProjectBranch -> Transaction () -insertProjectBranch causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do +insertProjectBranch :: Text -> CausalHashId -> ProjectBranch -> Transaction () +insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do + error "Implement Project Reflog on creation" description execute [sql| INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 6a611c913c..c3d5f25cd6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -5,23 +5,21 @@ module Unison.Codebase.Editor.HandleInput.ProjectClone where import Control.Lens (_2) -import Control.Monad.Reader (ask) import Data.These (These (..)) import Data.UUID.V4 qualified as UUID import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) import U.Codebase.Sqlite.DbId qualified as Sqlite import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli (updateAt) +import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch) import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share -import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path (Path) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug) import Unison.Sqlite qualified as Sqlite @@ -38,9 +36,9 @@ data RemoteProjectKey -- | Clone a remote branch. handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli () handleClone remoteNames0 maybeLocalNames0 = do - maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch - resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0 - localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0 + currentProjectBranch <- Cli.getCurrentProjectAndBranch + resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0 + localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0 cloneInto localNames1 resolvedRemoteNames.branch data ResolvedRemoteNames = ResolvedRemoteNames @@ -77,63 +75,59 @@ data ResolvedRemoteNamesFrom -- otherwise abort resolveRemoteNames :: Share.IncludeSquashedHead -> - Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) -> + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> ProjectAndBranchNames -> Cli ResolvedRemoteNames -resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case - ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> - case maybeCurrentProjectBranch of - Nothing -> resolveP remoteProjectName - Just (currentProjectAndBranch, _path) -> - case projectNameUserSlug remoteProjectName of - Nothing -> resolveB remoteBranchName - Just _ -> - Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case - Nothing -> resolveP remoteProjectName - Just remoteBranchProjectId -> do - -- Fetching these in parallel would be an improvement - maybeRemoteProject <- Share.getProjectByName remoteProjectName - maybeRemoteBranch <- - Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case - Share.GetProjectBranchResponseBranchNotFound -> Nothing - Share.GetProjectBranchResponseProjectNotFound -> Nothing - Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch - case (maybeRemoteProject, maybeRemoteBranch) of - (Just remoteProject, Nothing) -> do - let remoteProjectId = remoteProject.projectId - let remoteProjectName = remoteProject.projectName - let remoteBranchName = unsafeFrom @Text "main" - remoteBranch <- - ProjectUtils.expectRemoteProjectBranchByName - includeSquashed - (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) - pure - ResolvedRemoteNames - { branch = remoteBranch, - from = ResolvedRemoteNamesFrom'Project - } - (Nothing, Just remoteBranch) -> - pure - ResolvedRemoteNames - { branch = remoteBranch, - from = ResolvedRemoteNamesFrom'Branch - } - -- Treat neither existing and both existing uniformly as "ambiguous input" - -- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating - -- wouldn't help, because we did enough work to know neither thing exists" - _ -> do - branchProjectName <- - Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri) - Cli.returnEarly $ - Output.AmbiguousCloneRemote - remoteProjectName - (ProjectAndBranch branchProjectName remoteBranchName) +resolveRemoteNames includeSquashed currentProjectAndBranch = \case + ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do + case projectNameUserSlug remoteProjectName of + Nothing -> resolveB remoteBranchName + Just _ -> + Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case + Nothing -> resolveP remoteProjectName + Just remoteBranchProjectId -> do + -- Fetching these in parallel would be an improvement + maybeRemoteProject <- Share.getProjectByName remoteProjectName + maybeRemoteBranch <- + Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case + Share.GetProjectBranchResponseBranchNotFound -> Nothing + Share.GetProjectBranchResponseProjectNotFound -> Nothing + Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch + case (maybeRemoteProject, maybeRemoteBranch) of + (Just remoteProject, Nothing) -> do + let remoteProjectId = remoteProject.projectId + let remoteProjectName = remoteProject.projectName + let remoteBranchName = unsafeFrom @Text "main" + remoteBranch <- + ProjectUtils.expectRemoteProjectBranchByName + includeSquashed + (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) + pure + ResolvedRemoteNames + { branch = remoteBranch, + from = ResolvedRemoteNamesFrom'Project + } + (Nothing, Just remoteBranch) -> + pure + ResolvedRemoteNames + { branch = remoteBranch, + from = ResolvedRemoteNamesFrom'Branch + } + -- Treat neither existing and both existing uniformly as "ambiguous input" + -- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating + -- wouldn't help, because we did enough work to know neither thing exists" + _ -> do + branchProjectName <- + Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri) + Cli.returnEarly $ + Output.AmbiguousCloneRemote + remoteProjectName + (ProjectAndBranch branchProjectName remoteBranchName) ProjectAndBranchNames'Unambiguous (This p) -> resolveP p ProjectAndBranchNames'Unambiguous (That b) -> resolveB b ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b where resolveB branchName = do - (currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch) remoteProjectId <- Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch) @@ -180,11 +174,11 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case -- `clone @foo/bar` resulted in treating `@foo/bar` as a contributor branch of the current project, then it is as if -- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`. resolveLocalNames :: - Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) -> + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> ResolvedRemoteNames -> Maybe ProjectAndBranchNames -> Cli (ProjectAndBranch LocalProjectKey ProjectBranchName) -resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames = +resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames = resolve case maybeLocalNames of Nothing -> ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of @@ -198,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames resolve names = case names of - ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> - case maybeCurrentProjectBranch of - Nothing -> resolveP localProjectName - Just (ProjectAndBranch currentProject _, _path) -> do - Cli.returnEarly $ - Output.AmbiguousCloneLocal - (ProjectAndBranch localProjectName remoteBranchName) - (ProjectAndBranch currentProject.name localBranchName) + ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do + Cli.returnEarly $ + Output.AmbiguousCloneLocal + (ProjectAndBranch localProjectName remoteBranchName) + (ProjectAndBranch currentProject.name localBranchName) ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName @@ -214,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames go (LocalProjectKey'Name localProjectName) remoteBranchName resolveB localBranchName = do - (ProjectAndBranch currentProject _, _path) <- - maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch) go (LocalProjectKey'Project currentProject) localBranchName resolvePB localProjectName localBranchName = @@ -253,13 +242,14 @@ cloneInto localProjectBranch remoteProjectBranch = do pure (localProjectId, localProjectName) Right localProject -> pure (localProject.projectId, localProject.name) localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) + causalHashId <- Q.expectCausalHashIdByCausalHash branchHead Queries.insertProjectBranch + causalHashId Sqlite.ProjectBranch { projectId = localProjectId, branchId = localBranchId, name = localProjectBranch.branch, - parentBranchId = Nothing, - rootCausalHash = error "Add causal hash id in cloneInto" + parentBranchId = Nothing } Queries.insertBranchRemoteMapping localProjectId @@ -277,12 +267,8 @@ cloneInto localProjectBranch remoteProjectBranch = do localProjectBranch.branch ) - -- Manipulate the root namespace and cd - Cli.Env {codebase} <- ask - theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead) - let path = projectBranchPath (over #project fst localProjectAndBranch) - Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch) - Cli.cd path + let newProjectAndBranch = (over #project fst localProjectAndBranch) + Cli.switchProject newProjectAndBranch -- Return the remote project id associated with the given project branch loadAssociatedRemoteProjectId :: From c42d128371767d49a94c303caeb6641d3974f9e2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 10:19:51 -0700 Subject: [PATCH 43/76] Fix up ProjectCreate --- .../U/Codebase/Sqlite/Queries.hs | 15 ++++-- .../Editor/HandleInput/ProjectCreate.hs | 53 +++++++++---------- 2 files changed, 37 insertions(+), 31 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 80fcc36ae7..08cd1fe977 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3688,8 +3688,12 @@ loadProjectAndBranchNames projectId branchId = -- | Insert a project branch. insertProjectBranch :: Text -> CausalHashId -> ProjectBranch -> Transaction () -insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do - error "Implement Project Reflog on creation" description +insertProjectBranch _description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do + -- Ensure we never point at a causal we don't have the branch for. + _ <- expectBranchObjectIdByCausalHashId causalHashId + + error "Implement project branch reflog" + execute [sql| INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) @@ -3774,8 +3778,11 @@ deleteProjectBranch projectId branchId = do |] -- | Set project branch HEAD -setProjectBranchHead :: ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () -setProjectBranchHead projectId branchId causalHashId = +setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () +setProjectBranchHead _description projectId branchId causalHashId = do + error "Implement project branch reflog" + -- Ensure we never point at a causal we don't have the branch for. + _ <- expectBranchObjectIdByCausalHashId causalHashId execute [sql| UPDATE project_branch diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index d986ee68ee..f2c72f3371 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate ) where +import Control.Lens import Control.Monad.Reader (ask) -import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.UUID.V4 qualified as UUID import System.Random.Shuffle qualified as RandomShuffle import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.MonadUtils qualified as Cli (stepAt) import Unison.Cli.Share.Projects qualified as Share import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Causal qualified as Causal import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) @@ -126,42 +126,41 @@ projectCreate tryDownloadingBase maybeProjectName = do pure maybeBaseLatestReleaseBranchObject else pure Nothing - let projectBranchObject = - case maybeBaseLatestReleaseBranchObject of - Nothing -> Branch.empty0 - Just baseLatestReleaseBranchObject -> - let -- lib.base - projectBranchLibBaseObject = - over - Branch.children - (Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject) - Branch.empty0 - projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty - in over - Branch.children - (Map.insert NameSegment.libSegment projectBranchLibObject) - Branch.empty0 - - Cli.stepAt reflogDescription (Path.absoluteEmpty, const projectBranchObject) + for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do + -- lib.base + let projectBranchLibBaseObject = + Branch.empty0 + & Branch.children + . at NameSegment.baseSegment + .~ Just baseLatestReleaseBranchObject + projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty + let branchWithBase = + Branch.empty + & Branch.history + . Causal.head_ + . Branch.children + . at NameSegment.libSegment + .~ Just projectBranchLibObject + Cli.Env {codebase} <- ask + liftIO $ Codebase.putBranch codebase branchWithBase + Cli.runTransaction $ do + baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase) + Queries.setProjectBranchHead "Include latest base library" projectId branchId baseBranchCausalHashId Cli.respond Output.HappyCoding pure ProjectAndBranch {project = projectId, branch = branchId} - where - reflogDescription = - case maybeProjectName of - Nothing -> "project.create" - Just projectName -> "project.create " <> into @Text projectName insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> CausalHashId -> Sqlite.Transaction () insertProjectAndBranch projectId projectName branchId branchName chId = do Queries.insertProject projectId projectName Queries.insertProjectBranch + "Project Created" + chId Sqlite.ProjectBranch { projectId, branchId, name = branchName, - parentBranchId = Nothing, - causalHashId = chId + parentBranchId = Nothing } Queries.setMostRecentBranch projectId branchId From b663d44b50039d0c188dfb68a9b0e55fbe9ffe63 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 10:45:20 -0700 Subject: [PATCH 44/76] Finish cleaning up create branch --- unison-cli/src/Unison/Cli/MonadUtils.hs | 3 +- .../Codebase/Editor/HandleInput/Branch.hs | 79 +++++++++---------- .../Codebase/Editor/HandleInput/Upgrade.hs | 28 +++---- 3 files changed, 53 insertions(+), 57 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index a947d1e3f9..94ec894c04 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -461,7 +461,6 @@ updateAndStepAt reason projectBranch updates steps = do updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r updateProjectBranchRoot projectBranch reason f = do - error "implement project-branch reflog" reason Cli.Env {codebase} <- ask Cli.time "updateProjectBranchRoot" do old <- getProjectBranchRoot projectBranch @@ -469,7 +468,7 @@ updateProjectBranchRoot projectBranch reason f = do liftIO $ Codebase.putBranch codebase new Cli.runTransaction $ do causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) - Q.setProjectBranchHead (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId + Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId setCurrentProjectRoot new pure result diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 1533d56ec6..bfd5efbd09 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,8 +1,7 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch ( handleBranch, - createBranchFromParent, - createBranchFromNamespace, + createBranch, ) where @@ -11,7 +10,6 @@ import Data.UUID.V4 qualified as UUID import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) -import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries @@ -29,6 +27,12 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) import Unison.Sqlite qualified as Sqlite +data CreateFrom + = CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO) + | CreateFrom'ParentBranch Sqlite.ProjectBranch + | CreateFrom'Namespace (Branch IO) + | CreateFrom'Nothingness + -- | Create a new project branch from an existing project branch or namespace. handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do @@ -61,7 +65,13 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB pp <- Cli.getCurrentProjectPath Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- createBranchFromParent (view #branch <$> maySrcProjectAndBranch) destProject newBranchName + case maySrcProjectAndBranch of + Just srcProjectAndBranch -> do + let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name)) + void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject newBranchName + Nothing -> do + let description = "Empty branch created" + void $ createBranch description CreateFrom'Nothingness destProject newBranchName Cli.respond $ Output.CreatedProjectBranch @@ -83,14 +93,33 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB -- @release.draft@ command, which essentially just creates a branch, but with some different output for the user. -- -- Returns the branch id of the newly-created branch. -createBranchFromParent :: - -- If no parent branch is provided, make an empty branch. - Maybe Sqlite.ProjectBranch -> +createBranch :: + Text -> + CreateFrom -> Sqlite.Project -> ProjectBranchName -> Cli ProjectBranchId -createBranchFromParent mayParentBranch project newBranchName = do +createBranch description createFrom project newBranchName = do let projectId = project ^. #projectId + Cli.Env {codebase} <- ask + (mayParentBranchId, newBranchCausalHashId) <- case createFrom of + CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do + Q.expectProjectBranchHead projectId (parentBranch ^. #branchId) + newBranchCausalHashId <- Q.expectProjectBranchHead projectId (parentBranch ^. #branchId) + pure (Just (parentBranch ^. #branchId), newBranchCausalHashId) + CreateFrom'Nothingness -> Cli.runTransaction do + (_, causalHashId) <- Codebase.emptyCausalHash + pure (Nothing, causalHashId) + CreateFrom'NamespaceWithParent parentBranch namespace -> do + liftIO $ Codebase.putBranch codebase namespace + Cli.runTransaction $ do + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash namespace) + pure (Just (parentBranch ^. #branchId), newBranchCausalHashId) + CreateFrom'Namespace branch -> do + liftIO $ Codebase.putBranch codebase branch + Cli.runTransaction $ do + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch) + pure (Nothing, newBranchCausalHashId) newBranchId <- Cli.runTransactionWithRollback \rollback -> do Queries.projectBranchExistsByName projectId newBranchName >>= \case @@ -99,46 +128,16 @@ createBranchFromParent mayParentBranch project newBranchName = do -- Here, we are forking to `foo/bar`, where project `foo` does exist, and it does not have a branch named -- `bar`, so the fork will succeed. newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) - newBranchCausalHashId <- - (for mayParentBranch (\ProjectBranch {projectId, branchId} -> Q.expectProjectBranchHead projectId branchId)) `whenNothingM` do - (_, causalHashId) <- Codebase.emptyCausalHash - pure causalHashId Queries.insertProjectBranch + description newBranchCausalHashId Sqlite.ProjectBranch { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = ProjectBranch.branchId <$> mayParentBranch + parentBranchId = mayParentBranchId } pure newBranchId Cli.switchProject (ProjectAndBranch projectId newBranchId) pure newBranchId - -createBranchFromNamespace :: Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> Branch IO -> Cli ProjectBranchId -createBranchFromNamespace project getBranchName branch = do - let projectId = project ^. #projectId - Cli.Env {codebase} <- ask - let causalHash = Branch.headHash branch - liftIO $ Codebase.putBranch codebase branch - newBranchId <- - Cli.runTransactionWithRollback \rollback -> do - branchName <- getBranchName - Queries.projectBranchExistsByName projectId branchName >>= \case - True -> rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch (project ^. #name) branchName)) - False -> do - newProjectBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) - newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash causalHash - Queries.insertProjectBranch - newBranchCausalHashId - Sqlite.ProjectBranch - { projectId, - branchId = newProjectBranchId, - name = branchName, - parentBranchId = Nothing - } - pure newProjectBranchId - - Cli.switchProject (ProjectAndBranch projectId newBranchId) - pure newBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 9a5cd88787..5b816c87b7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -11,8 +11,6 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Text.Builder qualified import U.Codebase.Sqlite.DbId (ProjectId) -import U.Codebase.Sqlite.Project qualified -import U.Codebase.Sqlite.ProjectBranch qualified import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli @@ -34,6 +32,7 @@ import Unison.Codebase.Editor.HandleInput.Update2 ) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name @@ -46,7 +45,7 @@ import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback) -import Unison.Project (ProjectAndBranch (..), ProjectBranchName) +import Unison.Project (ProjectBranchName) import Unison.Reference (TermReference, TypeReference) import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -69,7 +68,7 @@ handleUpgrade oldName newName = do let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName]) let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName]) - currentNamespace <- Cli.getProjectRoot0 + currentNamespace <- Cli.getCurrentProjectRoot0 let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld @@ -77,7 +76,7 @@ handleUpgrade oldName newName = do let currentLocalConstructorNames = forwardCtorNames currentLocalNames let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld - oldNamespace <- Cli.expectBranch0AtPath' oldPath + oldNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' oldPath) let oldLocalNamespace = Branch.deleteLibdeps oldNamespace let oldLocalTerms = Branch.deepTerms oldLocalNamespace let oldLocalTypes = Branch.deepTypes oldLocalNamespace @@ -85,7 +84,7 @@ handleUpgrade oldName newName = do let oldDeepMinusLocalTerms = Branch.deepTerms oldNamespaceMinusLocal let oldDeepMinusLocalTypes = Branch.deepTypes oldNamespaceMinusLocal - newNamespace <- Cli.expectBranch0AtPath' newPath + newNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' newPath) let newLocalNamespace = Branch.deleteLibdeps newNamespace let newLocalTerms = Branch.deepTerms newLocalNamespace let newLocalTypes = Branch.deepTypes newLocalNamespace @@ -149,27 +148,26 @@ handleUpgrade oldName newName = do `PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents ) - parsingEnv <- makeParsingEnv projectPath currentDeepNamesSansOld + pp@(PP.ProjectPath project branch pathInProject) <- Cli.getCurrentProjectPath + parsingEnv <- makeParsingEnv pathInProject currentDeepNamesSansOld typecheckedUnisonFile <- prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do -- Small race condition: since picking a branch name and creating the branch happen in different -- transactions, creating could fail. - temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName projectId oldName newName) + temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName (project ^. #projectId) oldName newName) temporaryBranchId <- - HandleInput.Branch.doCreateBranch - (HandleInput.Branch.CreateFrom'Branch projectAndBranch) - projectAndBranch.project - temporaryBranchName + HandleInput.Branch.createBranchFromParent textualDescriptionOfUpgrade - let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId)) - Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld) + (Just branch) + project + temporaryBranchName scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" Just (file, _) -> file liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) Cli.returnEarly $ - Output.UpgradeFailure projectAndBranch.branch.name temporaryBranchName scratchFilePath oldName newName + Output.UpgradeFailure branch.name temporaryBranchName scratchFilePath oldName newName branchUpdates <- Cli.runTransactionWithRollback \abort -> do From 16dea7af6f7452cc655975a5b0175a3062586a2d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 11:37:21 -0700 Subject: [PATCH 45/76] Fix up Merge --- unison-cli/src/Unison/Cli/MonadUtils.hs | 1 + .../Unison/Codebase/Editor/HandleInput/Branch.hs | 12 +++++++----- .../Unison/Codebase/Editor/HandleInput/Merge2.hs | 16 ++++++++-------- 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 94ec894c04..f80a916a0a 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -52,6 +52,7 @@ module Unison.Cli.MonadUtils stepManyAt, stepManyAtM, updateProjectBranchRoot, + updateProjectBranchRoot_, updateAtM, updateAt, updateAndStepAt, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index bfd5efbd09..d320fe04b3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,6 +1,7 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch - ( handleBranch, + ( CreateFrom (..), + handleBranch, createBranch, ) where @@ -68,10 +69,10 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB case maySrcProjectAndBranch of Just srcProjectAndBranch -> do let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name)) - void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject newBranchName + void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName) Nothing -> do let description = "Empty branch created" - void $ createBranch description CreateFrom'Nothingness destProject newBranchName + void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName) Cli.respond $ Output.CreatedProjectBranch @@ -97,9 +98,9 @@ createBranch :: Text -> CreateFrom -> Sqlite.Project -> - ProjectBranchName -> + Sqlite.Transaction ProjectBranchName -> Cli ProjectBranchId -createBranch description createFrom project newBranchName = do +createBranch description createFrom project getNewBranchName = do let projectId = project ^. #projectId Cli.Env {codebase} <- ask (mayParentBranchId, newBranchCausalHashId) <- case createFrom of @@ -122,6 +123,7 @@ createBranch description createFrom project newBranchName = do pure (Nothing, newBranchCausalHashId) newBranchId <- Cli.runTransactionWithRollback \rollback -> do + newBranchName <- getNewBranchName Queries.projectBranchExistsByName projectId newBranchName >>= \case True -> rollback (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch (project ^. #name) newBranchName)) False -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 82a82ee74e..1837bbf459 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -42,7 +42,6 @@ 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 Q import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Builtin.Decls qualified as Builtin.Decls import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..)) @@ -411,10 +410,12 @@ doMerge info = do Nothing -> do Cli.Env {writeSource} <- ask _temporaryBranchId <- - HandleInput.Branch.createBranchFromNamespace + HandleInput.Branch.createBranch + info.description + (HandleInput.Branch.CreateFrom'Namespace (Branch.mergeNode stageOneBranch parents.alice parents.bob)) info.alice.projectAndBranch.project (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) - (Branch.mergeNode stageOneBranch parents.alice parents.bob) + scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" @@ -424,11 +425,10 @@ doMerge info = do Just tuf -> do Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - _ <- - Cli.updateProjectBranchRoot - info.alice.projectAndBranch - (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) - info.description + Cli.updateProjectBranchRoot_ + info.alice.projectAndBranch.branch + info.description + (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) Cli.respond (Output.MergeSuccess mergeSourceAndTarget) doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () From e24a5ee3275b31514591237662590b1f0ae83051 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 11:45:25 -0700 Subject: [PATCH 46/76] More command fixups --- unison-cli/src/Unison/Cli/ProjectUtils.hs | 1 + .../Codebase/Editor/HandleInput/MoveTerm.hs | 3 +- .../Codebase/Editor/HandleInput/MoveType.hs | 3 +- .../Editor/HandleInput/ProjectClone.hs | 2 + .../Editor/HandleInput/ProjectRename.hs | 11 ++--- .../Editor/HandleInput/ProjectSwitch.hs | 43 +++++++++---------- .../Unison/Codebase/Editor/HandleInput/UI.hs | 38 ++-------------- .../src/Unison/CommandLine/InputPatterns.hs | 1 - 8 files changed, 36 insertions(+), 66 deletions(-) diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 37cb496811..11aeba7a00 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -11,6 +11,7 @@ module Unison.Cli.ProjectUtils -- * Loading local project info expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, + getProjectAndBranchByNames, expectProjectAndBranchByTheseNames, getProjectBranchCausalHash, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs index 4ea6aa3489..145efcc826 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs @@ -42,5 +42,6 @@ doMoveTerm src' dest' description = do steps <- moveTermSteps src' dest' when (null steps) do Cli.returnEarly (Output.TermNotFound src') - Cli.stepManyAt description steps + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs index c4ff4a5a01..8dfdf20a41 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveType.hs @@ -42,5 +42,6 @@ doMoveType src' dest' description = do steps <- moveTypeSteps src' dest' when (null steps) do Cli.returnEarly (Output.TypeNotFound src') - Cli.stepManyAt description steps + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description steps Cli.respond Output.Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index c3d5f25cd6..8a872d18b8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -243,7 +243,9 @@ cloneInto localProjectBranch remoteProjectBranch = do Right localProject -> pure (localProject.projectId, localProject.name) localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) causalHashId <- Q.expectCausalHashIdByCausalHash branchHead + let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName) Queries.insertProjectBranch + description causalHashId Sqlite.ProjectBranch { projectId = localProjectId, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs index f7d960d2df..117f12bb80 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs @@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename ) where +import U.Codebase.Sqlite.Project (Project (..)) 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.Cli.MonadUtils qualified as Cli import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude -import Unison.Project (ProjectName) +import Unison.Project (ProjectAndBranch (..), ProjectName) handleProjectRename :: ProjectName -> Cli () handleProjectRename newName = do - project <- ProjectUtils.expectCurrentProject - let oldName = project ^. #name + ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch + let oldName = project.name when (oldName /= newName) do Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectByName newName >>= \case Just _ -> rollback (Output.ProjectNameAlreadyExists newName) - Nothing -> Queries.renameProject (project ^. #projectId) newName + Nothing -> Queries.renameProject project.projectId newName Cli.respond (Output.RenamedProject oldName newName) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index c2fcd4a260..3aaf801e8c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -1,16 +1,15 @@ -- | @switch@ input handler module Unison.Codebase.Editor.HandleInput.ProjectSwitch ( projectSwitch, - switchToProjectBranch, ) where import Data.These (These (..)) -import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) -import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.Project (Project (..)) 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.Editor.Output qualified as Output import Unison.Prelude @@ -29,24 +28,22 @@ import Witch (unsafeFrom) projectSwitch :: ProjectAndBranchNames -> Cli () projectSwitch projectNames = do case projectNames of - ProjectAndBranchNames'Ambiguous projectName branchName -> - ProjectUtils.getCurrentProjectBranch >>= \case - Nothing -> switchToProjectAndBranchByTheseNames (This projectName) - Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do - (projectExists, branchExists) <- - Cli.runTransaction do - (,) - <$> Queries.projectExistsByName projectName - <*> Queries.projectBranchExistsByName currentProject.projectId branchName - case (projectExists, branchExists) of - (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) - (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName) - (True, False) -> switchToProjectAndBranchByTheseNames (This projectName) - (True, True) -> - Cli.respondNumbered $ - Output.AmbiguousSwitch - projectName - (ProjectAndBranch currentProject.name branchName) + ProjectAndBranchNames'Ambiguous projectName branchName -> do + ProjectAndBranch currentProject _currentBranch <- Cli.getCurrentProjectAndBranch + (projectExists, branchExists) <- + Cli.runTransaction do + (,) + <$> Queries.projectExistsByName projectName + <*> Queries.projectBranchExistsByName currentProject.projectId branchName + case (projectExists, branchExists) of + (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) + (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName) + (True, False) -> switchToProjectAndBranchByTheseNames (This projectName) + (True, True) -> + Cli.respondNumbered $ + Output.AmbiguousSwitch + projectName + (ProjectAndBranch currentProject.name branchName) ProjectAndBranchNames'Unambiguous projectAndBranchNames0 -> switchToProjectAndBranchByTheseNames projectAndBranchNames0 @@ -62,7 +59,7 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do Nothing -> do let branchName = unsafeFrom @Text "main" Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) Just branchId -> Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case Nothing -> error "impossible" @@ -72,4 +69,4 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectBranchByNames projectName branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId) + Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs index 9a6c5dcb3f..b80d161674 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs @@ -11,13 +11,10 @@ import U.Codebase.Reference qualified as V2 (Reference) import U.Codebase.Referent qualified as V2 (Referent) import U.Codebase.Referent qualified as V2.Referent import U.Codebase.Sqlite.Project qualified as Project -import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite 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 Project import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path @@ -42,10 +39,10 @@ openUI path' = do defnPath <- Cli.resolvePath' path' pp <- Cli.getCurrentProjectPath whenJust serverBaseUrl \url -> do - openUIForProject url pp defnPath + openUIForProject url pp (defnPath ^. PP.absPath_) openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli () -openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath = do +openUIForProject url pp@(PP.ProjectPath project projectBranch perspective) defnPath = do mayDefinitionRef <- getDefinitionRef perspective let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch) _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url @@ -59,7 +56,7 @@ openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath fqn <- hoistMaybe $ do - pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot) + pathFromPerspective <- List.stripPrefix (Path.toList (Path.unabsolute perspective)) (Path.toList $ Path.unabsolute defnPath) Path.toName . Path.fromList $ pathFromPerspective def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn pure def @@ -77,35 +74,6 @@ getTermOrTypeRef codebase namespaceBranch fqn = runMaybeT $ do pure (toTypeReference fqn oneType) terms <|> types -openUIForLooseCode :: Server.BaseUrl -> Path.Path' -> Cli () -openUIForLooseCode url path' = do - Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath - (perspective, definitionRef) <- getUIUrlParts currentPath path' codebase - _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.LooseCodeUI perspective definitionRef) url - pure () - -getUIUrlParts :: Path.Absolute -> Path.Path' -> Codebase m Symbol Ann -> Cli (Path.Absolute, Maybe (Server.DefinitionReference)) -getUIUrlParts startPath definitionPath' codebase = do - let absPath = Path.resolve startPath definitionPath' - let perspective = - if Path.isAbsolute definitionPath' - then Path.absoluteEmpty - else startPath - case Lens.unsnoc absPath of - Just (abs, _nameSeg) -> do - namespaceBranch <- - Cli.runTransaction - (Codebase.getShallowBranchAtPath (Path.unabsolute abs) Nothing) - mayDefRef <- runMaybeT do - name <- hoistMaybe $ Path.toName $ Path.fromPath' definitionPath' - MaybeT $ getTermOrTypeRef codebase namespaceBranch name - case mayDefRef of - Nothing -> pure (absPath, Nothing) - Just defRef -> pure (perspective, Just defRef) - Nothing -> - pure (absPath, Nothing) - toTypeReference :: Name -> V2.Reference -> Server.DefinitionReference toTypeReference name reference = Server.TypeReference $ diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 03d1343936..b5b2787344 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -165,7 +165,6 @@ import Unison.Cli.Pretty prettySlashProjectBranchName, prettyURI, ) -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Merge qualified as Branch From e65f6e19685c679dec715ab88b6e555e23637e4e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 12:05:59 -0700 Subject: [PATCH 47/76] Remove ability to push loose code paths (local or on share) --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 41 +------------------ unison-cli/src/Unison/Cli/Pretty.hs | 17 +------- .../Codebase/Editor/HandleInput/Push.hs | 24 ++--------- .../src/Unison/Codebase/Editor/Input.hs | 6 +-- .../src/Unison/Codebase/Editor/Output.hs | 6 +-- .../src/Unison/Codebase/Editor/UriParser.hs | 28 +------------ 6 files changed, 11 insertions(+), 111 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index a3d5c63f51..bd352cbc26 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -1,8 +1,5 @@ module Unison.Codebase.Editor.RemoteRepo where -import Control.Lens (Lens') -import Control.Lens qualified as Lens -import Data.Void (absurd) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.NameSegment qualified as NameSegment @@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path = CustomCodeserver cu -> "share(" <> tShow cu <> ")." in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path -writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void -writeNamespaceToRead = \case - WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} -> - ReadShare'LooseCode ReadShareLooseCode {server, repo, path} - WriteRemoteProjectBranch v -> absurd v - -- | print remote namespace printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text printReadRemoteNamespace printProject = \case @@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case ReadShare'ProjectBranch project -> printProject project -- | Render a 'WriteRemoteNamespace' as text. -printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text -printWriteRemoteNamespace = \case - WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) -> - displayShareCodeserver server repo path - WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch +printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text +printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch maybePrintPath :: Path -> Text maybePrintPath path = @@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} = case path of (segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment _ -> False - -data WriteRemoteNamespace a - = WriteRemoteNamespaceShare !WriteShareRemoteNamespace - | WriteRemoteProjectBranch a - deriving stock (Eq, Functor, Show) - --- | A lens which focuses the path of a remote namespace. -remotePath_ :: Lens' (WriteRemoteNamespace Void) Path -remotePath_ = Lens.lens getter setter - where - getter = \case - WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path - WriteRemoteProjectBranch v -> absurd v - setter remote path = - case remote of - WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) -> - WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path - WriteRemoteProjectBranch v -> absurd v - -data WriteShareRemoteNamespace = WriteShareRemoteNamespace - { server :: !ShareCodeserver, - repo :: !ShareUserHandle, - path :: !Path - } - deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index c45ca85011..0f18f47b09 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -33,7 +33,6 @@ module Unison.Cli.Pretty prettyRepoInfo, prettySCH, prettySemver, - prettyShareLink, prettySharePath, prettyShareURI, prettySlashProjectBranchName, @@ -57,12 +56,10 @@ import Control.Monad.Writer (Writer, runWriter) import Data.List qualified as List import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N') import Network.URI (URI) import Network.URI qualified as URI -import Network.URI.Encode qualified as URI import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Project qualified as Sqlite @@ -76,10 +73,6 @@ import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), - ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - shareUserHandleToText, ) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Path (Path') @@ -150,7 +143,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty prettyReadRemoteNamespaceWith printProject = P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject -prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty +prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty prettyWriteRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace @@ -161,14 +154,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty prettyRepoInfo (Share.RepoInfo repoInfo) = P.blue (P.text repoInfo) -prettyShareLink :: WriteShareRemoteNamespace -> Pretty -prettyShareLink WriteShareRemoteNamespace {repo, path} = - let encodedPath = - Path.toList path - & fmap (URI.encodeText . NameSegment.toUnescapedText) - & Text.intercalate "/" - in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath - prettySharePath :: Share.Path -> Pretty prettySharePath = prettyRelative diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 46b05773e0..0884efcb23 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -32,10 +32,6 @@ import Unison.Codebase.Editor.Input 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 - ( WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - ) import Unison.Codebase.Path qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior qualified as PushBehavior @@ -70,31 +66,17 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do localProjectAndBranch <- Cli.getCurrentProjectAndBranch pushProjectBranchToProjectBranch force localProjectAndBranch Nothing -- push to .some.path (share) - PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do - localPath <- Cli.getCurrentPath - pushLooseCodeToShareLooseCode localPath namespace pushBehavior -- push to @some/project - PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do + PushSourceTarget1 remoteProjectAndBranch0 -> do localProjectAndBranch <- Cli.getCurrentProjectAndBranch pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) - -- push .some.path to .some.path (share) - PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do - localPath <- Cli.resolvePath' localPath0 - pushLooseCodeToShareLooseCode localPath namespace pushBehavior -- push .some.path to @some/project - PushSourceTarget2 (PathySource localPath0) (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do + PushSourceTarget2 (PathySource localPath0) remoteProjectAndBranch0 -> do localPath <- Cli.resolvePath' localPath0 remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - -- push @some/project to .some.path (share) - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 - pushLooseCodeToShareLooseCode - (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - namespace - pushBehavior -- push @some/project to @some/project - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteProjectBranch remoteProjectAndBranch) -> do + PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch) where diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 1e33f62e8e..9f5e57f32d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -31,7 +31,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path @@ -254,8 +254,8 @@ data PushSource -- | Push source and target: either neither is specified, or only a target, or both. data PushSourceTarget = PushSourceTarget0 - | PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName)) - | PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + | PushSourceTarget1 (These ProjectName ProjectBranchName) + | PushSourceTarget2 PushSource (These ProjectName ProjectBranchName) deriving stock (Eq, Show) data PushRemoteBranchInput = PushRemoteBranchInput diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index ff7f44c325..090d78bc1e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -42,7 +42,6 @@ import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath (ProjectPath) -import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -268,7 +267,7 @@ data Output -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) | ShareError ShareError - | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName)) + | ViewOnShare (URI, ProjectName, ProjectBranchName) | NoConfiguredRemoteMapping PushPull Path.Absolute | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | TermMissingType Reference @@ -309,8 +308,6 @@ data Output | HelpMessage Input.InputPattern | NamespaceEmpty (NonEmpty AbsBranchId) | NoOp - | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. - RefusedToPush PushBehavior (WriteRemoteNamespace Void) | -- | @GistCreated repo@ means a causal was just published to @repo@. GistCreated (ReadRemoteNamespace Void) | -- | Directs the user to URI to begin an authorization flow. @@ -566,7 +563,6 @@ isFailure o = case o of TermMissingType {} -> True DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty NamespaceEmpty {} -> True - RefusedToPush {} -> True GistCreated {} -> False InitiateAuthFlow {} -> False UnknownCodeServer {} -> True diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index cf7a99a8f9..d9520379f4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,7 +1,5 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - writeRemoteNamespace, - writeRemoteNamespaceWith, parseReadShareLooseCode, ) where @@ -17,13 +15,11 @@ import Unison.Codebase.Editor.RemoteRepo ReadShareLooseCode (..), ShareCodeserver (DefaultCodeserver), ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), ) import Unison.Codebase.Path qualified as Path import Unison.NameSegment (NameSegment) import Unison.Prelude -import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) +import Unison.Project (ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) import Unison.Syntax.Lexer qualified import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty qualified as P @@ -51,28 +47,6 @@ parseReadShareLooseCode label input = let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err] in first printError (P.parse readShareLooseCode label (Text.pack input)) --- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" --- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) -writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName)) -writeRemoteNamespace = - writeRemoteNamespaceWith - (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name) - -writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a) -writeRemoteNamespaceWith projectBranchParser = - WriteRemoteProjectBranch <$> projectBranchParser - <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace - --- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4" --- Just (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) -writeShareRemoteNamespace :: P WriteShareRemoteNamespace -writeShareRemoteNamespace = - P.label "write share remote namespace" $ - WriteShareRemoteNamespace - <$> pure DefaultCodeserver - <*> shareUserHandle - <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) - -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" -- Nothing From 9c17d14c9b54050f792ee1c32d3818fb00d95253 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 12:13:57 -0700 Subject: [PATCH 48/76] Remove ability to push to loose code or pull into loose code. --- Sync.hs | 930 ++++++++++++++++++ .../U/Codebase/Sqlite/Operations.hs | 6 + .../Codebase/Editor/HandleInput/Push.hs | 47 +- .../src/Unison/Codebase/Editor/Input.hs | 3 +- .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/Codebase/Editor/UriParser.hs | 9 +- .../src/Unison/CommandLine/InputPatterns.hs | 14 +- .../src/Unison/CommandLine/OutputMessages.hs | 84 +- unison-cli/src/Unison/Share/Sync.hs | 326 +----- unison-cli/src/Unison/Share/Sync/Types.hs | 27 +- unison-share-api/src/Unison/Sync/API.hs | 10 - unison-share-api/src/Unison/Sync/Types.hs | 111 +-- 12 files changed, 967 insertions(+), 604 deletions(-) create mode 100644 Sync.hs diff --git a/Sync.hs b/Sync.hs new file mode 100644 index 0000000000..c81123fa39 --- /dev/null +++ b/Sync.hs @@ -0,0 +1,930 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Unison.Share.Sync + ( -- ** Get causal hash by path + getCausalHashByPath, + GetCausalHashByPathError (..), + + -- ** Push + checkAndSetPush, + CheckAndSetPushError (..), + uploadEntities, + + -- ** Pull + pull, + PullError (..), + downloadEntities, + ) +where + +import Control.Concurrent.STM +import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader (ask) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Control.Monad.Trans.Reader qualified as Reader +import Data.Foldable qualified as Foldable (find) +import Data.List.NonEmpty (pattern (:|)) +import Data.List.NonEmpty qualified as List (NonEmpty) +import Data.List.NonEmpty qualified as List.NonEmpty +import Data.Map qualified as Map +import Data.Map.NonEmpty (NEMap) +import Data.Map.NonEmpty qualified as NEMap +import Data.Proxy +import Data.Sequence.NonEmpty (NESeq ((:<||))) +import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|)) +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as NESet +import Data.Text.Lazy qualified as Text.Lazy +import Data.Text.Lazy.Encoding qualified as Text.Lazy +import GHC.IO (unsafePerformIO) +import Ki qualified +import Network.HTTP.Client qualified as Http.Client +import Network.HTTP.Types qualified as HTTP +import Servant.API qualified as Servant ((:<|>) (..), (:>)) +import Servant.Client (BaseUrl) +import Servant.Client qualified as Servant +import System.Environment (lookupEnv) +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Queries qualified as Q +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) +import Unison.Auth.HTTPClient (AuthenticatedHttpClient) +import Unison.Auth.HTTPClient qualified as Auth +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Debug qualified as Debug +import Unison.Hash32 (Hash32) +import Unison.Prelude +import Unison.Share.API.Hash qualified as Share +import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches) +import Unison.Share.Sync.Types +import Unison.Sqlite qualified as Sqlite +import Unison.Sync.API qualified as Share (API) +import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) +import Unison.Sync.EntityValidation qualified as EV +import Unison.Sync.Types qualified as Share +import Unison.Util.Monoid (foldMapM) + +------------------------------------------------------------------------------------------------------------------------ +-- Pile of constants + +-- | The maximum number of downloader threads, during a pull. +maxSimultaneousPullDownloaders :: Int +maxSimultaneousPullDownloaders = unsafePerformIO $ do + lookupEnv "UNISON_PULL_WORKERS" <&> \case + Just n -> read n + Nothing -> 5 +{-# NOINLINE maxSimultaneousPullDownloaders #-} + +-- | The maximum number of push workers at a time. Each push worker reads from the database and uploads entities. +-- Share currently parallelizes on it's own in the backend, and any more than one push worker +-- just results in serialization conflicts which slow things down. +maxSimultaneousPushWorkers :: Int +maxSimultaneousPushWorkers = unsafePerformIO $ do + lookupEnv "UNISON_PUSH_WORKERS" <&> \case + Just n -> read n + Nothing -> 1 +{-# NOINLINE maxSimultaneousPushWorkers #-} + +syncChunkSize :: Int +syncChunkSize = unsafePerformIO $ do + lookupEnv "UNISON_SYNC_CHUNK_SIZE" <&> \case + Just n -> read n + Nothing -> 50 +{-# NOINLINE syncChunkSize #-} + +------------------------------------------------------------------------------------------------------------------------ +-- Push + +-- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the +-- server is missing, too) to Unison Share. +-- +-- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation +-- is off, we won't proceed with the push. +checkAndSetPush :: + -- | The Unison Share URL. + BaseUrl -> + -- | The repo+path to push to. + Share.Path -> + -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. + -- This prevents accidentally pushing over data that we didn't know was there. + Maybe Hash32 -> + -- | The hash of our local causal to push. + CausalHash -> + -- | Callback that's given a number of entities we just uploaded. + (Int -> IO ()) -> + Cli (Either (SyncError CheckAndSetPushError) ()) +checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do + Cli.Env {authHTTPClient} <- ask + + Cli.label \done -> do + let failed :: SyncError CheckAndSetPushError -> Cli void + failed = done . Left + + let updatePathError :: Share.UpdatePathError -> Cli void + updatePathError err = + failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err)) + + -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it + -- needs this causal (UpdatePathMissingDependencies). + dependencies <- + updatePath >>= \case + Share.UpdatePathSuccess -> done (Right ()) + Share.UpdatePathFailure err -> + case err of + Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies + _ -> updatePathError err + + -- Upload the causal and all of its dependencies. + uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err -> + failed (CheckAndSetPushError'UploadEntities <$> err) + + -- After uploading the causal and all of its dependencies, try setting the remote path again. + updatePath >>= \case + Share.UpdatePathSuccess -> pure (Right ()) + Share.UpdatePathFailure err -> updatePathError err + +-- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments, +-- excluding the newest hash (second argument). +loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32]) +loadCausalSpineBetween earlierHash laterHash = + dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash + +data Step a + = DeadEnd + | KeepSearching (List.NonEmpty a) + | FoundGoal a + +-- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each +-- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True). +-- +-- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because +-- it was provided as an input ;)) +-- +-- For example, when searching a tree that looks like +-- +-- 1 +-- / \ +-- 2 3 +-- / \ \ +-- 4 [5] 6 +-- +-- (where the goal is marked [5]), we'd return +-- +-- Just [5,2] +-- +-- And (as another example), if the root node is the goal, +-- +-- [1] +-- / \ +-- 2 3 +-- / \ \ +-- 4 5 6 +-- +-- we'd return +-- +-- Just [] +dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a]) +dagbfs goal children = + let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied, + -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet. + -- (Otherwise, we wouldn't still be in this loop, we'd return!). + -- + -- For example, say we are exploring the tree + -- + -- 1 + -- / \ + -- 2 3 + -- / \ \ + -- 4 5 6 + -- + -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below + -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, + -- and maybe it doesn't). + -- + -- The loop state, in this case, would be these three paths: + -- + -- [ 4, 2 ] + -- [ 5, 2 ] + -- [ 6, 3 ] + -- + -- (Note, again, that we do not include the root). + go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) + go (path :<|| paths) = + -- Step forward from the first path in our loop state (in the example above, [4, 2]). + step (List.NonEmpty.head path) >>= \case + -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep + -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because + -- this was the only remaining path. + DeadEnd -> + case NESeq.nonEmptySeq paths of + Nothing -> pure Nothing + Just paths' -> go paths' + -- If node 4 did have children, then maybe the search tree now looks like this. + -- + -- 1 + -- / \ + -- 2 3 + -- / \ \ + -- 4 5 6 + -- / \ + -- 7 8 + -- + -- There are two cases to handle: + -- + -- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path + -- + -- [ 7, 4, 2 ] + -- + -- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end + -- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four + -- paths: + -- + -- [ 5, 2 ] \ these two are are variable 'paths', the tail of the loop state. + -- [ 6, 3 ] / + -- [ 7, 4, 2 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children + -- [ 8, 4, 2 ] / to itself, making two new paths to search + KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) + FoundGoal y -> pure (Just (List.NonEmpty.cons y path)) + + -- Step forward from a single node. There are 3 possible outcomes: + -- + -- 1. We discover it has no children. (return DeadEnd) + -- 2. We discover is has children, none of which are a goal. (return KeepSearching) + -- 3. We discover it has children, (at least) one of which is a goal. (return FoundGoal) + step :: a -> m (Step a) + step x = do + ys0 <- children x + pure case List.NonEmpty.nonEmpty ys0 of + Nothing -> DeadEnd + Just ys -> + case Foldable.find goal ys of + Nothing -> KeepSearching ys + Just y -> FoundGoal y + in \root -> + if goal root + then pure (Just []) + else + step root >>= \case + DeadEnd -> pure Nothing + -- lts-18.28 doesn't have List.NonEmpty.singleton + KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs)) + FoundGoal x -> pure (Just [x]) + where + -- Concatenate a seq and a non-empty seq. + append :: Seq x -> NESeq x -> NESeq x + append = (NESeq.><|) + +------------------------------------------------------------------------------------------------------------------------ +-- Pull + +pull :: + -- | The Unison Share URL. + BaseUrl -> + -- | The repo+path to pull from. + Share.Path -> + -- | Callback that's given a number of entities we just downloaded. + (Int -> IO ()) -> + Cli (Either (SyncError PullError) CausalHash) +pull unisonShareUrl repoPath downloadedCallback = + getCausalHashByPath unisonShareUrl repoPath >>= \case + Left err -> pure (Left (PullError'GetCausalHash <$> err)) + -- There's nothing at the remote path, so there's no causal to pull. + Right Nothing -> pure (Left (SyncError (PullError'NoHistoryAtPath repoPath))) + Right (Just hashJwt) -> + downloadEntities unisonShareUrl (Share.pathRepoInfo repoPath) hashJwt downloadedCallback <&> \case + Left err -> Left (PullError'DownloadEntities <$> err) + Right () -> Right (hash32ToCausalHash (Share.hashJWTHash hashJwt)) + +------------------------------------------------------------------------------------------------------------------------ +-- Download entities + +downloadEntities :: + -- | The Unison Share URL. + BaseUrl -> + -- | The repo to download from. + Share.RepoInfo -> + -- | The hash to download. + Share.HashJWT -> + -- | Callback that's given a number of entities we just downloaded. + (Int -> IO ()) -> + Cli (Either (SyncError Share.DownloadEntitiesError) ()) +downloadEntities unisonShareUrl repoInfo hashJwt downloadedCallback = do + Cli.Env {authHTTPClient, codebase} <- ask + + Cli.label \done -> do + let failed :: SyncError Share.DownloadEntitiesError -> Cli void + failed = done . Left + + let hash = Share.hashJWTHash hashJwt + + maybeTempEntities <- + Cli.runTransaction (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure Nothing + Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash)) + Nothing -> do + let request = + httpDownloadEntities + authHTTPClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoInfo, hashes = NESet.singleton hashJwt} + entities <- + liftIO request >>= \case + Left err -> failed (TransportError err) + Right (Share.DownloadEntitiesFailure err) -> failed (SyncError err) + Right (Share.DownloadEntitiesSuccess entities) -> pure entities + case validateEntities entities of + Left err -> failed . SyncError . Share.DownloadEntitiesEntityValidationFailure $ err + Right () -> pure () + tempEntities <- Cli.runTransaction (insertEntities entities) + liftIO (downloadedCallback 1) + pure (NESet.nonEmptySet tempEntities) + + whenJust maybeTempEntities \tempEntities -> do + let doCompleteTempEntities = + completeTempEntities + authHTTPClient + unisonShareUrl + ( \action -> + Codebase.withConnection codebase \conn -> + action (Sqlite.runTransaction conn) + ) + repoInfo + downloadedCallback + tempEntities + liftIO doCompleteTempEntities & onLeftM \err -> + failed err + -- Since we may have just inserted and then deleted many temp entities, we attempt to recover some disk space by + -- vacuuming after each pull. If the vacuum fails due to another open transaction on this connection, that's ok, + -- we'll try vacuuming again next pull. + _success <- liftIO (Codebase.withConnection codebase Sqlite.vacuum) + pure (Right ()) + +-- | Validates the provided entities if and only if the environment variable `UNISON_ENTITY_VALIDATION` is set to "true". +validateEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Either Share.EntityValidationError () +validateEntities entities = + when shouldValidateEntities $ do + ifor_ (NEMap.toMap entities) \hash entity -> do + let entityWithHashes = entity & Share.entityHashes_ %~ Share.hashJWTHash + case EV.validateEntity hash entityWithHashes of + Nothing -> pure () + Just err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> + let expectedMismatches = case et of + Share.TermComponentType -> expectedComponentHashMismatches + Share.DeclComponentType -> expectedComponentHashMismatches + Share.CausalType -> expectedCausalHashMismatches + _ -> mempty + in case Map.lookup supplied expectedMismatches of + Just expected + | expected == computed -> pure () + _ -> do + Left err + Just err -> do + Left err + +-- | Validate entities received from the server unless this flag is set to false. +validationEnvKey :: String +validationEnvKey = "UNISON_ENTITY_VALIDATION" + +shouldValidateEntities :: Bool +shouldValidateEntities = unsafePerformIO $ do + lookupEnv validationEnvKey <&> \case + Just "false" -> False + _ -> True +{-# NOINLINE shouldValidateEntities #-} + +type WorkerCount = + TVar Int + +newWorkerCount :: IO WorkerCount +newWorkerCount = + newTVarIO 0 + +recordWorking :: WorkerCount -> STM () +recordWorking sem = + modifyTVar' sem (+ 1) + +recordNotWorking :: WorkerCount -> STM () +recordNotWorking sem = + modifyTVar' sem \n -> n - 1 + +-- What the dispatcher is to do +data DispatcherJob + = DispatcherForkWorker (NESet Share.HashJWT) + | DispatcherReturnEarlyBecauseDownloaderFailed (SyncError Share.DownloadEntitiesError) + | DispatcherDone + +-- | Finish downloading entities from Unison Share (or return the first failure to download something). +-- +-- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the +-- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage. +completeTempEntities :: + AuthenticatedHttpClient -> + BaseUrl -> + (forall a. ((forall x. Sqlite.Transaction x -> IO x) -> IO a) -> IO a) -> + Share.RepoInfo -> + (Int -> IO ()) -> + NESet Hash32 -> + IO (Either (SyncError Share.DownloadEntitiesError) ()) +completeTempEntities httpClient unisonShareUrl connect repoInfo downloadedCallback initialNewTempEntities = do + -- The set of hashes we still need to download + hashesVar <- newTVarIO Set.empty + + -- The set of hashes that we haven't inserted yet, but will soon, because we've committed to downloading them. + uninsertedHashesVar <- newTVarIO Set.empty + + -- The entities payloads (along with the jwts that we used to download them) that we've downloaded + entitiesQueue <- newTQueueIO + + -- The sets of new (at the time of inserting, anyway) temp entity rows, which we need to elaborate, then download. + newTempEntitiesQueue <- newTQueueIO + + -- How many workers (downloader / inserter / elaborator) are currently doing stuff. + workerCount <- newWorkerCount + + -- The first download error seen by a downloader, if any. + downloaderFailedVar <- newEmptyTMVarIO + + -- Kick off the cycle of inserter->elaborator->dispatcher->downloader by giving the elaborator something to do + atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities)) + + Ki.scoped \scope -> do + Ki.fork_ scope (inserter entitiesQueue newTempEntitiesQueue workerCount) + Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount) + dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar + where + -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders. + -- + -- We stop when either all of the following are true: + -- + -- - There are no outstanding workers (downloaders, inserter, elaboraror) + -- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`) + -- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`) + -- + -- Or: + -- + -- - Some downloader failed to download something + dispatcher :: + TVar (Set Share.HashJWT) -> + TVar (Set Share.HashJWT) -> + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> + WorkerCount -> + TMVar (SyncError Share.DownloadEntitiesError) -> + IO (Either (SyncError Share.DownloadEntitiesError) ()) + dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar = + Ki.scoped \scope -> + let loop :: IO (Either (SyncError Share.DownloadEntitiesError) ()) + loop = + atomically (checkIfDownloaderFailedMode <|> dispatchWorkMode <|> checkIfDoneMode) >>= \case + DispatcherDone -> pure (Right ()) + DispatcherReturnEarlyBecauseDownloaderFailed err -> pure (Left err) + DispatcherForkWorker hashes -> do + atomically do + -- Limit number of simultaneous downloaders (plus 2, for inserter and elaborator) + workers <- readTVar workerCount + check (workers < maxSimultaneousPullDownloaders + 2) + -- we do need to record the downloader as working outside of the worker thread, not inside. + -- otherwise, we might erroneously fall through the teardown logic below and conclude there's + -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as + -- far as recording its own existence + recordWorking workerCount + _ <- + Ki.fork @() scope do + downloader entitiesQueue workerCount hashes & onLeftM \err -> + void (atomically (tryPutTMVar downloaderFailedVar err)) + loop + in loop + where + checkIfDownloaderFailedMode :: STM DispatcherJob + checkIfDownloaderFailedMode = + DispatcherReturnEarlyBecauseDownloaderFailed <$> readTMVar downloaderFailedVar + + dispatchWorkMode :: STM DispatcherJob + dispatchWorkMode = do + hashes <- readTVar hashesVar + check (not (Set.null hashes)) + let (hashes1, hashes2) = Set.splitAt syncChunkSize hashes + modifyTVar' uninsertedHashesVar (Set.union hashes1) + writeTVar hashesVar hashes2 + pure (DispatcherForkWorker (NESet.unsafeFromSet hashes1)) + + -- Check to see if there are no hashes left to download, no outstanding workers, and no work in either queue + checkIfDoneMode :: STM DispatcherJob + checkIfDoneMode = do + workers <- readTVar workerCount + check (workers == 0) + isEmptyTQueue entitiesQueue >>= check + isEmptyTQueue newTempEntitiesQueue >>= check + pure DispatcherDone + + -- Downloader thread: download entities, (if successful) enqueue to `entitiesQueue` + downloader :: + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + WorkerCount -> + NESet Share.HashJWT -> + IO (Either (SyncError Share.DownloadEntitiesError) ()) + downloader entitiesQueue workerCount hashes = do + httpDownloadEntities httpClient unisonShareUrl Share.DownloadEntitiesRequest {repoInfo, hashes} >>= \case + Left err -> do + atomically (recordNotWorking workerCount) + pure (Left (TransportError err)) + Right (Share.DownloadEntitiesFailure err) -> do + atomically (recordNotWorking workerCount) + pure (Left (SyncError err)) + Right (Share.DownloadEntitiesSuccess entities) -> do + downloadedCallback (NESet.size hashes) + case validateEntities entities of + Left err -> pure . Left . SyncError . Share.DownloadEntitiesEntityValidationFailure $ err + Right () -> do + atomically do + writeTQueue entitiesQueue (hashes, entities) + recordNotWorking workerCount + pure (Right ()) + + -- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue` + inserter :: + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> + WorkerCount -> + IO Void + inserter entitiesQueue newTempEntitiesQueue workerCount = + connect \runTransaction -> + forever do + (hashJwts, entities) <- + atomically do + entities <- readTQueue entitiesQueue + recordWorking workerCount + pure entities + newTempEntities0 <- + runTransaction do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + atomically do + writeTQueue newTempEntitiesQueue (NESet.toSet hashJwts, NESet.nonEmptySet newTempEntities0) + recordNotWorking workerCount + + -- Elaborator thread: dequeue from `newTempEntitiesQueue`, elaborate, "enqueue" to `hashesVar` + elaborator :: + TVar (Set Share.HashJWT) -> + TVar (Set Share.HashJWT) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> + WorkerCount -> + IO Void + elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount = + connect \runTransaction -> + forever do + maybeNewTempEntities <- + atomically do + (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would + -- still be correct if we never delete from `uninsertedHashes`. + -- + -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion + -- in order to ensure that no running transaction of the elaborator is viewing a snapshot that precedes + -- the snapshot that inserted those hashes. + modifyTVar' uninsertedHashesVar \uninsertedHashes -> Set.difference uninsertedHashes hashJwts + case mayNewTempEntities of + Nothing -> pure Nothing + Just newTempEntities -> do + recordWorking workerCount + pure (Just newTempEntities) + whenJust maybeNewTempEntities \newTempEntities -> do + newElaboratedHashes <- runTransaction (elaborateHashes newTempEntities) + atomically do + uninsertedHashes <- readTVar uninsertedHashesVar + hashes0 <- readTVar hashesVar + writeTVar hashesVar $! Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 + recordNotWorking workerCount + +-- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than +-- of main storage (`object` / `causal`) due to missing dependencies. +insertEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Sqlite.Transaction (Set Hash32) +insertEntities entities = + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + +------------------------------------------------------------------------------------------------------------------------ +-- Get causal hash by path + +-- | Get the causal hash of a path hosted on Unison Share. +getCausalHashByPath :: + -- | The Unison Share URL. + BaseUrl -> + Share.Path -> + Cli (Either (SyncError GetCausalHashByPathError) (Maybe Share.HashJWT)) +getCausalHashByPath unisonShareUrl repoPath = do + Cli.Env {authHTTPClient} <- ask + liftIO (httpGetCausalHashByPath authHTTPClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath)) <&> \case + Left err -> Left (TransportError err) + Right (Share.GetCausalHashByPathSuccess maybeHashJwt) -> Right maybeHashJwt + Right (Share.GetCausalHashByPathNoReadPermission _) -> + Left (SyncError (GetCausalHashByPathErrorNoReadPermission repoPath)) + Right (Share.GetCausalHashByPathInvalidRepoInfo err repoInfo) -> + Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo err repoInfo)) + Right Share.GetCausalHashByPathUserNotFound -> + Left (SyncError $ GetCausalHashByPathErrorUserNotFound (Share.pathRepoInfo repoPath)) + +------------------------------------------------------------------------------------------------------------------------ +-- Upload entities + +data UploadDispatcherJob + = UploadDispatcherReturnFailure (SyncError Share.UploadEntitiesError) + | UploadDispatcherForkWorkerWhenAvailable (NESet Hash32) + | UploadDispatcherForkWorker (NESet Hash32) + | UploadDispatcherDone + +-- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to +-- missing dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing +-- anything. +-- +-- Returns true on success, false on failure (because the user does not have write permission). +uploadEntities :: + BaseUrl -> + Share.RepoInfo -> + NESet Hash32 -> + (Int -> IO ()) -> + Cli (Either (SyncError Share.UploadEntitiesError) ()) +uploadEntities unisonShareUrl repoInfo hashes0 uploadedCallback = do + Cli.Env {authHTTPClient, codebase} <- ask + + liftIO do + hashesVar <- newTVarIO (NESet.toSet hashes0) + -- Semantically, this is the set of hashes we've uploaded so far, but we do delete from it when it's safe to, so it + -- doesn't grow unbounded. It's used to filter out hashes that would be duplicate uploads: the server, when + -- responding to any particular upload request, may declare that it still needs some hashes that we're in the + -- process of uploading from another thread. + dedupeVar <- newTVarIO Set.empty + nextWorkerIdVar <- newTVarIO 0 + workersVar <- newTVarIO Set.empty + workerFailedVar <- newEmptyTMVarIO + + Ki.scoped \scope -> + dispatcher + scope + authHTTPClient + (Codebase.runTransaction codebase) + hashesVar + dedupeVar + nextWorkerIdVar + workersVar + workerFailedVar + where + dispatcher :: + Ki.Scope -> + AuthenticatedHttpClient -> + (forall a. Sqlite.Transaction a -> IO a) -> + TVar (Set Hash32) -> + TVar (Set Hash32) -> + TVar Int -> + TVar (Set Int) -> + TMVar (SyncError Share.UploadEntitiesError) -> + IO (Either (SyncError Share.UploadEntitiesError) ()) + dispatcher scope httpClient runTransaction hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do + loop + where + loop :: IO (Either (SyncError Share.UploadEntitiesError) ()) + loop = + doJob [checkForFailureMode, dispatchWorkMode, checkIfDoneMode] + + doJob :: [STM UploadDispatcherJob] -> IO (Either (SyncError Share.UploadEntitiesError) ()) + doJob jobs = + atomically (asum jobs) >>= \case + UploadDispatcherReturnFailure err -> pure (Left err) + UploadDispatcherForkWorkerWhenAvailable hashes -> doJob [forkWorkerMode hashes, checkForFailureMode] + UploadDispatcherForkWorker hashes -> do + workerId <- + atomically do + workerId <- readTVar nextWorkerIdVar + writeTVar nextWorkerIdVar $! workerId + 1 + modifyTVar' workersVar (Set.insert workerId) + pure workerId + _ <- + Ki.fork @() scope do + worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes + loop + UploadDispatcherDone -> pure (Right ()) + + checkForFailureMode :: STM UploadDispatcherJob + checkForFailureMode = do + err <- readTMVar workerFailedVar + pure (UploadDispatcherReturnFailure err) + + dispatchWorkMode :: STM UploadDispatcherJob + dispatchWorkMode = do + hashes <- readTVar hashesVar + when (Set.null hashes) retry + let (hashes1, hashes2) = Set.splitAt syncChunkSize hashes + modifyTVar' dedupeVar (Set.union hashes1) + writeTVar hashesVar hashes2 + pure (UploadDispatcherForkWorkerWhenAvailable (NESet.unsafeFromSet hashes1)) + + forkWorkerMode :: NESet Hash32 -> STM UploadDispatcherJob + forkWorkerMode hashes = do + workers <- readTVar workersVar + when (Set.size workers >= maxSimultaneousPushWorkers) retry + pure (UploadDispatcherForkWorker hashes) + + checkIfDoneMode :: STM UploadDispatcherJob + checkIfDoneMode = do + workers <- readTVar workersVar + when (not (Set.null workers)) retry + pure UploadDispatcherDone + + worker :: + AuthenticatedHttpClient -> + (forall a. Sqlite.Transaction a -> IO a) -> + TVar (Set Hash32) -> + TVar (Set Hash32) -> + TVar (Set Int) -> + TMVar (SyncError Share.UploadEntitiesError) -> + Int -> + NESet Hash32 -> + IO () + worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do + entities <- + fmap NEMap.fromAscList do + runTransaction do + for (NESet.toAscList hashes) \hash -> do + entity <- expectEntity hash + pure (hash, entity) + + result <- + httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest {entities, repoInfo} <&> \case + Left err -> Left (TransportError err) + Right response -> + case response of + Share.UploadEntitiesSuccess -> Right Set.empty + Share.UploadEntitiesFailure err -> + case err of + Share.UploadEntitiesError'NeedDependencies (Share.NeedDependencies moreHashes) -> + Right (NESet.toSet moreHashes) + err -> Left (SyncError err) + + case result of + Left err -> void (atomically (tryPutTMVar workerFailedVar err)) + Right moreHashes -> do + uploadedCallback (NESet.size hashes) + maybeYoungestWorkerThatWasAlive <- + atomically do + -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from + -- the `dedupe` set, but whether or not we are "alive" is relevant only to: + -- + -- - The main dispatcher thread, which terminates when there are no more hashes to upload, and no alive + -- workers. It is not important for us to delete from the `dedupe` set in this case. + -- + -- - Other worker threads, each of which independently decides when it is safe to delete the set of + -- hashes they just uploaded from the `dedupe` set (as we are doing now). + !workers <- Set.delete workerId <$> readTVar workersVar + writeTVar workersVar workers + -- Add more work (i.e. hashes to upload) to the work queue (really a work set), per the response we just + -- got from the server. Remember to only add hashes that aren't in the `dedupe` set (see the comment on + -- the dedupe set above for more info). + when (not (Set.null moreHashes)) do + dedupe <- readTVar dedupeVar + hashes0 <- readTVar hashesVar + writeTVar hashesVar $! Set.union (Set.difference moreHashes dedupe) hashes0 + pure (Set.lookupMax workers) + -- Block until we are sure that the server does not have any uncommitted transactions that see a version of + -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the + -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any + -- subsequent deduping operations. If we didn't delete from the `dedupe` set, this algorithm would still be + -- correct, it would just use an unbounded amount of memory to remember all the hashes we've uploaded so far. + whenJust maybeYoungestWorkerThatWasAlive \youngestWorkerThatWasAlive -> do + atomically do + workers <- readTVar workersVar + whenJust (Set.lookupMin workers) \oldestWorkerAlive -> + when (oldestWorkerAlive <= youngestWorkerThatWasAlive) retry + atomically (modifyTVar' dedupeVar (`Set.difference` (NESet.toSet hashes))) + +------------------------------------------------------------------------------------------------------------------------ +-- Database operations + +-- | "Elaborate" a set of `temp_entity` hashes. +-- +-- For each hash, then we ought to instead download its missing dependencies (which themselves are +-- elaborated by this same procedure, in case we have any of *them* already in temp storage, too. +-- 3. If it's in main storage, we should ignore it. +-- +-- In the end, we return a set of hashes that correspond to entities we actually need to download. +elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (Set Share.HashJWT) +elaborateHashes hashes = + Q.elaborateHashes (NESet.toList hashes) <&> Set.fromList . coerce @[Text] @[Share.HashJWT] + +-- | Upsert a downloaded entity "somewhere" - +-- +-- 1. Nowhere if we already had the entity (in main or temp storage). +-- 2. In main storage if we already have all of its dependencies in main storage. +-- 3. In temp storage otherwise. +upsertEntitySomewhere :: + Hash32 -> + Share.Entity Text Hash32 Share.HashJWT -> + Sqlite.Transaction Q.EntityLocation +upsertEntitySomewhere hash entity = + Q.entityLocation hash >>= \case + Just location -> pure location + Nothing -> do + missingDependencies1 :: Map Hash32 Share.HashJWT <- + Share.entityDependencies entity + & foldMapM + ( \hashJwt -> do + let hash = Share.hashJWTHash hashJwt + Q.entityExists hash <&> \case + True -> Map.empty + False -> Map.singleton hash hashJwt + ) + case NEMap.nonEmptyMap missingDependencies1 of + Nothing -> do + _id <- Q.saveTempEntityInMain v2HashHandle hash (entityToTempEntity Share.hashJWTHash entity) + pure Q.EntityInMainStorage + Just missingDependencies -> do + Q.insertTempEntity + hash + (entityToTempEntity Share.hashJWTHash entity) + ( coerce + @(NEMap Hash32 Share.HashJWT) + @(NEMap Hash32 Text) + missingDependencies + ) + pure Q.EntityInTempStorage + +------------------------------------------------------------------------------------------------------------------------ +-- HTTP calls + +httpGetCausalHashByPath :: + Auth.AuthenticatedHttpClient -> + BaseUrl -> + Share.GetCausalHashByPathRequest -> + IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse) +httpDownloadEntities :: + Auth.AuthenticatedHttpClient -> + BaseUrl -> + Share.DownloadEntitiesRequest -> + IO (Either CodeserverTransportError Share.DownloadEntitiesResponse) +httpUploadEntities :: + Auth.AuthenticatedHttpClient -> + BaseUrl -> + Share.UploadEntitiesRequest -> + IO (Either CodeserverTransportError Share.UploadEntitiesResponse) +( httpGetCausalHashByPath, + httpDownloadEntities, + httpUploadEntities + ) = + let ( httpGetCausalHashByPath + Servant.:<|> httpDownloadEntities + Servant.:<|> httpUploadEntities + ) = + let pp :: Proxy ("ucm" Servant.:> "v1" Servant.:> "sync" Servant.:> Share.API) + pp = Proxy + in Servant.hoistClient pp hoist (Servant.client pp) + in ( go httpGetCausalHashByPath, + go httpDownloadEntities, + go httpUploadEntities + ) + where + hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) a + hoist m = do + clientEnv <- Reader.ask + liftIO (Servant.runClientM m clientEnv) >>= \case + Right a -> pure a + Left err -> do + Debug.debugLogM Debug.Sync (show err) + throwError case err of + Servant.FailureResponse _req resp -> + case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated (Servant.baseUrl clientEnv) + -- The server should provide semantically relevant permission-denied messages + -- when possible, but this should catch any we miss. + 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) + 408 -> Timeout + 429 -> RateLimitExceeded + 504 -> Timeout + _ -> UnexpectedResponse resp + Servant.DecodeFailure msg resp -> DecodeFailure msg resp + Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp + Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp + Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) + + go :: + (req -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) resp) -> + Auth.AuthenticatedHttpClient -> + BaseUrl -> + req -> + IO (Either CodeserverTransportError resp) + go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + & runReaderT (f req) + & runExceptT diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index d3f24db564..c3965c1432 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -96,6 +96,7 @@ module U.Codebase.Sqlite.Operations -- * Projects expectProjectAndBranchNames, + expectProjectBranchHead, -- * reflog getReflog, @@ -1524,3 +1525,8 @@ expectProjectAndBranchNames projectId projectBranchId = do Project {name = pName} <- Q.expectProject projectId ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId pure (pName, bName) + +expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash +expectProjectBranchHead projId projectBranchId = do + chId <- Q.expectProjectBranchHead projId projectBranchId + Q.expectCausalHash chId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 0884efcb23..81dbbc2816 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -9,13 +9,13 @@ import Control.Lens (_1, _2) import Data.Set.NonEmpty qualified as Set.NonEmpty import Data.Text as Text import Data.These (These (..)) -import Data.Void (absurd) import System.Console.Regions qualified as Console.Regions import Text.Builder qualified import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project qualified as Sqlite (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -31,9 +31,6 @@ import Unison.Codebase.Editor.Input ) import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.Output.PushPull (PushPull (Push)) -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) import Unison.Hash32 (Hash32) @@ -70,11 +67,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushSourceTarget1 remoteProjectAndBranch0 -> do localProjectAndBranch <- Cli.getCurrentProjectAndBranch pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) - -- push .some.path to @some/project - PushSourceTarget2 (PathySource localPath0) remoteProjectAndBranch0 -> do - localPath <- Cli.resolvePath' localPath0 - remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 - pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch -- push @some/project to @some/project PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 @@ -86,19 +78,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushBehavior.RequireEmpty -> False PushBehavior.RequireNonEmpty -> False --- Push a local namespace ("loose code") to a remote project branch. -pushLooseCodeToProjectBranch :: Bool -> Path.Absolute -> ProjectAndBranch ProjectName ProjectBranchName -> Cli () -pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch = do - _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver - localBranchHead <- - Cli.runTransactionWithRollback \rollback -> do - loadCausalHashToPush localPath >>= \case - Nothing -> rollback (EmptyLooseCodePush (Path.absoluteToPath' localPath)) - Just hash -> pure hash - - uploadPlan <- pushToProjectBranch0 force PushingLooseCode localBranchHead remoteProjectAndBranch - executeUploadPlan uploadPlan - -- | Push a local project branch to a remote project branch. If the remote project branch is left unspecified, we either -- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it). pushProjectBranchToProjectBranch :: @@ -109,14 +88,11 @@ pushProjectBranchToProjectBranch :: pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver let localProjectAndBranchIds = localProjectAndBranch & over #project (view #projectId) & over #branch (view #branchId) - let localProjectAndBranchNames = localProjectAndBranch & over #project (view #name) & over #branch (view #name) -- Load local project and branch from database and get the causal hash to push (localProjectAndBranch, localBranchHead) <- - Cli.runTransactionWithRollback \rollback -> do - hash <- - loadCausalHashToPush (ProjectUtils.projectBranchPath localProjectAndBranchIds) & onNothingM do - rollback (EmptyProjectBranchPush localProjectAndBranchNames) + Cli.runTransaction do + hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch) localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds pure (localProjectAndBranch, hash) @@ -432,7 +408,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do Cli.respond (Output.UploadedEntities numUploaded) afterUploadAction let ProjectAndBranch projectName branchName = remoteBranch - Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName))) + Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName)) ------------------------------------------------------------------------------------------------------------------------ -- After upload actions @@ -524,7 +500,7 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) - Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))) + Cli.returnEarly (ViewOnShare (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)) when (not force) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do @@ -594,14 +570,11 @@ expectProjectAndBranch (ProjectAndBranch projectId branchId) = <$> Queries.expectProject projectId <*> Queries.expectProjectBranch projectId branchId --- Get the causal hash to push at the given path. Return Nothing if there's no history. -loadCausalHashToPush :: Path.Absolute -> Sqlite.Transaction (Maybe Hash32) -loadCausalHashToPush path = - Operations.loadCausalHashAtPath Nothing segments <&> \case - Nothing -> Nothing - Just (CausalHash hash) -> Just (Hash32.fromHash hash) - where - segments = Path.toList (Path.unabsolute path) +-- Get the causal hash for the given project branch. +expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32 +expectCausalHashToPush pb = do + CausalHash causalHash <- Operations.expectProjectBranchHead (pb ^. #projectId) (pb ^. #branchId) + pure (Hash32.fromHash causalHash) -- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward? wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 9f5e57f32d..46cab3a744 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -247,8 +247,7 @@ data PullSourceTarget deriving stock (Eq, Show) data PushSource - = PathySource Path' - | ProjySource (These ProjectName ProjectBranchName) + = ProjySource (These ProjectName ProjectBranchName) deriving stock (Eq, Show) -- | Push source and target: either neither is specified, or only a target, or both. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 090d78bc1e..b137b5d32f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -426,9 +426,7 @@ data WhichBranchEmpty | WhichBranchEmptyPath (Either ProjectPath Path') data ShareError - = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError - | ShareErrorDownloadEntities Share.DownloadEntitiesError - | ShareErrorFastForwardPush Sync.FastForwardPushError + = ShareErrorDownloadEntities Share.DownloadEntitiesError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError | ShareErrorPull Sync.PullError | ShareErrorTransport Sync.CodeserverTransportError diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index d9520379f4..14e7412c4e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,7 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, parseReadShareLooseCode, + writeRemoteNamespace, ) where @@ -19,7 +20,7 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Path qualified as Path import Unison.NameSegment (NameSegment) import Unison.Prelude -import Unison.Project (ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) +import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) import Unison.Syntax.Lexer qualified import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty qualified as P @@ -47,6 +48,12 @@ parseReadShareLooseCode label input = let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err] in first printError (P.parse readShareLooseCode label (Text.pack input)) +-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" +-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) +writeRemoteNamespace :: P (These ProjectName ProjectBranchName) +writeRemoteNamespace = + (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name) + -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" -- Nothing diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index b5b2787344..5195866641 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -171,7 +171,7 @@ import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) @@ -640,11 +640,11 @@ handlePullSourceArg = otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg handlePushTargetArg :: - I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + I.Argument -> Either (P.Pretty CT.ColorText) (These ProjectName ProjectBranchName) handlePushTargetArg = either (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget) - $ fmap RemoteRepo.WriteRemoteProjectBranch . \case + $ \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 @@ -654,11 +654,6 @@ 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 @@ -3847,12 +3842,11 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do parsePushSource :: String -> Maybe Input.PushSource parsePushSource sourceStr = 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 -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +parsePushTarget :: String -> Maybe (These ProjectName ProjectBranchName) parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack parseHashQualifiedName :: diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5645ce7458..bc95371850 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -57,8 +57,6 @@ import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as E import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD 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 @@ -67,7 +65,6 @@ import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrit import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -91,7 +88,6 @@ import Unison.LabeledDependency as LD import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment -import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Names (Names (..)) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names @@ -1533,11 +1529,6 @@ notifyUser dir = \case <> ( terms <&> \(n, r) -> prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r) ) - RefusedToPush pushBehavior path -> - (pure . P.warnCallout) case pushBehavior of - PushBehavior.ForcePush -> error "impossible: refused to push due to ForcePush?" - PushBehavior.RequireEmpty -> expectedEmptyPushDest path - PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> pure $ P.lines @@ -1599,10 +1590,7 @@ notifyUser dir = \case PrintVersion ucmVersion -> pure (P.text ucmVersion) ShareError shareError -> pure (prettyShareError shareError) ViewOnShare shareRef -> - pure $ - "View it here: " <> case shareRef of - Left repoPath -> prettyShareLink repoPath - Right branchInfo -> prettyRemoteBranchInfo branchInfo + pure $ "View it here: " <> prettyRemoteBranchInfo shareRef IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "🎉 No issues detected 🎉" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns @@ -2120,39 +2108,16 @@ notifyUser dir = \case Nothing -> prettyProjectBranchName targetBranch Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch) -expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty -expectedEmptyPushDest namespace = - P.lines - [ "The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] - -expectedNonEmptyPushDest :: WriteRemoteNamespace Void -> Pretty -expectedNonEmptyPushDest namespace = - P.lines - [ P.wrap ("The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is empty."), - "", - P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?") - ] - prettyShareError :: ShareError -> Pretty prettyShareError = P.fatalCallout . \case - ShareErrorCheckAndSetPush err -> prettyCheckAndSetPushError err ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err - ShareErrorFastForwardPush err -> prettyFastForwardPushError err ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err ShareErrorPull err -> prettyPullError err ShareErrorTransport err -> prettyTransportError err ShareErrorUploadEntities err -> prettyUploadEntitiesError err ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team." -prettyCheckAndSetPushError :: Share.CheckAndSetPushError -> Pretty -prettyCheckAndSetPushError = \case - Share.CheckAndSetPushError'UpdatePath repoInfo err -> prettyUpdatePathError repoInfo err - Share.CheckAndSetPushError'UploadEntities err -> prettyUploadEntitiesError err - prettyDownloadEntitiesError :: Share.DownloadEntitiesError -> Pretty prettyDownloadEntitiesError = \case Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo @@ -2161,27 +2126,6 @@ prettyDownloadEntitiesError = \case Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationFailure err -prettyFastForwardPathError :: Share.Path -> Share.FastForwardPathError -> Pretty -prettyFastForwardPathError path = \case - Share.FastForwardPathError'InvalidParentage Share.InvalidParentage {child, parent} -> - P.lines - [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", - "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent - ] - Share.FastForwardPathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo - Share.FastForwardPathError'MissingDependencies dependencies -> needDependencies dependencies - Share.FastForwardPathError'NoHistory -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare path) - Share.FastForwardPathError'NoWritePermission path -> noWritePermissionForPath path - Share.FastForwardPathError'NotFastForward _hashJwt -> notFastForward path - Share.FastForwardPathError'UserNotFound -> shareUserNotFound (Share.pathRepoInfo path) - -prettyFastForwardPushError :: Share.FastForwardPushError -> Pretty -prettyFastForwardPushError = \case - Share.FastForwardPushError'FastForwardPath path err -> prettyFastForwardPathError path err - Share.FastForwardPushError'GetCausalHash err -> prettyGetCausalHashByPathError err - Share.FastForwardPushError'NotFastForward path -> notFastForward path - Share.FastForwardPushError'UploadEntities err -> prettyUploadEntitiesError err - prettyGetCausalHashByPathError :: Share.GetCausalHashByPathError -> Pretty prettyGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath @@ -2195,21 +2139,6 @@ prettyPullError = \case Share.PullError'NoHistoryAtPath sharePath -> P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath -prettyUpdatePathError :: Share.RepoInfo -> Share.UpdatePathError -> Pretty -prettyUpdatePathError repoInfo = \case - Share.UpdatePathError'HashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash} -> - case (expectedHash, actualHash) of - (Nothing, Just _) -> expectedEmptyPushDest (sharePathToWriteRemotePathShare sharePath) - _ -> - P.wrap $ - P.text "It looks like someone modified" - <> prettySharePath sharePath - <> P.text "an instant before you. Pull and try again? 🤞" - Share.UpdatePathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo - Share.UpdatePathError'MissingDependencies dependencies -> needDependencies dependencies - Share.UpdatePathError'NoWritePermission path -> noWritePermissionForPath path - Share.UpdatePathError'UserNotFound -> shareUserNotFound repoInfo - prettyUploadEntitiesError :: Share.UploadEntitiesError -> Pretty prettyUploadEntitiesError = \case Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr @@ -2407,17 +2336,6 @@ shareUserNotFound :: Share.RepoInfo -> Pretty shareUserNotFound repoInfo = P.wrap ("User" <> prettyRepoInfo repoInfo <> "does not exist.") -sharePathToWriteRemotePathShare :: Share.Path -> WriteRemoteNamespace void -sharePathToWriteRemotePathShare sharePath = - -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share - -- client code that doesn't know about WriteRemotePath - WriteRemoteNamespaceShare - WriteShareRemoteNamespace - { server = RemoteRepo.DefaultCodeserver, - repo = ShareUserHandle $ Share.unRepoInfo (Share.pathRepoInfo sharePath), - path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) - } - formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified Name, tm)] -> diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 8df14b8f99..6ccf8939ef 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -6,14 +6,10 @@ module Unison.Share.Sync getCausalHashByPath, GetCausalHashByPathError (..), - -- ** Push - checkAndSetPush, - CheckAndSetPushError (..), - fastForwardPush, - FastForwardPushError (..), + -- ** Upload uploadEntities, - -- ** Pull + -- ** Pull/Download pull, PullError (..), downloadEntities, @@ -26,16 +22,10 @@ import Control.Monad.Except import Control.Monad.Reader (ask) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Reader qualified as Reader -import Data.Foldable qualified as Foldable (find) -import Data.List.NonEmpty (pattern (:|)) -import Data.List.NonEmpty qualified as List (NonEmpty) -import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map qualified as Map import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEMap import Data.Proxy -import Data.Sequence.NonEmpty (NESeq ((:<||))) -import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|)) import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet @@ -65,7 +55,7 @@ import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expect import Unison.Share.Sync.Types import Unison.Sqlite qualified as Sqlite import Unison.Sync.API qualified as Share (API) -import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) +import Unison.Sync.Common (entityToTempEntity, expectEntity, hash32ToCausalHash) import Unison.Sync.EntityValidation qualified as EV import Unison.Sync.Types qualified as Share import Unison.Util.Monoid (foldMapM) @@ -98,300 +88,6 @@ syncChunkSize = unsafePerformIO $ do Nothing -> 50 {-# NOINLINE syncChunkSize #-} ------------------------------------------------------------------------------------------------------------------------- --- Push - --- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the --- server is missing, too) to Unison Share. --- --- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation --- is off, we won't proceed with the push. -checkAndSetPush :: - -- | The Unison Share URL. - BaseUrl -> - -- | The repo+path to push to. - Share.Path -> - -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. - -- This prevents accidentally pushing over data that we didn't know was there. - Maybe Hash32 -> - -- | The hash of our local causal to push. - CausalHash -> - -- | Callback that's given a number of entities we just uploaded. - (Int -> IO ()) -> - Cli (Either (SyncError CheckAndSetPushError) ()) -checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do - Cli.Env {authHTTPClient} <- ask - - Cli.label \done -> do - let failed :: SyncError CheckAndSetPushError -> Cli void - failed = done . Left - - let updatePathError :: Share.UpdatePathError -> Cli void - updatePathError err = - failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err)) - - let updatePath :: Cli Share.UpdatePathResponse - updatePath = do - liftIO request & onLeftM \err -> failed (TransportError err) - where - request :: IO (Either CodeserverTransportError Share.UpdatePathResponse) - request = - httpUpdatePath - authHTTPClient - unisonShareUrl - Share.UpdatePathRequest - { path, - expectedHash, - newHash = causalHashToHash32 causalHash - } - - -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it - -- needs this causal (UpdatePathMissingDependencies). - dependencies <- - updatePath >>= \case - Share.UpdatePathSuccess -> done (Right ()) - Share.UpdatePathFailure err -> - case err of - Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies - _ -> updatePathError err - - -- Upload the causal and all of its dependencies. - uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err -> - failed (CheckAndSetPushError'UploadEntities <$> err) - - -- After uploading the causal and all of its dependencies, try setting the remote path again. - updatePath >>= \case - Share.UpdatePathSuccess -> pure (Right ()) - Share.UpdatePathFailure err -> updatePathError err - --- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the --- server is missing, too) to Unison Share. --- --- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired --- state. -fastForwardPush :: - -- | The Unison Share URL. - BaseUrl -> - -- | The repo+path to push to. - Share.Path -> - -- | The hash of our local causal to push. - CausalHash -> - -- | Callback that's given a number of entities we just uploaded. - (Int -> IO ()) -> - Cli (Either (SyncError FastForwardPushError) ()) -fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do - Cli.label \done -> do - let succeeded :: Cli void - succeeded = - done (Right ()) - - let failed :: SyncError FastForwardPushError -> Cli void - failed = done . Left - - let fastForwardPathError :: Share.FastForwardPathError -> Cli void - fastForwardPathError err = - failed (SyncError (FastForwardPushError'FastForwardPath path err)) - - remoteHeadHash <- - getCausalHashByPath unisonShareUrl path >>= \case - Left err -> failed (FastForwardPushError'GetCausalHash <$> err) - Right Nothing -> fastForwardPathError Share.FastForwardPathError'NoHistory - Right (Just remoteHeadHash) -> pure (Share.hashJWTHash remoteHeadHash) - - let doLoadCausalSpineBetween = do - -- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the - -- actual path. - let isBefore :: Sqlite.Transaction Bool - isBefore = do - maybeHashIds <- - runMaybeT $ - (,) - <$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash)) - <*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash) - case maybeHashIds of - Nothing -> pure False - Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId - isBefore >>= \case - False -> pure Nothing - True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash) - - let doUpload :: List.NonEmpty CausalHash -> Cli () - -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", - -- but we don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure - -- the server doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server - -- needs. - doUpload (headHash :| _tailHashes) = - request & onLeftM \err -> failed (FastForwardPushError'UploadEntities <$> err) - where - request = - uploadEntities - unisonShareUrl - (Share.pathRepoInfo path) - (NESet.singleton (causalHashToHash32 headHash)) - uploadedCallback - - localInnerHashes <- - Cli.runTransaction doLoadCausalSpineBetween >>= \case - -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a - -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> failed (SyncError (FastForwardPushError'NotFastForward path)) - -- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push. - Just [] -> succeeded - -- drop remote hash - Just (_ : localInnerHashes) -> pure (map hash32ToCausalHash localInnerHashes) - - doUpload (localHeadHash :| localInnerHashes) - - let doFastForwardPath :: Cli Share.FastForwardPathResponse - doFastForwardPath = do - Cli.Env {authHTTPClient} <- ask - let request = - httpFastForwardPath - authHTTPClient - unisonShareUrl - Share.FastForwardPathRequest - { expectedHash = remoteHeadHash, - hashes = - causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), - path - } - liftIO request & onLeftM \err -> failed (TransportError err) - - doFastForwardPath >>= \case - Share.FastForwardPathSuccess -> succeeded - Share.FastForwardPathFailure err -> fastForwardPathError err - --- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments, --- excluding the newest hash (second argument). -loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32]) -loadCausalSpineBetween earlierHash laterHash = - dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash - -data Step a - = DeadEnd - | KeepSearching (List.NonEmpty a) - | FoundGoal a - --- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each --- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True). --- --- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because --- it was provided as an input ;)) --- --- For example, when searching a tree that looks like --- --- 1 --- / \ --- 2 3 --- / \ \ --- 4 [5] 6 --- --- (where the goal is marked [5]), we'd return --- --- Just [5,2] --- --- And (as another example), if the root node is the goal, --- --- [1] --- / \ --- 2 3 --- / \ \ --- 4 5 6 --- --- we'd return --- --- Just [] -dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a]) -dagbfs goal children = - let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied, - -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet. - -- (Otherwise, we wouldn't still be in this loop, we'd return!). - -- - -- For example, say we are exploring the tree - -- - -- 1 - -- / \ - -- 2 3 - -- / \ \ - -- 4 5 6 - -- - -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below - -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, - -- and maybe it doesn't). - -- - -- The loop state, in this case, would be these three paths: - -- - -- [ 4, 2 ] - -- [ 5, 2 ] - -- [ 6, 3 ] - -- - -- (Note, again, that we do not include the root). - go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) - go (path :<|| paths) = - -- Step forward from the first path in our loop state (in the example above, [4, 2]). - step (List.NonEmpty.head path) >>= \case - -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep - -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because - -- this was the only remaining path. - DeadEnd -> - case NESeq.nonEmptySeq paths of - Nothing -> pure Nothing - Just paths' -> go paths' - -- If node 4 did have children, then maybe the search tree now looks like this. - -- - -- 1 - -- / \ - -- 2 3 - -- / \ \ - -- 4 5 6 - -- / \ - -- 7 8 - -- - -- There are two cases to handle: - -- - -- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path - -- - -- [ 7, 4, 2 ] - -- - -- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end - -- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four - -- paths: - -- - -- [ 5, 2 ] \ these two are are variable 'paths', the tail of the loop state. - -- [ 6, 3 ] / - -- [ 7, 4, 2 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children - -- [ 8, 4, 2 ] / to itself, making two new paths to search - KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) - FoundGoal y -> pure (Just (List.NonEmpty.cons y path)) - - -- Step forward from a single node. There are 3 possible outcomes: - -- - -- 1. We discover it has no children. (return DeadEnd) - -- 2. We discover is has children, none of which are a goal. (return KeepSearching) - -- 3. We discover it has children, (at least) one of which is a goal. (return FoundGoal) - step :: a -> m (Step a) - step x = do - ys0 <- children x - pure case List.NonEmpty.nonEmpty ys0 of - Nothing -> DeadEnd - Just ys -> - case Foldable.find goal ys of - Nothing -> KeepSearching ys - Just y -> FoundGoal y - in \root -> - if goal root - then pure (Just []) - else - step root >>= \case - DeadEnd -> pure Nothing - -- lts-18.28 doesn't have List.NonEmpty.singleton - KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs)) - FoundGoal x -> pure (Just [x]) - where - -- Concatenate a seq and a non-empty seq. - append :: Seq x -> NESeq x -> NESeq x - append = (NESeq.><|) - ------------------------------------------------------------------------------------------------------------------------ -- Pull @@ -977,16 +673,6 @@ httpGetCausalHashByPath :: BaseUrl -> Share.GetCausalHashByPathRequest -> IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse) -httpFastForwardPath :: - Auth.AuthenticatedHttpClient -> - BaseUrl -> - Share.FastForwardPathRequest -> - IO (Either CodeserverTransportError Share.FastForwardPathResponse) -httpUpdatePath :: - Auth.AuthenticatedHttpClient -> - BaseUrl -> - Share.UpdatePathRequest -> - IO (Either CodeserverTransportError Share.UpdatePathResponse) httpDownloadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> @@ -998,14 +684,10 @@ httpUploadEntities :: Share.UploadEntitiesRequest -> IO (Either CodeserverTransportError Share.UploadEntitiesResponse) ( httpGetCausalHashByPath, - httpFastForwardPath, - httpUpdatePath, httpDownloadEntities, httpUploadEntities ) = let ( httpGetCausalHashByPath - Servant.:<|> httpFastForwardPath - Servant.:<|> httpUpdatePath Servant.:<|> httpDownloadEntities Servant.:<|> httpUploadEntities ) = @@ -1013,8 +695,6 @@ httpUploadEntities :: pp = Proxy in Servant.hoistClient pp hoist (Servant.client pp) in ( go httpGetCausalHashByPath, - go httpFastForwardPath, - go httpUpdatePath, go httpDownloadEntities, go httpUploadEntities ) diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index 1d14c32207..a53d14acbb 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -1,8 +1,6 @@ -- | Types used by the UCM client during sync. module Unison.Share.Sync.Types - ( CheckAndSetPushError (..), - CodeserverTransportError (..), - FastForwardPushError (..), + ( CodeserverTransportError (..), GetCausalHashByPathError (..), PullError (..), SyncError (..), @@ -13,29 +11,6 @@ import Servant.Client qualified as Servant import Unison.Prelude import Unison.Sync.Types qualified as Share --- | Error used by the client when pushing code to Unison Share. -data CheckAndSetPushError - = CheckAndSetPushError'UpdatePath - -- The repo we are pushing to. This is only necessary because an UpdatePathError does not have enough context to - -- print the entire error message we want to print, but it really should, at which point maybe this can go away. - Share.RepoInfo - Share.UpdatePathError - | CheckAndSetPushError'UploadEntities Share.UploadEntitiesError - deriving stock (Show) - --- | An error occurred while fast-forward pushing code to Unison Share. -data FastForwardPushError - = FastForwardPushError'FastForwardPath - -- The path we are fast forwarding. This is only necessary because a FastForwardPathError does not have enough - -- context to print the entire error message we want to print, but it really should, at which point maybe this can - -- go away. - Share.Path - Share.FastForwardPathError - | FastForwardPushError'GetCausalHash GetCausalHashByPathError - | FastForwardPushError'NotFastForward Share.Path - | FastForwardPushError'UploadEntities Share.UploadEntitiesError - deriving stock (Show) - -- | An error occurred while pulling code from Unison Share. data PullError = PullError'DownloadEntities Share.DownloadEntitiesError diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 754931f8b1..5cafebdfc3 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -11,8 +11,6 @@ api = Proxy type API = "path" :> "get" :> GetCausalHashByPathEndpoint - :<|> "path" :> "fast-forward" :> FastForwardPathEndpoint - :<|> "path" :> "update" :> UpdatePathEndpoint :<|> "entities" :> "download" :> DownloadEntitiesEndpoint :<|> "entities" :> "upload" :> UploadEntitiesEndpoint @@ -20,14 +18,6 @@ type GetCausalHashByPathEndpoint = ReqBody '[JSON] GetCausalHashByPathRequest :> Post '[JSON] GetCausalHashByPathResponse -type FastForwardPathEndpoint = - ReqBody '[JSON] FastForwardPathRequest - :> Post '[JSON] FastForwardPathResponse - -type UpdatePathEndpoint = - ReqBody '[JSON] UpdatePathRequest - :> Post '[JSON] UpdatePathResponse - type DownloadEntitiesEndpoint = ReqBody '[JSON] DownloadEntitiesRequest :> Post '[JSON] DownloadEntitiesResponse diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index ccd680135f..4b37cfaf21 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -48,11 +48,6 @@ module Unison.Sync.Types UploadEntitiesResponse (..), UploadEntitiesError (..), - -- ** Fast-forward path - FastForwardPathRequest (..), - FastForwardPathResponse (..), - FastForwardPathError (..), - -- ** Update path UpdatePathRequest (..), UpdatePathResponse (..), @@ -747,115 +742,13 @@ instance FromJSON HashMismatchForEntity where Aeson.withObject "HashMismatchForEntity" \obj -> HashMismatchForEntity <$> obj - .: "supplied" + .: "supplied" <*> obj - .: "computed" - ------------------------------------------------------------------------------------------------------------------------- --- Fast-forward path - --- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to --- fast-forward to back to wherever the (client believes the) server is (including the server head, in a separate --- field). --- --- For example, if the client wants to update --- --- @ --- A -> B -> C --- @ --- --- to --- --- @ --- A -> B -> C -> D -> E -> F --- @ --- --- then it would send hashes --- --- @ --- expectedHash = C --- hashes = [D, E, F] --- @ --- --- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint --- instead. -data FastForwardPathRequest = FastForwardPathRequest - { -- | The causal that the client believes exists at `path` - expectedHash :: Hash32, - -- | The sequence of causals to fast-forward with, starting from the oldest new causal to the newest new causal - hashes :: NonEmpty Hash32, - -- | The path to fast-forward - path :: Path - } - deriving stock (Show) - -instance ToJSON FastForwardPathRequest where - toJSON FastForwardPathRequest {expectedHash, hashes, path} = - object - [ "expected_hash" .= expectedHash, - "hashes" .= hashes, - "path" .= path - ] - -instance FromJSON FastForwardPathRequest where - parseJSON = - Aeson.withObject "FastForwardPathRequest" \o -> do - expectedHash <- o .: "expected_hash" - hashes <- o .: "hashes" - path <- o .: "path" - pure FastForwardPathRequest {expectedHash, hashes, path} - -data FastForwardPathResponse - = FastForwardPathSuccess - | FastForwardPathFailure FastForwardPathError - deriving stock (Show) - -data FastForwardPathError - = FastForwardPathError'MissingDependencies (NeedDependencies Hash32) - | FastForwardPathError'NoWritePermission Path - | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. - FastForwardPathError'NotFastForward HashJWT - | -- | There was no history at this path; the client should use the "update path" endpoint instead. - FastForwardPathError'NoHistory - | -- | This wasn't a fast-forward. You said the first hash was a parent of the second hash, but I disagree. - FastForwardPathError'InvalidParentage InvalidParentage - | FastForwardPathError'InvalidRepoInfo Text RepoInfo - | FastForwardPathError'UserNotFound - deriving stock (Show) + .: "computed" data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} deriving stock (Show) -instance ToJSON FastForwardPathResponse where - toJSON = \case - FastForwardPathSuccess -> jsonUnion "success" (Object mempty) - (FastForwardPathFailure (FastForwardPathError'MissingDependencies deps)) -> jsonUnion "missing_dependencies" deps - (FastForwardPathFailure (FastForwardPathError'NoWritePermission path)) -> jsonUnion "no_write_permission" path - (FastForwardPathFailure (FastForwardPathError'NotFastForward hashJwt)) -> jsonUnion "not_fast_forward" hashJwt - (FastForwardPathFailure FastForwardPathError'NoHistory) -> jsonUnion "no_history" (Object mempty) - (FastForwardPathFailure (FastForwardPathError'InvalidParentage invalidParentage)) -> - jsonUnion "invalid_parentage" invalidParentage - (FastForwardPathFailure (FastForwardPathError'InvalidRepoInfo msg repoInfo)) -> - jsonUnion "invalid_repo_info" (msg, repoInfo) - (FastForwardPathFailure FastForwardPathError'UserNotFound) -> - jsonUnion "user_not_found" (Object mempty) - -instance FromJSON FastForwardPathResponse where - parseJSON = - Aeson.withObject "FastForwardPathResponse" \o -> - o .: "type" >>= Aeson.withText "type" \case - "success" -> pure FastForwardPathSuccess - "missing_dependencies" -> FastForwardPathFailure . FastForwardPathError'MissingDependencies <$> o .: "payload" - "no_write_permission" -> FastForwardPathFailure . FastForwardPathError'NoWritePermission <$> o .: "payload" - "not_fast_forward" -> FastForwardPathFailure . FastForwardPathError'NotFastForward <$> o .: "payload" - "no_history" -> pure (FastForwardPathFailure FastForwardPathError'NoHistory) - "invalid_parentage" -> FastForwardPathFailure . FastForwardPathError'InvalidParentage <$> o .: "payload" - "invalid_repo_info" -> do - (msg, repoInfo) <- o .: "payload" - pure (FastForwardPathFailure (FastForwardPathError'InvalidRepoInfo msg repoInfo)) - "user_not_found" -> pure (FastForwardPathFailure FastForwardPathError'UserNotFound) - t -> failText $ "Unexpected FastForwardPathResponse type: " <> t - instance ToJSON InvalidParentage where toJSON (InvalidParentage parent child) = object ["parent" .= parent, "child" .= child] From 5b0045dc66d48fa53f81f3898486d01631d5b209 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 14:50:44 -0700 Subject: [PATCH 49/76] Fix ReleaseDraft --- .../Codebase/Editor/HandleInput/ReleaseDraft.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs index 13caf9b1ac..e6cdbffc7e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs @@ -6,8 +6,8 @@ where import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli -import Unison.Cli.ProjectUtils qualified as ProjectUtils -import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), doCreateBranch) +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), createBranch) import Unison.Codebase.Editor.Output qualified as Output import Unison.Prelude import Unison.Project (Semver) @@ -16,15 +16,15 @@ import Witch (unsafeFrom) -- | Handle a @release.draft@ command. handleReleaseDraft :: Semver -> Cli () handleReleaseDraft ver = do - currentProjectAndBranch <- fst <$> ProjectUtils.expectCurrentProjectBranch + currentProjectAndBranch <- Cli.getCurrentProjectAndBranch let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver) _ <- - doCreateBranch - (CreateFrom'Branch currentProjectAndBranch) - (currentProjectAndBranch ^. #project) - branchName + createBranch ("release.draft " <> into @Text ver) + (CreateFrom'ParentBranch (currentProjectAndBranch ^. #branch)) + (currentProjectAndBranch ^. #project) + (pure branchName) Cli.respond (Output.DraftingRelease branchName ver) From 9936a02f556716b3b61756b2f77ebf6b15bd75e2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 14:53:20 -0700 Subject: [PATCH 50/76] Fix Upgrade --- .../Codebase/Editor/HandleInput/Branch.hs | 8 ++++---- .../Codebase/Editor/HandleInput/Upgrade.hs | 20 +++++++++---------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index d320fe04b3..ab26f12f34 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -99,7 +99,7 @@ createBranch :: CreateFrom -> Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> - Cli ProjectBranchId + Cli (ProjectBranchName, ProjectBranchId) createBranch description createFrom project getNewBranchName = do let projectId = project ^. #projectId Cli.Env {codebase} <- ask @@ -121,7 +121,7 @@ createBranch description createFrom project getNewBranchName = do Cli.runTransaction $ do newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch) pure (Nothing, newBranchCausalHashId) - newBranchId <- + (newBranchName, newBranchId) <- Cli.runTransactionWithRollback \rollback -> do newBranchName <- getNewBranchName Queries.projectBranchExistsByName projectId newBranchName >>= \case @@ -139,7 +139,7 @@ createBranch description createFrom project getNewBranchName = do name = newBranchName, parentBranchId = mayParentBranchId } - pure newBranchId + pure (newBranchName, newBranchId) Cli.switchProject (ProjectAndBranch projectId newBranchId) - pure newBranchId + pure (newBranchName, newBranchId) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 5b816c87b7..59237c56bd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -18,6 +18,7 @@ import Unison.Cli.ProjectUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (CreateFrom'ParentBranch)) import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch import Unison.Codebase.Editor.HandleInput.Update2 ( addDefinitionsToUnisonFile, @@ -148,26 +149,24 @@ handleUpgrade oldName newName = do `PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents ) - pp@(PP.ProjectPath project branch pathInProject) <- Cli.getCurrentProjectPath + (PP.ProjectPath project projectBranch pathInProject) <- Cli.getCurrentProjectPath parsingEnv <- makeParsingEnv pathInProject currentDeepNamesSansOld typecheckedUnisonFile <- prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do - -- Small race condition: since picking a branch name and creating the branch happen in different - -- transactions, creating could fail. - temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName (project ^. #projectId) oldName newName) - temporaryBranchId <- - HandleInput.Branch.createBranchFromParent + let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName + (temporaryBranchName, _temporaryBranchId) <- + HandleInput.Branch.createBranch textualDescriptionOfUpgrade - (Just branch) + (CreateFrom'ParentBranch projectBranch) project - temporaryBranchName + getTemporaryBranchName scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" Just (file, _) -> file liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) Cli.returnEarly $ - Output.UpgradeFailure branch.name temporaryBranchName scratchFilePath oldName newName + Output.UpgradeFailure (projectBranch ^. #name) temporaryBranchName scratchFilePath oldName newName branchUpdates <- Cli.runTransactionWithRollback \abort -> do @@ -177,8 +176,9 @@ handleUpgrade oldName newName = do (findCtorNamesMaybe Output.UOUUpgrade currentLocalNames currentLocalConstructorNames Nothing) typecheckedUnisonFile Cli.stepAt + projectBranch textualDescriptionOfUpgrade - ( Path.unabsolute projectPath, + ( Path.absoluteEmpty, Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates ) Cli.respond (Output.UpgradeSuccess oldName newName) From 1e4627b393cb1def47d0594b70d9fb5b5ed139ad Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 14:58:28 -0700 Subject: [PATCH 51/76] Fix update.old --- unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index 1f2538891a..39cc4acc23 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs @@ -74,6 +74,7 @@ import Unison.WatchKind (WatchKind) handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli () handleUpdate input optionalPatch requestedNames = do Cli.Env {codebase} <- ask + pp <- Cli.getCurrentProjectPath currentPath' <- Cli.getCurrentPath let patchPath = case optionalPatch of @@ -211,7 +212,7 @@ handleUpdate input optionalPatch requestedNames = do & Path.unsplit' & Path.resolve @_ @_ @Path.Absolute currentPath' & tShow - Cli.updateRoot branchWithPropagatedPatch description + void $ Cli.updateAt description pp (const branchWithPropagatedPatch) getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult getSlurpResultForUpdate requestedNames slurpCheckNames = do From 7b5845ff2e2cd7043970aefbfefbef8de05240eb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 15:01:53 -0700 Subject: [PATCH 52/76] Fix AddRun --- unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs index 7d24986d27..8ef0550a30 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs @@ -19,7 +19,7 @@ import Unison.Codebase.Editor.Input (Input) import Unison.Codebase.Editor.Output (Output (NoLastRunResult, SaveTermNameConflict, SlurpOutput)) import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Name (Name) @@ -37,13 +37,13 @@ handleAddRun input resultName = do let resultVar = Name.toVar resultName uf <- addSavedTermToUnisonFile resultName Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath currentNames <- Cli.currentNames let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames let adds = SlurpResult.adds sr Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf let description = (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName) - Cli.stepAt description (Path.unabsolute currentPath, doSlurpAdds adds uf) + PP.ProjectPath _proj pb currentPath <- Cli.getCurrentProjectPath + Cli.stepAt pb description (currentPath, doSlurpAdds adds uf) let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile let suffixifiedPPE = PPE.suffixifiedPPE pped From b1ad1599ed6289cdfab0058c7bb92d5717d4507a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 15:04:19 -0700 Subject: [PATCH 53/76] Fix up Pull --- .../Codebase/Editor/HandleInput/Pull.hs | 20 +++++++++---------- .../src/Unison/Codebase/Editor/Output.hs | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index fec305abd3..886f7d2a46 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -21,23 +21,21 @@ import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli +import Unison.Cli.NamesUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share 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.Branch.Names 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 import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.Output.PushPull qualified as PushPull import Unison.Codebase.Editor.Propagate qualified as Propagate import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace) -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 @@ -260,7 +258,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb mergeBranch = Cli.time "mergeBranch" do Cli.Env {codebase} <- ask - destb <- Cli.getBranchAt dest + destb <- Cli.getBranchFromProjectPath dest merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb) b <- Cli.updateAtM inputDescription dest (const $ pure merged) for_ maybeDest0 \dest0 -> do @@ -271,18 +269,18 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb loadPropagateDiffDefaultPatch :: Text -> Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> - Path.Absolute -> + PP.ProjectPath -> Cli () loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do Cli.respond Output.AboutToPropagatePatch Cli.time "loadPropagateDiffDefaultPatch" do - original <- Cli.getBranch0At dest + original <- Cli.getBranch0FromProjectPath dest patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original patchDidChange <- propagatePatch inputDescription patch dest when patchDidChange do whenJust maybeDest0 \dest0 -> do Cli.respond Output.CalculatingDiff - patched <- Cli.getBranchAt dest + patched <- Cli.getBranchFromProjectPath dest let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment]))) (ppe, diff) <- diffHelper original (Branch.head patched) Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff) @@ -291,11 +289,13 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do propagatePatch :: Text -> Patch -> - Path.Absolute -> + PP.ProjectPath -> Cli Bool propagatePatch inputDescription patch scopePath = do + let pb = scopePath ^. #branch Cli.time "propagatePatch" do - rootNames <- Branch.toNames <$> Cli.getRootBranch0 + rootNames <- Cli.projectBranchNames pb Cli.stepAt' + pb (inputDescription <> " (applying patch)") - (Path.unabsolute scopePath, Propagate.propagateAndApply rootNames patch) + (scopePath ^. PP.absPath_, Propagate.propagateAndApply rootNames patch) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index b137b5d32f..f15608cbbc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -105,7 +105,7 @@ data NumberedOutput (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePropagate (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + ProjectPath Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) From 0b16a7c9de7dbefc8f52cd1f52a25551d194fbd0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 7 Jun 2024 15:10:10 -0700 Subject: [PATCH 54/76] Fixup BranchId --- .../src/Unison/Codebase/ProjectPath.hs | 4 + unison-cli/src/Unison/Cli/MonadUtils.hs | 12 +-- unison-cli/src/Unison/Cli/Pretty.hs | 5 +- .../src/Unison/Codebase/Editor/Input.hs | 24 +++--- .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 79 +++++++++++-------- 6 files changed, 75 insertions(+), 51 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 5c249cea40..2694d26b51 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -43,6 +43,10 @@ type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName +instance From ProjectPathNames Text where + from (ProjectPath proj branch path) = + into @Text (ProjectAndBranch proj branch) <> ":" <> Path.absToText path + type ProjectPath = ProjectPathG Project ProjectBranch projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index f80a916a0a..5587f88694 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -201,10 +201,11 @@ resolveSplit' = -- branches by path are OK - the empty branch will be returned). resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO) resolveAbsBranchId = \case - Left hash -> resolveShortCausalHash hash - Right absPath -> do + Input.BranchAtSCH hash -> resolveShortCausalHash hash + Input.BranchAtPath absPath -> do pp <- resolvePath' (Path' (Left absPath)) getBranchFromProjectPath pp + Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp -- | V2 version of 'resolveAbsBranchId2'. resolveAbsBranchIdV2 :: @@ -213,13 +214,14 @@ resolveAbsBranchIdV2 :: Input.AbsBranchId -> Sqlite.Transaction (V2.Branch Sqlite.Transaction) resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case - Left shortHash -> do + Input.BranchAtSCH shortHash -> do hash <- resolveShortCausalHashToCausalHash rollback shortHash causal <- (Codebase.expectCausalBranchByCausalHash hash) V2Causal.value causal - Right absPath -> do + Input.BranchAtPath absPath -> do let pp = PP.ProjectPath proj branch absPath Codebase.getShallowBranchAtProjectPath pp + Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp -- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent -- branches by path are OK - the empty branch will be returned). @@ -231,7 +233,7 @@ resolveBranchId branchId = do -- | Resolve a @BranchId@ to an @AbsBranchId@. resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId resolveBranchIdToAbsBranchId = - traverseOf _Right (fmap (view PP.absPath_) . resolvePath') + traverse (fmap (view PP.absPath_) . resolvePath') -- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found. resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 0f18f47b09..0c51349383 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -187,8 +187,9 @@ prettyNamespaceKey = \case prettyBranchId :: Input.AbsBranchId -> Pretty prettyBranchId = \case - Left sch -> prettySCH sch - Right absPath -> prettyAbsolute $ absPath + Input.BranchAtSCH sch -> prettySCH sch + Input.BranchAtPath absPath -> prettyAbsolute $ absPath + Input.BranchAtProjectPath pp -> prettyProjectPath pp prettyRelative :: Path.Relative -> Pretty prettyRelative = P.blue . P.shown diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 46cab3a744..84af51ddd1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -9,6 +9,7 @@ module Unison.Codebase.Editor.Input Event (..), OutputLocation (..), PatchPath, + BranchIdG (..), BranchId, AbsBranchId, UnresolvedProjectBranch, @@ -35,6 +36,7 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -60,15 +62,19 @@ type PatchPath = Path.Split' data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath deriving (Eq, Ord, Show) -type BranchId = Either ShortCausalHash Path' +data BranchIdG p + = BranchAtSCH ShortCausalHash + | BranchAtPath p + | BranchAtProjectPath ProjectPath + deriving stock (Eq, Show, Functor, Foldable, Traversable) + +type BranchId = BranchIdG Path' + +type AbsBranchId = BranchIdG Path.Absolute -- | An unambiguous project branch name, use the current project name if not provided. type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName --- | TODO: You should probably use a `ProjectPath` instead of a `Path.Absolute` in most --- cases. -type AbsBranchId = Either ShortCausalHash Path.Absolute - type HashOrHQSplit' = Either ShortHash Path.HQSplit' -- | Should we force the operation or not? @@ -78,8 +84,8 @@ data Insistence = Force | Try parseBranchId :: String -> Either Text BranchId parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of Nothing -> Left "Invalid hash, expected a base32hex string." - Just h -> pure $ Left h -parseBranchId s = Right <$> Path.parsePath' s + Just h -> pure $ BranchAtSCH h +parseBranchId s = BranchAtPath <$> Path.parsePath' s parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of @@ -110,10 +116,10 @@ data Input | DiffNamespaceI BranchId BranchId -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput - | ResetRootI (Either ShortCausalHash Path') + | ResetRootI BranchId | ResetI ( These - (Either ShortCausalHash Path') + BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ) (Maybe UnresolvedProjectBranch) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index f15608cbbc..6880948800 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -111,7 +111,7 @@ data NumberedOutput (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePreview (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 5195866641..47f8207caf 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -168,7 +168,7 @@ import Unison.Cli.Pretty import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) +import Unison.Codebase.Editor.Input (BranchIdG (..), DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) @@ -246,8 +246,13 @@ formatStructuredArgument schLength = \case -- 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) + BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + BranchAtPath pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) + BranchAtProjectPath pp -> + pp + & PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name)) + & PP.toNames + & into @Text entryToHQText :: Path' -> ShallowListEntry v Ann -> Text entryToHQText pathArg = @@ -428,8 +433,8 @@ handleSplitArg = (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 + SA.NameWithBranchPrefix (BranchAtSCH _) name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (BranchAtPath prefix) name | Name.isRelative name -> pure . Path.splitFromName . Name.makeAbsolute $ Path.prefixName prefix name otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg @@ -439,8 +444,8 @@ handleSplit'Arg = (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 -> + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg @@ -457,11 +462,17 @@ 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.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path + SA.Name name -> pure . BranchAtPath $ 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 + pure $ case mprefix of + BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name + BranchAtPath prefix -> BranchAtPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + BranchAtProjectPath pp -> + pp + & PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name)) + & BranchAtProjectPath + SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg handleBranchIdOrProjectArg :: @@ -471,13 +482,13 @@ 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 + SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path + SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . This . BranchAtPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch pb -> pure $ That pb otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType where branchIdOrProject :: @@ -506,8 +517,8 @@ handleBranchId2Arg = SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure . pure . UnqualifiedPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name SA.ProjectBranch (ProjectAndBranch mproject branch) -> case mproject of @@ -522,8 +533,8 @@ handleBranchRelativePathArg = \case SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . UnqualifiedPath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure . UnqualifiedPath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name SA.ProjectBranch (ProjectAndBranch mproject branch) -> case mproject of @@ -559,8 +570,8 @@ handleHashQualifiedSplit'Arg = (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 -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath 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 @@ -572,8 +583,8 @@ handleHashQualifiedSplitArg = (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 -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath 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 @@ -594,8 +605,8 @@ handleShortHashOrHQSplit'Arg = (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 -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath 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 @@ -614,11 +625,11 @@ handleNameArg = (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.NameWithBranchPrefix (BranchAtSCH _) name -> pure name + SA.NameWithBranchPrefix (BranchAtPath 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 -> + SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (BranchAtPath 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 @@ -1510,7 +1521,7 @@ history = ) \case [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src - [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) + [] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.currentPath) _ -> Left (I.help history) forkLocal :: InputPattern @@ -2097,7 +2108,7 @@ diffNamespace = ) ( \case [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after - [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) + [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (BranchAtPath Path.currentPath) _ -> Left $ I.help diffNamespace ) where From 7274361ec2f7874f9271f13c4d875d474737f1cb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 10:26:19 -0700 Subject: [PATCH 55/76] Fix up Pull and output messages --- unison-cli/src/Unison/Cli/Pretty.hs | 6 +++--- .../src/Unison/Codebase/Editor/HandleInput/Pull.hs | 9 ++++----- unison-cli/src/Unison/Codebase/Editor/Output.hs | 12 ++++++------ unison-cli/src/Unison/CommandLine/OutputMessages.hs | 9 +++++---- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 0c51349383..7052e7b87d 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -75,8 +75,8 @@ import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), ) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -179,9 +179,9 @@ prettyPath' p' = then "the current namespace" else P.blue (P.shown p') -prettyNamespaceKey :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty +prettyNamespaceKey :: Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty prettyNamespaceKey = \case - Left path -> prettyPath' path + Left path -> prettyProjectPath path Right (ProjectAndBranch project branch) -> prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 886f7d2a46..9eebe820c9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -37,7 +37,6 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Propagate qualified as Propagate import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace) import Unison.Codebase.Patch (Patch (..)) -import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.InputPattern qualified as InputPattern @@ -92,11 +91,11 @@ handlePull unresolvedSourceAndTarget pullMode = do Input.PullWithHistory -> do targetBranch <- Cli.getBranchFromProjectPath targetProjectPath - if Branch.isEmpty0 $ Branch.head targetBranchObject + if Branch.isEmpty0 $ Branch.head targetBranch then do Cli.Env {codebase} <- ask remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) - void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) + void $ Cli.updateAtM description targetProjectPath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do Cli.respond AboutToMerge @@ -133,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do didUpdate <- Cli.updateAtM description - targetAbsolutePath + targetProjectPath (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) Cli.respond @@ -268,7 +267,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb loadPropagateDiffDefaultPatch :: Text -> - Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> + Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> PP.ProjectPath -> Cli () loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 6880948800..807805e301 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -99,18 +99,18 @@ data NumberedOutput | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMerge - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePropagate - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ProjectPath Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePreview - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) @@ -291,8 +291,8 @@ data Output | -- 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)) + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) | -- | No conflicts or edits remain for the current patch. NoConflictsOrEdits | NotImplemented diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index bc95371850..f58aa7458d 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -150,6 +150,7 @@ import Unison.Var (Var) import Unison.Var qualified as Var import Unison.WatchKind qualified as WK import Witch (unsafeFrom) +import Unison.Codebase.Editor.Input (BranchIdG(..)) reportBugURL :: Pretty reportBugURL = "https://github.com/unisonweb/unison/issues/new" @@ -228,7 +229,7 @@ notifyNumbered = \case <> " to undo the results of this merge." ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput -> first ( \p -> @@ -255,7 +256,7 @@ notifyNumbered = \case <> " to undo the results of this merge." ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterMergePreview dest' destAbs ppe diffOutput -> first ( \p -> @@ -265,7 +266,7 @@ notifyNumbered = \case p ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterUndo ppe diffOutput -> first (\p -> P.lines ["Here are the changes I undid", "", p]) @@ -532,7 +533,7 @@ notifyNumbered = \case & fmap (\name -> formatNum (getNameNumber name) <> prettyName name) & P.lines where - absPathToBranchId = Right + absPathToBranchId = BranchAtPath undoTip :: P.Pretty P.ColorText undoTip = From a7d455c490475e3ca54b236e3c2653e78712a355 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 10:37:55 -0700 Subject: [PATCH 56/76] Fix CommitUpgrade --- .../src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index 76229b8bfd..35ebe12519 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -8,10 +8,10 @@ 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.MonadUtils 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 @@ -19,7 +19,7 @@ import Unison.Project (ProjectAndBranch (..)) handleCommitUpgrade :: Cli () handleCommitUpgrade = do - (upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + upgradeProjectAndBranch <- Cli.getCurrentProjectAndBranch -- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`. @@ -35,7 +35,7 @@ handleCommitUpgrade = do -- Switch to the parent - ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) + Cli.switchProject (ProjectUtils.justTheIds parentProjectAndBranch) -- Merge the upgrade branch into the parent From 87c9d5b1d1f331136aa552a12b87b7752598f0ec Mon Sep 17 00:00:00 2001 From: ChrisPenner Date: Mon, 10 Jun 2024 17:40:25 +0000 Subject: [PATCH 57/76] automatically run ormolu --- unison-share-api/src/Unison/Sync/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 4b37cfaf21..98d713f660 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -742,9 +742,9 @@ instance FromJSON HashMismatchForEntity where Aeson.withObject "HashMismatchForEntity" \obj -> HashMismatchForEntity <$> obj - .: "supplied" + .: "supplied" <*> obj - .: "computed" + .: "computed" data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} deriving stock (Show) From 1faba8442dfd11f0552bf3dbb2b6b4ee6a5e3cbc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 10:39:32 -0700 Subject: [PATCH 58/76] Don't expose dangerous primitives for setting project root --- unison-cli/src/Unison/Cli/MonadUtils.hs | 32 ++++++++----------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5587f88694..868b7bb3ab 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -27,8 +27,6 @@ module Unison.Cli.MonadUtils resolveShortCausalHash, -- ** Getting/setting branches - setCurrentProjectRoot, - modifyProjectRoot, getCurrentProjectRoot, getCurrentProjectRoot0, getCurrentBranch, @@ -270,25 +268,6 @@ getCurrentProjectRoot0 :: Cli (Branch0 IO) getCurrentProjectRoot0 = Branch.head <$> getCurrentProjectRoot --- | Set a new root branch. --- --- Note: This does _not_ update the codebase, the caller is responsible for that. -setCurrentProjectRoot :: Branch IO -> Cli () -setCurrentProjectRoot b = do - void $ modifyProjectRoot (const b) - --- | Modify the root branch. --- --- Note: This does _not_ update the codebase, the caller is responsible for that. -modifyProjectRoot :: (Branch IO -> Branch IO) -> Cli (Branch IO) -modifyProjectRoot f = do - rootVar <- use #currentProjectRoot - atomically do - root <- takeTMVar rootVar - let !newRoot = f root - putTMVar rootVar newRoot - pure newRoot - -- | Get the current branch. getCurrentBranch :: Cli (Branch IO) getCurrentBranch = do @@ -464,6 +443,7 @@ updateAndStepAt reason projectBranch updates steps = do updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r updateProjectBranchRoot projectBranch reason f = do + currentPB <- getCurrentProjectBranch Cli.Env {codebase} <- ask Cli.time "updateProjectBranchRoot" do old <- getProjectBranchRoot projectBranch @@ -472,8 +452,16 @@ updateProjectBranchRoot projectBranch reason f = do Cli.runTransaction $ do causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId - setCurrentProjectRoot new + if projectBranch.branchId == currentPB.branchId + then setCurrentProjectRoot new + else pure () pure result + where + setCurrentProjectRoot :: Branch IO -> Cli () + setCurrentProjectRoot !newRoot = do + rootVar <- use #currentProjectRoot + atomically do + void $ swapTMVar rootVar newRoot updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () updateProjectBranchRoot_ projectBranch reason f = do From 6d78dabea751175b3a5d954417ced42f7811a574 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 10:39:32 -0700 Subject: [PATCH 59/76] Fix up most imports in HandleInput --- unison-cli/src/Unison/Cli/ProjectUtils.hs | 15 ++- .../src/Unison/Codebase/Editor/HandleInput.hs | 124 +++++++----------- 2 files changed, 61 insertions(+), 78 deletions(-) diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 11aeba7a00..65c480f217 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -4,6 +4,7 @@ module Unison.Cli.ProjectUtils expectProjectBranchByName, resolveBranchRelativePath, resolveProjectBranch, + resolveProjectBranchInProject, -- * Name hydration hydrateNames, @@ -201,13 +202,23 @@ expectProjectAndBranchByTheseNames = \case -- 1. If the project is missing, use the provided project. -- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided -- project, defaulting to 'main' if branch is unspecified. -resolveProjectBranch :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do +resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName let projectName = fromMaybe (defaultProj ^. #name) mayProjectName projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName) pure projectAndBranch +-- | Expect/resolve branch reference with the following rules: +-- +-- 1. If the project is missing, use the current project. +-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current +-- project, defaulting to 'main' if branch is unspecified. +resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranch pab = do + pp <- Cli.getCurrentProjectPath + resolveProjectBranchInProject (pp ^. #project) pab + -- | Get the causal hash of a project branch. getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6c572676f8..074494cfef 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -37,6 +37,7 @@ import Unison.Builtin qualified as Builtin import Unison.Builtin.Terms qualified as Builtin import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils (getCurrentProjectBranch) import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.NamesUtils qualified as Cli import Unison.Cli.PrettyPrintUtils qualified as Cli @@ -108,6 +109,7 @@ 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.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.CommandLine.BranchRelativePath (BranchRelativePath) @@ -259,16 +261,8 @@ loop e = do Left hash -> Cli.resolveShortCausalHash hash Right path' -> Cli.expectBranchAtPath' path' That (ProjectAndBranch mProjectName branchName) -> do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg - Cli.expectBranchAtPath' - ( Path.absoluteToPath' - ( ProjectUtils.projectBranchPath - (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)) - ) - ) + newProjectAndBranch <- ProjectUtils.resolveProjectBranch mProjectName (Just branchName) + Cli.getProjectBranchRoot newProjectAndBranch.branch These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do absPath <- case branchId of Left hash -> jump =<< Cli.resolveShortCausalHash hash @@ -342,33 +336,30 @@ loop e = do Left hash -> Cli.resolveShortCausalHash hash Right path' -> Cli.expectBranchAtPath' path' description <- inputDescription input - Cli.updateCurrentProjectRoot newRoot description + pb <- getCurrentProjectBranch + Cli.updateAtM "reset-root" (PP.projectBranchRoot pb) newRoot description Cli.respond Success ForkLocalBranchI src0 dest0 -> do (srcb, branchEmpty) <- case src0 of Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash Right path' -> do - absPath <- ProjectUtils.branchRelativePathToAbsolute path' - let srcp = Path.convert absPath - srcb <- Cli.expectBranchAtPath' srcp + srcPP <- ProjectUtils.resolveBranchRelativePath path' + srcb <- Cli.getBranchFromProjectPath srcPP `whenNothingM` pure Branch.empty pure (srcb, WhichBranchEmptyPath srcp) description <- inputDescription input - dest <- ProjectUtils.branchRelativePathToAbsolute dest0 + dest <- ProjectUtils.resolveBranchRelativePath dest0 ok <- Cli.updateAtM description dest (const $ pure srcb) Cli.respond if ok then Success else BranchEmpty branchEmpty MergeI branch -> handleMerge branch - MergeLocalBranchI src0 dest0 mergeMode -> do + MergeLocalBranchI unresolvedSrc unresolvedDest mergeMode -> do description <- inputDescription input - src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0 - dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0 - let srcp = looseCodeOrProjectToPath src0 - let destp = looseCodeOrProjectToPath dest0 - srcb <- Cli.expectBranchAtPath' srcp - dest <- Cli.resolvePath' destp + srcPaB <- ProjectUtils.resolveProjectBranch (second Just src0) + destPaB <- ProjectUtils.resolveProjectBranch (second Just dest0) + srcBranch <- Cli.getProjectBranchRoot srcPaB.branch let err = Just $ MergeAlreadyUpToDate @@ -377,11 +368,9 @@ loop e = do mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest PreviewMergeLocalBranchI src0 dest0 -> do Cli.Env {codebase} <- ask - src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0 - dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0 - srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0 - dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0 - destb <- Cli.getBranchAt dest + srcPaB <- ProjectUtils.resolveProjectBranch (second Just src0) + destPaB <- ProjectUtils.resolveProjectBranch (second Just dest0) + srcBranch <- Cli.getProjectBranchRoot srcPaB.branch merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) if merged == destb then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0) @@ -421,8 +410,8 @@ loop e = do case from of Left hash -> Cli.resolveShortCausalHash hash Right path' -> do - path <- Cli.resolvePath' path' - Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path)) + pp <- Cli.resolvePath' path' + Cli.getBranchFromProjectPath pp schLength <- Cli.runTransaction Codebase.branchHashLength history <- liftIO (doHistory schLength 0 branch []) Cli.respondNumbered history @@ -440,7 +429,7 @@ loop e = do let elem = (Branch.headHash b, Branch.namesDiff b' b) doHistory schLength (n + 1) b' (elem : acc) UndoI -> do - rootBranch <- Cli.getProjectRoot + rootBranch <- Cli.getCurrentProjectRoot (_, prev) <- liftIO (Branch.uncons rootBranch) & onNothingM do Cli.returnEarly . CantUndo $ @@ -448,7 +437,8 @@ loop e = do then CantUndoPastStart else CantUndoPastMerge description <- inputDescription input - Cli.updateCurrentProjectRoot prev description + pb <- getCurrentProjectBranch + Cli.updateProjectBranchRoot pb prev description (ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch) Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff) UiI path' -> openUI path' @@ -467,8 +457,8 @@ loop e = do Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText) DocsToHtmlI namespacePath' sourceDirectory -> do Cli.Env {codebase, sandboxedRuntime} <- ask - absPath <- Cli.resolvePath' namespacePath' - branch <- liftIO $ Codebase.getBranchAtPath codebase absPath + projPath <- Cli.resolvePath' namespacePath' + branch <- Cli.getBranchFromProjectPath projPath _evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory) pure () AliasTermI src' dest' -> do @@ -522,14 +512,14 @@ loop e = do -- this implementation will happily produce name conflicts, -- but will surface them in a normal diff at the end of the operation. AliasManyI srcs dest' -> do - root0 <- Cli.getProjectRoot0 + root0 <- Cli.getCurrentProjectRoot0 currentBranch0 <- Cli.getCurrentBranch0 - destAbs <- Cli.resolvePath' dest' - old <- Cli.getBranch0At destAbs + destPP <- Cli.resolvePath' dest' + old <- Cli.getBranch0FromProjectPath destPP description <- inputDescription input let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs Cli.stepManyAt description actions - new <- Cli.getBranch0At destAbs + new <- Cli.getBranch0FromProjectPath destPP (ppe, diff) <- diffHelper old new Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff) when (not (null unknown)) do @@ -579,14 +569,9 @@ loop e = do NamesI global query -> do hqLength <- Cli.runTransaction Codebase.hashLength (names, pped) <- - if global || any Name.isAbsolute query + if global then do - -- TODO: Use some global names index here - root0 <- Cli.getProjectRoot0 - -- Use an absolutely qualified ppe for view.global - let names = Names.makeAbsolute $ Branch.toNames root0 - let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names) - pure (names, pped) + error "TODO: Implement names.global." else do names <- Cli.currentNames pped <- Cli.prettyPrintEnvDeclFromNames names @@ -652,7 +637,8 @@ loop e = do if hasConfirmed || insistence == Force then do description <- inputDescription input - Cli.updateRoot Branch.empty description + pb <- Cli.getCurrentProjectBranch + Cli.updateProjectBranchRoot pb Branch.empty description Cli.respond DeletedEverything else Cli.respond DeleteEverythingConfirmation DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do @@ -824,8 +810,8 @@ loop e = do Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms DebugTabCompletionI inputs -> do Cli.Env {authHTTPClient, codebase} <- ask - ppCtx <- Cli.getProjectPath - let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient ppCtx + pp <- Cli.getCurrentProjectPath + let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "") Cli.respond (DisplayDebugCompletions completions) DebugFuzzyOptionsI command args -> do @@ -835,8 +821,8 @@ loop e = do Just (IP.InputPattern {args = argTypes}) -> do zip argTypes args & Monoid.foldMapM \case ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do - ppCtx <- Cli.getProjectPath - results <- liftIO $ getOptions codebase ppCtx currentBranch + pp <- Cli.getCurrentProjectPath + results <- liftIO $ getOptions codebase pp currentBranch Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do Cli.respond DebugFuzzyOptionsNoResolver @@ -906,10 +892,10 @@ loop e = do prettyRef renderR r = P.indentN 2 $ P.text (renderR r) prettyDefn renderR (r, Foldable.toList -> names) = P.lines (P.text <$> if null names then [""] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r - projectRoot <- Cli.getProjectRoot + projectRoot <- Cli.getCurrentProjectRoot void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot] DebugDumpNamespaceSimpleI -> do - projectRootBranch0 <- Cli.getProjectRoot0 + projectRootBranch0 <- Cli.getCurrentProjectRoot0 for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) -> traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r) for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) -> @@ -1161,12 +1147,10 @@ inputDescription input = 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 - That branch -> pure (into @Text branch) - -- just trying to recover the syntax the user wrote - These path _branch -> pure (Path.toText' path) + unresolvedProjectBranchText :: UnresolvedProjectBranch -> Cli Text + unresolvedProjectBranchText (ProjectAndBranch mayProjName pbName) = case mayProjName of + Nothing -> pure $ into @Text pbName + Just projName -> into @Text $ ProjectAndBranch projName pbName handleFindI :: Bool -> @@ -1179,7 +1163,7 @@ handleFindI isVerbose fscope ws input = do (pped, names, searchRoot, branch0) <- case fscope of FindLocal p -> do searchRoot <- Cli.resolvePath' p - branch0 <- Cli.getBranch0At searchRoot + branch0 <- Cli.getBranch0FromProjectPath searchRoot let names = Branch.toNames (Branch.withoutLib branch0) -- Don't exclude anything from the pretty printer, since the type signatures we print for -- results may contain things in lib. @@ -1187,7 +1171,7 @@ handleFindI isVerbose fscope ws input = do pure (pped, names, Just p, branch0) FindLocalAndDeps p -> do searchRoot <- Cli.resolvePath' p - branch0 <- Cli.getBranch0At searchRoot + branch0 <- Cli.getBranch0FromProjectPath searchRoot let names = Branch.toNames (Branch.withoutTransitiveLibs branch0) -- Don't exclude anything from the pretty printer, since the type signatures we print for -- results may contain things in lib. @@ -1195,7 +1179,7 @@ handleFindI isVerbose fscope ws input = do pure (pped, names, Just p, branch0) FindGlobal -> do -- TODO: Rewrite to be properly global again - projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getProjectRoot0 + projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0 pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames currentBranch0 <- Cli.getCurrentBranch0 pure (pped, projectRootNames, Nothing, currentBranch0) @@ -1336,14 +1320,14 @@ handleShowDefinition outputLoc showDefinitionScope query = do (names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of -- TODO: We should instead print each definition using the names from its project-branch root. (True, _) -> do - root <- Cli.getProjectRoot + root <- Cli.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names pure (names, pped) (_, ShowDefinitionGlobal) -> do -- TODO: Maybe rewrite to be properly global - root <- Cli.getProjectRoot + root <- Cli.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names @@ -1627,7 +1611,7 @@ checkDeletes typesTermsTuples doutput inputs = do toRel setRef name = R.fromList (fmap (name,) (toList setRef)) let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames -- make sure endangered is compeletely contained in paths - projectNames <- Branch.toNames <$> Cli.getProjectRoot0 + projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0 -- get only once for the entire deletion set let allTermsToDelete :: Set LabeledDependency allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete) @@ -1721,7 +1705,7 @@ displayI outputLoc hq = do (names, pped) <- if useRoot then do - root <- Cli.getProjectRoot + root <- Cli.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names @@ -1853,15 +1837,3 @@ addWatch watchName (Just uf) = do (UF.watchComponents uf <> [(WK.RegularWatch, [(v2, ann, Term.var a v, ty)])]) ) _ -> addWatch watchName Nothing - -looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path' -looseCodeOrProjectToPath = \case - Left pth -> pth - Right (ProjectAndBranch prj br) -> - Path.absoluteToPath' - ( ProjectUtils.projectBranchPath - ( ProjectAndBranch - (prj ^. #projectId) - (br ^. #branchId) - ) - ) From b76e559dddf564d49a41d30bb6be22adadac3062 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 11:55:30 -0700 Subject: [PATCH 60/76] Fix projectbranch resolve rename --- unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index ab26f12f34..8dc9252dc0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -64,7 +64,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB Input.BranchSourceI'Empty -> pure Nothing Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do pp <- Cli.getCurrentProjectPath - Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) + Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) case maySrcProjectAndBranch of Just srcProjectAndBranch -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index 2c91256bb7..4501d0d453 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -28,7 +28,7 @@ import Witch (unsafeFrom) handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleDeleteBranch projectAndBranchNamesToDelete = do ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath - projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranch currentProject (projectAndBranchNamesToDelete & #branch %~ Just) + projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just) doDeleteProjectBranch projectAndBranchToDelete -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order: From 591d72cffa088693524461fe059c139724039a0a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 11:57:38 -0700 Subject: [PATCH 61/76] Resolve imports in HandleInput --- .../src/Unison/Codebase/Editor/HandleInput.hs | 77 +++---------------- .../src/Unison/Codebase/Editor/Input.hs | 7 +- 2 files changed, 11 insertions(+), 73 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 074494cfef..318dc3394c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -257,75 +257,17 @@ loop e = do ResetI newRoot mtarget -> do newRoot <- case newRoot of - This newRoot -> case newRoot of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> Cli.expectBranchAtPath' path' - That (ProjectAndBranch mProjectName branchName) -> do - newProjectAndBranch <- ProjectUtils.resolveProjectBranch mProjectName (Just branchName) - Cli.getProjectBranchRoot newProjectAndBranch.branch - These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do - absPath <- case branchId of - Left hash -> jump =<< Cli.resolveShortCausalHash hash - Right path' -> Cli.resolvePath' path' - mrelativePath <- - Cli.getMaybeBranchAt absPath <&> \case - Nothing -> Nothing - Just _ -> preview ProjectUtils.projectBranchPathPrism absPath - projectAndBranch <- do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectUtils.getProjectAndBranchByTheseNames arg - thePath <- case (mrelativePath, projectAndBranch) of - (Nothing, Nothing) -> - ProjectUtils.getCurrentProject >>= \case - Nothing -> pure absPath - Just project -> - Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) - (Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do - projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0) - Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name))) - Cli.returnEarlyWithoutOutput - (Just _relativePath, Nothing) -> pure absPath - (Nothing, Just (ProjectAndBranch project branch)) -> - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - Cli.expectBranchAtPath' (Path.absoluteToPath' thePath) - + BranchAtPath p -> do + pp <- Cli.resolvePath' p + Cli.getBranchFromProjectPath pp + BranchAtSCH sch -> Cli.resolveShortCausalHash hash + BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp target <- case mtarget of Nothing -> Cli.getCurrentPath - Just looseCodeOrProject -> case looseCodeOrProject of - This path' -> Cli.resolvePath' path' - That (ProjectAndBranch mProjectName branchName) -> do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - These path' (ProjectAndBranch mProjectName branchName) -> do - absPath <- Cli.resolvePath' path' - mrelativePath <- - Cli.getMaybeBranchAt absPath <&> \case - Nothing -> Nothing - Just _ -> preview ProjectUtils.projectBranchPathPrism absPath - projectAndBranch <- do - let arg = case mProjectName of - Nothing -> That branchName - Just projectName -> These projectName branchName - ProjectUtils.getProjectAndBranchByTheseNames arg - case (mrelativePath, projectAndBranch) of - (Nothing, Nothing) -> - ProjectUtils.getCurrentProject >>= \case - Nothing -> pure absPath - Just project -> - Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) - (Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do - projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0) - Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name))) - Cli.returnEarlyWithoutOutput - (Just _relativePath, Nothing) -> pure absPath - (Nothing, Just (ProjectAndBranch project branch)) -> - pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) + Just unresolvedProjectAndBranch -> do + targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch) + pure $ PP.projectBranchRoot targetProjectAndBranch description <- inputDescription input _ <- Cli.updateAt description target (const newRoot) Cli.respond Success @@ -1415,8 +1357,9 @@ doDisplay outputLoc names tm = do -- | Show todo output if there are any conflicts or edits. doShowTodoOutput :: Patch -> Path.Absolute -> Cli () doShowTodoOutput patch scopePath = do + pp <- Cli.resolvePath' (Path.AbsolutePath' scopePath) Cli.Env {codebase} <- ask - names0 <- Branch.toNames <$> Cli.getBranch0At scopePath + names0 <- Branch.toNames <$> Cli.getBranch0FromProjectPath pp todo <- Cli.runTransaction (checkTodo codebase patch names0) if TO.noConflicts todo && TO.noEdits todo then Cli.respond NoConflictsOrEdits diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c55bd8b5d6..4f0237f732 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -117,12 +117,7 @@ data Input | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | ResetRootI BranchId - | ResetI - ( These - BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - (Maybe UnresolvedProjectBranch) + | ResetI BranchId (Maybe UnresolvedProjectBranch) | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? -- Does it make sense to fork from not-the-root of a Github repo? -- used in Welcome module to give directions to user From 18cde10b98a0e9ba26010628879c54754b9440a4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 14:45:57 -0700 Subject: [PATCH 62/76] WIP --- .../src/Unison/Codebase/ProjectPath.hs | 7 +- unison-cli/src/Unison/Cli/MonadUtils.hs | 5 + .../src/Unison/Codebase/Editor/HandleInput.hs | 117 ++++++++++-------- .../src/Unison/Codebase/Editor/Input.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 15 +-- 5 files changed, 80 insertions(+), 68 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 2694d26b51..cdd9a4ef29 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -7,6 +7,7 @@ module Unison.Codebase.ProjectPath projectBranchRoot, absPath_, path_, + path, projectAndBranch_, toText, toIds, @@ -83,11 +84,13 @@ toText (ProjectPath proj branch path) = into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path absPath_ :: Lens' (ProjectPathG p b) Path.Absolute -absPath_ = lens go set +absPath_ = lens absPath set where - go (ProjectPath _ _ p) = p set (ProjectPath n b _) p = ProjectPath n b p +path :: (ProjectPathG p b) -> Path.Path +path (ProjectPath _ _ p) = Path.unabsolute p + path_ :: Lens' (ProjectPathG p b) Path.Path path_ = absPath_ . Path.absPath_ diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 868b7bb3ab..d49f4b964e 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -11,6 +11,7 @@ module Unison.Cli.MonadUtils getCurrentProjectPath, resolvePath, resolvePath', + resolvePath'ToAbsolute, resolveSplit', -- * Project and branch resolution @@ -187,6 +188,10 @@ resolvePath' path' = do pp <- getCurrentProjectPath pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path' +resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute +resolvePath'ToAbsolute path' = do + view PP.absPath_ <$> resolvePath' path' + -- | Resolve a path split, per the current path. resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a) resolveSplit' = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 318dc3394c..d605d67f82 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,8 +29,6 @@ import U.Codebase.Branch.Diff qualified as V2Branch.Diff import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reflog qualified as Reflog -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.ABT qualified as ABT import Unison.Builtin qualified as Builtin @@ -93,7 +91,6 @@ import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate) import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2) import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade) import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN @@ -112,7 +109,7 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.CommandLine.BranchRelativePath (BranchRelativePath) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..)) import Unison.CommandLine.Completion qualified as Completion import Unison.CommandLine.DisplayValues qualified as DisplayValues import Unison.CommandLine.InputPattern qualified as IP @@ -138,12 +135,10 @@ import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE -import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) import Unison.PrettyPrintEnvDecl qualified as PPED -import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..)) -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 @@ -260,11 +255,11 @@ loop e = do BranchAtPath p -> do pp <- Cli.resolvePath' p Cli.getBranchFromProjectPath pp - BranchAtSCH sch -> Cli.resolveShortCausalHash hash + BranchAtSCH sch -> Cli.resolveShortCausalHash sch BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp target <- case mtarget of - Nothing -> Cli.getCurrentPath + Nothing -> Cli.getCurrentProjectPath Just unresolvedProjectAndBranch -> do targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch) pure $ PP.projectBranchRoot targetProjectAndBranch @@ -275,11 +270,12 @@ loop e = do Cli.time "reset-root" do newRoot <- case src0 of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> Cli.expectBranchAtPath' path' + BranchAtSCH hash -> Cli.resolveShortCausalHash hash + BranchAtPath path' -> Cli.expectBranchAtPath' path' + BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp description <- inputDescription input pb <- getCurrentProjectBranch - Cli.updateAtM "reset-root" (PP.projectBranchRoot pb) newRoot description + void $ Cli.updateProjectBranchRoot_ pb description (const newRoot) Cli.respond Success ForkLocalBranchI src0 dest0 -> do (srcb, branchEmpty) <- @@ -287,8 +283,8 @@ loop e = do Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash Right path' -> do srcPP <- ProjectUtils.resolveBranchRelativePath path' - srcb <- Cli.getBranchFromProjectPath srcPP `whenNothingM` pure Branch.empty - pure (srcb, WhichBranchEmptyPath srcp) + srcb <- Cli.getBranchFromProjectPath srcPP + pure (srcb, WhichBranchEmptyPath srcPP) description <- inputDescription input dest <- ProjectUtils.resolveBranchRelativePath dest0 ok <- Cli.updateAtM description dest (const $ pure srcb) @@ -297,49 +293,57 @@ loop e = do then Success else BranchEmpty branchEmpty MergeI branch -> handleMerge branch - MergeLocalBranchI unresolvedSrc unresolvedDest mergeMode -> do + MergeLocalBranchI unresolvedSrc mayUnresolvedDest mergeMode -> do description <- inputDescription input - srcPaB <- ProjectUtils.resolveProjectBranch (second Just src0) - destPaB <- ProjectUtils.resolveProjectBranch (second Just dest0) - srcBranch <- Cli.getProjectBranchRoot srcPaB.branch - 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 + srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc + (destPP, destBRP) <- case mayUnresolvedDest of + Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath pp.project.name pp.branch.name (pp ^. PP.absPath_)) + Just unresolvedDest -> do + ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest) + srcBranch <- Cli.getProjectBranchRoot srcPP.branch + let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP + mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP + PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do Cli.Env {codebase} <- ask - srcPaB <- ProjectUtils.resolveProjectBranch (second Just src0) - destPaB <- ProjectUtils.resolveProjectBranch (second Just dest0) - srcBranch <- Cli.getProjectBranchRoot srcPaB.branch - merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) - if merged == destb - then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0) + srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc + destPP <- case mayUnresolvedDest of + Nothing -> Cli.getCurrentProjectPath + Just unresolvedDest -> do + ProjectUtils.resolveBranchRelativePath unresolvedDest + srcBranch <- Cli.getProjectBranchRoot srcPP.branch + destBranch <- Cli.getProjectBranchRoot destPP.branch + merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch) + if merged == destBranch + then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP) else do - (ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged) - Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff) + (ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged) + Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff) DiffNamespaceI before after -> do - absBefore <- traverseOf _Right Cli.resolvePath' before - absAfter <- traverseOf _Right Cli.resolvePath' after - beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore - afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter + beforeLoc <- case before of + BranchAtSCH sch -> pure $ Left sch + BranchAtPath path' -> Right <$> Cli.resolvePath' path' + BranchAtProjectPath pp -> pure $ Right pp + afterLoc <- case after of + BranchAtSCH sch -> pure $ Left sch + BranchAtPath path' -> Right <$> Cli.resolvePath' path' + BranchAtProjectPath pp -> pure $ Right pp + beforeBranch0 <- Branch.head <$> Cli.resolveBranchId before + afterBranch0 <- Branch.head <$> Cli.resolveBranchId after case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of - (True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter]) - (True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| []) - (False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| []) + (True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc]) + (True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| []) + (False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| []) (False, False) -> pure () (ppe, diff) <- diffHelper beforeBranch0 afterBranch0 - Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff) + Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff) MoveBranchI src' dest' -> do - hasConfirmed <- confirmedCommand input description <- inputDescription input - doMoveBranch description hasConfirmed src' dest' + doMoveBranch description src' dest' SwitchBranchI path' -> do path <- Cli.resolvePath' path' branchExists <- Cli.branchExistsAtPath' path' - when (not branchExists) (Cli.respond $ CreatedNewBranch path) - Cli.cd path + when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_)) + Cli.cd (path ^. PP.absPath_) UpI -> do path0 <- Cli.getCurrentPath whenJust (unsnoc path0) \(path, _) -> @@ -350,10 +354,11 @@ loop e = do HistoryI resultsCap diffCap from -> do branch <- case from of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> do + BranchAtSCH hash -> Cli.resolveShortCausalHash hash + BranchAtPath path' -> do pp <- Cli.resolvePath' path' Cli.getBranchFromProjectPath pp + BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp schLength <- Cli.runTransaction Codebase.branchHashLength history <- liftIO (doHistory schLength 0 branch []) Cli.respondNumbered history @@ -380,7 +385,7 @@ loop e = do else CantUndoPastMerge description <- inputDescription input pb <- getCurrentProjectBranch - Cli.updateProjectBranchRoot pb prev description + Cli.updateProjectBranchRoot_ pb description (const prev) (ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch) Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff) UiI path' -> openUI path' @@ -425,7 +430,8 @@ loop e = do when (not (Set.null destTerms)) do Cli.returnEarly (TermAlreadyExists dest' destTerms) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTermName (Path.convert dest) srcTerm) + pb <- Cli.getCurrentProjectBranch + Cli.stepAt pb description (BranchUtil.makeAddTermName (Path.convert dest) srcTerm) Cli.respond Success AliasTypeI src' dest' -> do src <- traverseOf _Right Cli.resolveSplit' src' @@ -448,7 +454,8 @@ loop e = do when (not (Set.null destTypes)) do Cli.returnEarly (TypeAlreadyExists dest' destTypes) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTypeName (Path.convert dest) srcType) + pb <- Cli.getCurrentProjectBranch + Cli.stepAt pb description (BranchUtil.makeAddTypeName (Path.convert dest) srcType) Cli.respond Success -- this implementation will happily produce name conflicts, @@ -459,11 +466,11 @@ loop e = do destPP <- Cli.resolvePath' dest' old <- Cli.getBranch0FromProjectPath destPP description <- inputDescription input - let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs - Cli.stepManyAt description actions + let (unknown, actions) = foldl' (go root0 currentBranch0 (destPP ^. PP.absPath_)) mempty srcs + Cli.stepManyAt destPP.branch description actions new <- Cli.getBranch0FromProjectPath destPP (ppe, diff) <- diffHelper old new - Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff) + Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destPP.absPath ppe diff) when (not (null unknown)) do Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown where @@ -472,9 +479,9 @@ loop e = do Branch0 IO -> Branch0 IO -> Path.Absolute -> - ([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) -> + ([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) -> Path.HQSplit -> - ([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) + ([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) go root0 currentBranch0 dest (missingSrcs, actions) hqsrc = let proposedDest :: Path.Split proposedDest = second HQ'.toName hqProposedDest diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 4f0237f732..b22e8ac024 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -111,8 +111,8 @@ data Input -- clone w/o merge, error if would clobber ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath | -- merge first causal into destination - MergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) Branch.MergeMode - | PreviewMergeLocalBranchI UnresolvedProjectBranch (Maybe UnresolvedProjectBranch) + MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode + | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) | DiffNamespaceI BranchId BranchId -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 807805e301..19b282b4c4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -45,6 +45,7 @@ import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) @@ -93,7 +94,7 @@ type NumberedArgs = [StructuredArgument] type HashLength = Int data NumberedOutput - = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) + = ShowDiffNamespace (Either ShortCausalHash ProjectPath) (Either ShortCausalHash ProjectPath) PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) @@ -285,14 +286,10 @@ data Output | AboutToMerge | -- | Indicates a trivial merge where the destination was empty and was just replaced. MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) - | MergeAlreadyUpToDate - (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) - (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + | MergeAlreadyUpToDate BranchRelativePath BranchRelativePath | -- This will replace the above once `merge.old` is deleted MergeAlreadyUpToDate2 !MergeSourceAndTarget - | PreviewMergeAlreadyUpToDate - (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + | PreviewMergeAlreadyUpToDate ProjectPath ProjectPath | -- | No conflicts or edits remain for the current patch. NoConflictsOrEdits | NotImplemented @@ -306,7 +303,7 @@ data Output | BadName Text | CouldntLoadBranch CausalHash | HelpMessage Input.InputPattern - | NamespaceEmpty (NonEmpty AbsBranchId) + | NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath)) | NoOp | -- | @GistCreated repo@ means a causal was just published to @repo@. GistCreated (ReadRemoteNamespace Void) @@ -423,7 +420,7 @@ data CreatedProjectBranchFrom -- | A branch was empty. But how do we refer to that branch? data WhichBranchEmpty = WhichBranchEmptyHash ShortCausalHash - | WhichBranchEmptyPath (Either ProjectPath Path') + | WhichBranchEmptyPath ProjectPath data ShareError = ShareErrorDownloadEntities Share.DownloadEntitiesError From 8138e61a2a0c1b35086fb7436fdd61026deb8bd0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 15:39:30 -0700 Subject: [PATCH 63/76] toText and output munging --- .../src/Unison/Codebase/Path.hs | 13 ++ .../src/Unison/Codebase/ProjectPath.hs | 9 +- unison-cli/src/Unison/Cli/Pretty.hs | 10 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 188 +++++++++--------- .../HandleInput/NamespaceDependencies.hs | 2 +- .../src/Unison/Codebase/Editor/Input.hs | 6 + .../Unison/CommandLine/BranchRelativePath.hs | 8 + .../src/Unison/CommandLine/InputPatterns.hs | 25 +-- .../src/Unison/CommandLine/OutputMessages.hs | 14 +- 9 files changed, 151 insertions(+), 124 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 0a335ac240..ee13e1d124 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -32,6 +32,7 @@ module Unison.Codebase.Path prefixNameIfRel, unprefixName, HQSplit, + HQSplitAbsolute, AbsSplit, Split, Split', @@ -390,6 +391,18 @@ empty = Path mempty instance Show Path where show = Text.unpack . toText +instance From Path Text where + from = toText + +instance From Absolute Text where + from = absToText + +instance From Relative Text where + from = relToText + +instance From Path' Text where + from = toText' + -- | Note: This treats the path as relative. toText :: Path -> Text toText = diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index cdd9a4ef29..55d481794d 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -18,7 +18,7 @@ module Unison.Codebase.ProjectPath ) where -import Control.Lens +import Control.Lens hiding (from) import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.Text qualified as Text @@ -44,10 +44,17 @@ type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName +instance From ProjectPath Text where + from = from . toNames + instance From ProjectPathNames Text where from (ProjectPath proj branch path) = into @Text (ProjectAndBranch proj branch) <> ":" <> Path.absToText path +instance From (ProjectPathG () ProjectBranchName) Text where + from (ProjectPath () branch path) = + "/" <> into @Text branch <> ":" <> Path.absToText path + type ProjectPath = ProjectPathG Project ProjectBranch projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 7052e7b87d..ac56a7d644 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -6,6 +6,7 @@ module Unison.Cli.Pretty ( displayBranchHash, prettyAbsolute, prettyProjectPath, + prettyBranchRelativePath, prettyBase32Hex#, prettyBase32Hex, prettyBranchId, @@ -80,6 +81,7 @@ import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.Core.Project (ProjectBranchName) import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug @@ -260,6 +262,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName -> prettyProjectAndBranchName (ProjectAndBranch project branch) = P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch) +prettyBranchRelativePath :: BranchRelativePath -> Pretty +prettyBranchRelativePath = P.blue . P.text . into @Text + -- produces: -- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0 -- Optional.None, Maybe.Nothing : Maybe a @@ -332,10 +337,7 @@ prettyTypeName ppe r = prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case WhichBranchEmptyHash hash -> P.shown hash - WhichBranchEmptyPath p -> - case p of - Left pp -> prettyProjectPath pp - Right path' -> prettyPath' path' + WhichBranchEmptyPath pp -> prettyProjectPath pp -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef displayBranchHash :: CausalHash -> Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index d605d67f82..220665ab67 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -21,7 +21,6 @@ import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet import Data.Text qualified as Text -import Data.These (These (..)) import Data.Time (UTCTime) import Data.Tuple.Extra (uncurry3) import Text.Megaparsec qualified as Megaparsec @@ -137,7 +136,6 @@ import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) import Unison.PrettyPrintEnvDecl qualified as PPED -import Unison.Project (ProjectAndBranch (..)) import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -297,7 +295,7 @@ loop e = do description <- inputDescription input srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc (destPP, destBRP) <- case mayUnresolvedDest of - Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath pp.project.name pp.branch.name (pp ^. PP.absPath_)) + Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_)) Just unresolvedDest -> do ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest) srcBranch <- Cli.getProjectBranchRoot srcPP.branch @@ -431,7 +429,7 @@ loop e = do Cli.returnEarly (TermAlreadyExists dest' destTerms) description <- inputDescription input pb <- Cli.getCurrentProjectBranch - Cli.stepAt pb description (BranchUtil.makeAddTermName (Path.convert dest) srcTerm) + Cli.stepAt pb description (BranchUtil.makeAddTermName (first PP.absPath dest) srcTerm) Cli.respond Success AliasTypeI src' dest' -> do src <- traverseOf _Right Cli.resolveSplit' src' @@ -455,7 +453,7 @@ loop e = do Cli.returnEarly (TypeAlreadyExists dest' destTypes) description <- inputDescription input pb <- Cli.getCurrentProjectBranch - Cli.stepAt pb description (BranchUtil.makeAddTypeName (Path.convert dest) srcType) + Cli.stepAt pb description (BranchUtil.makeAddTypeName (first PP.absPath dest) srcType) Cli.respond Success -- this implementation will happily produce name conflicts, @@ -466,11 +464,11 @@ loop e = do destPP <- Cli.resolvePath' dest' old <- Cli.getBranch0FromProjectPath destPP description <- inputDescription input - let (unknown, actions) = foldl' (go root0 currentBranch0 (destPP ^. PP.absPath_)) mempty srcs + let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs Cli.stepManyAt destPP.branch description actions new <- Cli.getBranch0FromProjectPath destPP (ppe, diff) <- diffHelper old new - Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destPP.absPath ppe diff) + Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff) when (not (null unknown)) do Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown where @@ -483,24 +481,25 @@ loop e = do Path.HQSplit -> ([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) go root0 currentBranch0 dest (missingSrcs, actions) hqsrc = - let proposedDest :: Path.Split + let proposedDest :: Path.AbsSplit proposedDest = second HQ'.toName hqProposedDest - hqProposedDest :: Path.HQSplit - hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc + hqProposedDest :: Path.HQSplitAbsolute + hqProposedDest = Path.resolve dest hqsrc -- `Nothing` if src doesn't exist - doType :: Maybe [(Path, Branch0 m -> Branch0 m)] + doType :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)] doType = case ( BranchUtil.getType hqsrc currentBranch0, - BranchUtil.getType hqProposedDest root0 + BranchUtil.getType (first Path.unabsolute hqProposedDest) root0 ) of (null -> True, _) -> Nothing -- missing src (rsrcs, existing) -> -- happy path Just . map addAlias . toList $ Set.difference rsrcs existing where + addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m) addAlias r = BranchUtil.makeAddTypeName proposedDest r - doTerm :: Maybe [(Path, Branch0 m -> Branch0 m)] + doTerm :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)] doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0, - BranchUtil.getTerm hqProposedDest root0 + BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0 ) of (null -> True, _) -> Nothing -- missing src (rsrcs, existing) -> @@ -550,11 +549,13 @@ loop e = do authorPath <- Cli.resolveSplit' authorPath' copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment) guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment) + pb <- Cli.getCurrentProjectBranch Cli.stepManyAt + pb description - [ BranchUtil.makeAddTermName (Path.convert authorPath) (d authorRef), - BranchUtil.makeAddTermName (Path.convert copyrightHolderPath) (d copyrightHolderRef), - BranchUtil.makeAddTermName (Path.convert guidPath) (d guidRef) + [ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef), + BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef), + BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef) ] currentPath <- Cli.getCurrentPath finalBranch <- Cli.getCurrentBranch0 @@ -574,61 +575,56 @@ loop e = do MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input MoveAllI src' dest' -> do - hasConfirmed <- confirmedCommand input desc <- inputDescription input - handleMoveAll hasConfirmed src' dest' desc - DeleteI dtarget -> case dtarget of - 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'Namespace insistence Nothing -> do - hasConfirmed <- confirmedCommand input - if hasConfirmed || insistence == Force - then do - description <- inputDescription input - pb <- Cli.getCurrentProjectBranch - Cli.updateProjectBranchRoot pb Branch.empty description - Cli.respond DeletedEverything - else Cli.respond DeleteEverythingConfirmation - DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do - branch <- Cli.expectBranchAtPath (Path.unsplit p) - description <- inputDescription input - let toDelete = - Names.prefix0 - (Path.unsafeToName (Path.unsplit (p))) - (Branch.toNames (Branch.head branch)) - afterDelete <- do - names <- Cli.currentNames - endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) - case (null endangerments, insistence) of - (True, _) -> pure (Cli.respond Success) - (False, Force) -> do - ppeDecl <- Cli.currentPrettyPrintEnvDecl - pure do - Cli.respond Success - Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments - (False, Try) -> do - ppeDecl <- Cli.currentPrettyPrintEnvDecl - Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments - Cli.returnEarlyWithoutOutput - 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 -> - parentBranch - & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty - afterDelete - DeleteTarget'ProjectBranch name -> handleDeleteBranch name - DeleteTarget'Project name -> handleDeleteProject name + handleMoveAll src' dest' desc + DeleteI dtarget -> do + pp <- Cli.getCurrentProjectPath + let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg) + let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg) + case dtarget of + DeleteTarget'TermOrType doutput hqs -> do + delete input doutput getTerms getTypes hqs + DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs + DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs + DeleteTarget'Namespace insistence p@(parentPath, childName) -> do + branch <- Cli.expectBranchAtPath (Path.unsplit p) + description <- inputDescription input + let toDelete = + Names.prefix0 + (Path.unsafeToName (Path.unsplit (p))) + (Branch.toNames (Branch.head branch)) + afterDelete <- do + names <- Cli.currentNames + endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) + case (null endangerments, insistence) of + (True, _) -> pure (Cli.respond Success) + (False, Force) -> do + ppeDecl <- Cli.currentPrettyPrintEnvDecl + pure do + Cli.respond Success + Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments + (False, Try) -> do + ppeDecl <- Cli.currentPrettyPrintEnvDecl + Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments + Cli.returnEarlyWithoutOutput + 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 -> + parentBranch + & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty + afterDelete + DeleteTarget'ProjectBranch name -> handleDeleteBranch name + DeleteTarget'Project name -> handleDeleteProject name DisplayI outputLoc namesToDisplay -> do traverse_ (displayI outputLoc) namesToDisplay ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths FindShallowI pathArg -> do Cli.Env {codebase} <- ask - - pathArgAbs <- Cli.resolvePath' pathArg - entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) + pp <- Cli.resolvePath' pathArg + projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch + entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath)) Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped @@ -654,7 +650,8 @@ loop e = do let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames let adds = SlurpResult.adds sr Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf - Cli.stepAt description (Path.unabsolute currentPath, doSlurpAdds adds uf) + pb <- getCurrentProjectBranch + Cli.stepAt pb description (currentPath, doSlurpAdds adds uf) pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.respond $ SlurpOutput input suffixifiedPPE sr @@ -677,8 +674,8 @@ loop e = do previewResponse sourceName sr uf TodoI patchPath branchPath' -> do patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath patchPath) - branchPath <- Cli.resolvePath' branchPath' - doShowTodoOutput patch branchPath + pp <- Cli.resolvePath' branchPath' + doShowTodoOutput patch pp.absPath TestI testInput -> Tests.handleTest testInput ExecuteI main args -> handleRun False main args MakeStandaloneI output main -> doCompile False output main @@ -710,7 +707,8 @@ loop e = do let destPath = case opath of Just path -> Path.resolve currentPath (Path.Relative path) Nothing -> currentPath `snoc` NameSegment.builtinSegment - _ <- Cli.updateAtM description destPath \destb -> + pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath + _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success MergeIOBuiltinsI opath -> do @@ -737,7 +735,8 @@ loop e = do let destPath = case opath of Just path -> Path.resolve currentPath (Path.Relative path) Nothing -> currentPath `snoc` NameSegment.builtinSegment - _ <- Cli.updateAtM description destPath \destb -> + pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath + _ <- Cli.updateAtM description pp \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success PullI sourceTarget pullMode -> handlePull sourceTarget pullMode @@ -887,7 +886,7 @@ loop e = do Cli.respond $ PrintVersion ucmVersion ProjectRenameI name -> handleProjectRename name ProjectSwitchI name -> projectSwitch name - ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name + ProjectCreateI tryDownloadingBase name -> void $ projectCreate tryDownloadingBase name ProjectsI -> handleProjects BranchI source name -> handleBranch source name BranchRenameI name -> handleBranchRename name @@ -907,8 +906,8 @@ inputDescription input = dest <- brp dest0 pure ("fork " <> src <> " " <> dest) MergeLocalBranchI src0 dest0 mode -> do - src <- looseCodeOrProjectToText src0 - dest <- looseCodeOrProjectToText dest0 + let src = into @Text src0 + let dest = maybe "" (into @Text) dest0 let command = case mode of Branch.RegularMerge -> "merge" @@ -916,17 +915,17 @@ inputDescription input = pure (command <> " " <> src <> " " <> dest) ResetI hash tgt -> do hashTxt <- case hash of - This hash -> hp' hash - That pr -> pure (into @Text pr) - These hash _pr -> hp' hash + BranchAtSCH hash -> hp' $ Left hash + BranchAtPath pr -> pure $ into @Text pr + BranchAtProjectPath pp -> pure $ into @Text pp tgt <- case tgt of Nothing -> pure "" Just tgt -> do - tgt <- looseCodeOrProjectToText tgt - pure (" " <> tgt) + let tgtText = into @Text tgt + pure (" " <> tgtText) pure ("reset " <> hashTxt <> tgt) ResetRootI src0 -> do - src <- hp' src0 + let src = into @Text src0 pure ("reset-root " <> src) AliasTermI src0 dest0 -> do src <- hhqs' src0 @@ -977,10 +976,10 @@ inputDescription input = thing <- traverse hqs' thing0 pure ("delete.type.verbose " <> Text.intercalate " " thing) DeleteTarget'Namespace Try opath0 -> do - opath <- ops opath0 + opath <- ps opath0 pure ("delete.namespace " <> opath) DeleteTarget'Namespace Force opath0 -> do - opath <- ops opath0 + opath <- ps opath0 pure ("delete.namespace.force " <> opath) DeleteTarget'ProjectBranch _ -> wat DeleteTarget'Project _ -> wat @@ -1081,9 +1080,7 @@ inputDescription input = p' :: Path' -> Cli Text p' = fmap tShow . Cli.resolvePath' brp :: BranchRelativePath -> Cli Text - brp = fmap from . ProjectUtils.resolveBranchRelativePath - ops :: Maybe Path.Split -> Cli Text - ops = maybe (pure ".") ps + brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath wat = error $ show input ++ " is not expected to alter the branch" hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text hhqs' = \case @@ -1096,10 +1093,6 @@ inputDescription input = hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) ps' = p' . Path.unsplit' ps = p . Path.unsplit - unresolvedProjectBranchText :: UnresolvedProjectBranch -> Cli Text - unresolvedProjectBranchText (ProjectAndBranch mayProjName pbName) = case mayProjName of - Nothing -> pure $ into @Text pbName - Just projName -> into @Text $ ProjectAndBranch projName pbName handleFindI :: Bool -> @@ -1414,11 +1407,6 @@ checkTodo codebase patch names0 = do edited :: Set Reference edited = R.dom (Patch._termEdits patch) <> R.dom (Patch._typeEdits patch) -confirmedCommand :: Input -> Cli Bool -confirmedCommand i = do - loopState <- State.get - pure $ Just i == (loopState ^. #lastInput) - -- return `name` and `name....` _searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of @@ -1531,8 +1519,8 @@ delete input doutput getTerms getTypes hqs' = do traverse ( \hq -> do absolute <- Cli.resolveSplit' hq - types <- getTypes absolute - terms <- getTerms absolute + types <- getTypes ( first PP.absPath absolute) + terms <- getTerms( first PP.absPath absolute) return (hq, types, terms) ) hqs' @@ -1551,10 +1539,11 @@ checkDeletes :: [(Path.HQSplit', Set Reference, Set Referent)] -> DeleteOutput - checkDeletes typesTermsTuples doutput inputs = do let toSplitName :: (Path.HQSplit', Set Reference, Set Referent) -> - Cli (Path.Split, Name, Set Reference, Set Referent) + Cli (Path.AbsSplit, Name, Set Reference, Set Referent) toSplitName hq = do - resolvedPath <- Path.convert <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) - return (resolvedPath, Path.unsafeToName (Path.unsplit resolvedPath), hq ^. _2, hq ^. _3) + (pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) + let resolvedSplit = (pp.absPath, ns) + return (resolvedSplit, Path.unsafeToName (Path.unsplit (first Path.unabsolute resolvedSplit)), hq ^. _2, hq ^. _3) -- get the splits and names with terms and types splitsNames <- traverse toSplitName typesTermsTuples let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref @@ -1585,7 +1574,8 @@ checkDeletes typesTermsTuples doutput inputs = do ) before <- Cli.getCurrentBranch0 description <- inputDescription inputs - Cli.stepManyAt description deleteTypesTerms + pb <- Cli.getCurrentProjectBranch + Cli.stepManyAt pb description deleteTypesTerms case doutput of DeleteOutput'Diff -> do after <- Cli.getCurrentBranch0 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 66f3f0c3af..aa35d39dde 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -37,7 +37,7 @@ handleNamespaceDependencies namespacePath' = do let pb = pp ^. #branch branch <- Cli.getMaybeBranch0FromProjectPath pp & onNothingM do - Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Left pp))) + Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp)) externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) pped <- Cli.projectBranchPPED pb diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b22e8ac024..0c69480733 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -68,6 +68,12 @@ data BranchIdG p | BranchAtProjectPath ProjectPath deriving stock (Eq, Show, Functor, Foldable, Traversable) +instance From p Text => From (BranchIdG p) Text where + from = \case + BranchAtSCH h -> "#" <> SCH.toText h + BranchAtPath p -> from p + BranchAtProjectPath pp -> from pp + type BranchId = BranchIdG Path' type AbsBranchId = BranchIdG Path.Absolute diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index 65942f5db9..06a71a19ae 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -4,6 +4,7 @@ module Unison.CommandLine.BranchRelativePath branchRelativePathParser, parseIncrementalBranchRelativePath, IncrementalBranchRelativePath (..), + toText, ) where @@ -15,6 +16,7 @@ import Text.Megaparsec qualified as Megaparsec import Text.Megaparsec.Char qualified as Megaparsec import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project qualified as Project @@ -233,3 +235,9 @@ branchRelativePathParser = pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath) Right branch -> pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath) + +toText :: BranchRelativePath -> Text +toText = \case + BranchPathInCurrentProject pbName absPath -> ProjectPath () pbName absPath & into @Text + QualifiedBranchPath projName pbName absPath -> ProjectPath projName pbName absPath & into @Text + UnqualifiedPath path' -> Path.toText' path' diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index f86714404e..cfe8604134 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -493,10 +493,11 @@ handleBranchIdArg = SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg -handleBranchIdOrProjectArg :: +-- | TODO: Maybe remove? +_handleBranchIdOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) -handleBranchIdOrProjectArg = +_handleBranchIdOrProjectArg = either (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) \case @@ -1631,8 +1632,8 @@ reset = ] ) \case - [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing - [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleMaybeProjectBranchArg arg1) + [arg0] -> Input.ResetI <$> handleBranchIdArg arg0 <*> pure Nothing + [arg0, arg1] -> Input.ResetI <$> handleBranchIdArg arg0 <*> fmap pure (handleMaybeProjectBranchArg arg1) _ -> Left $ I.help reset where config = @@ -2036,13 +2037,13 @@ mergeOldSquashInputPattern = parse = \case [src] -> Input.MergeLocalBranchI - <$> handleMaybeProjectBranchArg src + <$> handleBranchRelativePathArg src <*> pure Nothing <*> pure Branch.SquashMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleMaybeProjectBranchArg src - <*> (Just <$> handleMaybeProjectBranchArg dest) + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.SquashMerge _ -> Left $ I.help mergeOldSquashInputPattern } @@ -2081,13 +2082,13 @@ mergeOldInputPattern = ( \case [src] -> Input.MergeLocalBranchI - <$> handleMaybeProjectBranchArg src + <$> handleBranchRelativePathArg src <*> pure Nothing <*> pure Branch.RegularMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleMaybeProjectBranchArg src - <*> (Just <$> handleMaybeProjectBranchArg dest) + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.RegularMerge _ -> Left $ I.help mergeOldInputPattern ) @@ -2170,9 +2171,9 @@ mergeOldPreviewInputPattern = ] ) ( \case - [src] -> Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> pure Nothing + [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing [src, dest] -> - Input.PreviewMergeLocalBranchI <$> handleMaybeProjectBranchArg src <*> (Just <$> handleMaybeProjectBranchArg dest) + Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest) _ -> Left $ I.help mergeOldPreviewInputPattern ) where diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f58aa7458d..07439565a6 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -170,7 +170,7 @@ renderFileName dir = P.group . P.blue . fromString <$> shortenDirectory dir notifyNumbered :: NumberedOutput -> (Pretty, NumberedArgs) notifyNumbered = \case ShowDiffNamespace oldPrefix newPrefix ppe diffOutput -> - showDiffNamespace ShowNumbers ppe oldPrefix newPrefix diffOutput + showDiffNamespace ShowNumbers ppe (either BranchAtSCH BranchAtProjectPath oldPrefix) (either BranchAtSCH BranchAtProjectPath newPrefix) diffOutput ShowDiffAfterDeleteDefinitions ppe diff -> first ( \p -> @@ -577,13 +577,13 @@ notifyUser dir = \case pure . P.warnCallout $ "The namespace " - <> prettyBranchId p0 + <> either prettySCH prettyProjectPath p0 <> " is empty. Was there a typo?" ps -> pure . P.warnCallout $ "The namespaces " - <> P.commas (prettyBranchId <$> ps) + <> P.commas (either prettySCH prettyProjectPath <$> ps) <> " are empty. Was there a typo?" LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ @@ -1327,9 +1327,9 @@ notifyUser dir = \case MergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ - either prettyPath' prettyProjectAndBranchName dest + prettyBranchRelativePath dest <> "was already up-to-date with" - <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".") + <> P.group (prettyBranchRelativePath src <> ".") MergeAlreadyUpToDate2 aliceAndBob -> pure . P.callout "😶" $ P.wrap $ @@ -1471,9 +1471,9 @@ notifyUser dir = \case PreviewMergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + prettyProjectPath dest <> "is already up-to-date with" - <> P.group (prettyNamespaceKey src <> ".") + <> P.group (prettyProjectPath src) DumpNumberedArgs schLength args -> pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args NoConflictsOrEdits -> From 48371c021f51239c93c2f98875819f5f6efaf138 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 10 Jun 2024 16:33:16 -0700 Subject: [PATCH 64/76] Propagate ProjectPath into CLI Main --- parser-typechecker/src/Unison/Codebase.hs | 6 +-- .../src/Unison/Codebase/ProjectPath.hs | 11 ++-- unison-cli/src/Unison/Cli/MonadUtils.hs | 4 +- .../Codebase/Editor/HandleInput/Pull.hs | 6 +-- unison-cli/src/Unison/CommandLine/Main.hs | 52 +++++++++---------- unison-cli/src/Unison/LSP/UCMWorker.hs | 2 +- 6 files changed, 38 insertions(+), 43 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 91d6275d76..fff9c74571 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -229,8 +229,8 @@ getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMayb causalHash <- lift $ Q.expectCausalHash causalHashId lift $ Operations.expectCausalBranchByCausalHash causalHash -expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> ProjectBranch -> m (Branch m) -expectProjectBranchRoot codebase ProjectBranch {projectId, branchId} = do +expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m) +expectProjectBranchRoot codebase projectId branchId = do causalHash <- runTransaction codebase $ do causalHashId <- Q.expectProjectBranchHead projectId branchId Q.expectCausalHash causalHashId @@ -254,7 +254,7 @@ getBranchAtProjectPath :: PP.ProjectPath -> m (Maybe (Branch m)) getBranchAtProjectPath codebase pp = runMaybeT do - rootBranch <- lift $ expectProjectBranchRoot codebase (pp ^. #branch) + rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch -- | Like 'getBranchForHash', but for when the hash is known to be in the codebase. diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 55d481794d..fed28739b2 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -8,11 +8,11 @@ module Unison.Codebase.ProjectPath absPath_, path_, path, + toProjectAndBranch, projectAndBranch_, toText, toIds, toNames, - asProjectAndBranch_, projectPathParser, parseProjectPath, ) @@ -71,11 +71,8 @@ toIds (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch toNames :: ProjectPath -> ProjectPathNames toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path -asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch) -asProjectAndBranch_ = lens get set - where - get (ProjectPath proj branch _) = ProjectAndBranch proj branch - set p (ProjectAndBranch proj branch) = p & #project .~ proj & #branch .~ branch +toProjectAndBranch :: ProjectPathG p b -> ProjectAndBranch p b +toProjectAndBranch (ProjectPath proj branch _) = ProjectAndBranch proj branch instance Bifunctor ProjectPathG where bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path @@ -101,7 +98,7 @@ path (ProjectPath _ _ p) = Path.unabsolute p path_ :: Lens' (ProjectPathG p b) Path.Path path_ = absPath_ . Path.absPath_ -projectAndBranch_ :: Lens' (ProjectPathG p b) (ProjectAndBranch p b) +projectAndBranch_ :: Lens (ProjectPathG p b) (ProjectPathG p' b') (ProjectAndBranch p b) (ProjectAndBranch p' b') projectAndBranch_ = lens go set where go (ProjectPath proj branch _) = ProjectAndBranch proj branch diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index d49f4b964e..2e6abfdc30 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -157,7 +157,7 @@ getCurrentProjectPath = do getCurrentProjectAndBranch :: Cli (ProjectAndBranch Project ProjectBranch) getCurrentProjectAndBranch = do - view PP.asProjectAndBranch_ <$> getCurrentProjectPath + PP.toProjectAndBranch <$> getCurrentProjectPath getCurrentProjectBranch :: Cli ProjectBranch getCurrentProjectBranch = do @@ -298,7 +298,7 @@ getBranch0FromProjectPath pp = getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO) getProjectBranchRoot projectBranch = do Cli.Env {codebase} <- ask - liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch + liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId -- | Get the maybe-branch at an absolute path. getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 9eebe820c9..7a844bec50 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -162,7 +162,7 @@ resolveSourceAndTarget includeSquashed = \case resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) resolveImplicitSource includeSquashed = do pp <- Cli.getCurrentProjectPath - let localProjectAndBranch = pp ^. PP.asProjectAndBranch_ + let localProjectAndBranch = PP.toProjectAndBranch pp (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- Cli.runTransactionWithRollback \rollback -> do let localProjectId = localProjectAndBranch.project.projectId @@ -200,7 +200,7 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - localProjectAndBranch <- view PP.asProjectAndBranch_ <$> Cli.getCurrentProjectPath + localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath let localProjectId = localProjectAndBranch.project.projectId let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case @@ -235,7 +235,7 @@ resolveExplicitSource includeSquashed = \case resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) resolveImplicitTarget = do - view PP.asProjectAndBranch_ <$> Cli.getCurrentProjectPath + PP.toProjectAndBranch <$> Cli.getCurrentProjectPath -- | 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/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 151c7c3948..a4309e8733 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -6,7 +6,8 @@ where import Compat (withInterruptHandler) import Control.Concurrent.Async qualified as Async import Control.Exception (catch, displayException, finally, mask) -import Control.Lens (preview, (?~)) +import Control.Lens ((?~)) +import Control.Lens.Lens import Crypto.Random qualified as Random import Data.Configurator.Types (Config) import Data.IORef @@ -20,16 +21,13 @@ import System.Console.Haskeline.History qualified as Line import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin) import System.IO.Error (isDoesNotExistError) import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.Operations qualified as Operations -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.CredentialManager (newCredentialManager) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Auth.HTTPClient qualified as AuthN import Unison.Auth.Tokens qualified as AuthN import Unison.Cli.Monad qualified as Cli -import Unison.Cli.Pretty (prettyProjectAndBranchName) -import Unison.Cli.ProjectUtils (projectBranchPathPrism) +import Unison.Cli.Pretty qualified as P +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch) @@ -38,7 +36,6 @@ import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event, Input (..)) import Unison.Codebase.Editor.Output (NumberedArgs, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) -import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime import Unison.CommandLine @@ -50,7 +47,6 @@ import Unison.CommandLine.Welcome qualified as Welcome import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal -import Unison.Project (ProjectAndBranch (..)) import Unison.Runtime.IOSource qualified as IOSource import Unison.Server.CodebaseServer qualified as Server import Unison.Symbol (Symbol) @@ -68,7 +64,7 @@ getUserInput :: IO (Branch IO) -> NumberedArgs -> IO Input -getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = +getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = Line.runInputT settings (haskelineCtrlCHandling go) @@ -83,15 +79,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Just a -> pure a go :: Line.InputT IO Input go = do - let (PP.ProjectPath projectName projectBranchName path) = PP.toNames ppCtx - let promptString = - P.sep - ":" - ( catMaybes - [ Just (prettyProjectAndBranchName (ProjectAndBranch projectName projectBranchName)), - (Just . P.green . P.shown) path - ] - ) + let promptString = P.prettyProjectPath pp let fullPrompt = P.toANSI 80 (promptString <> fromString prompt) line <- Line.getInputLine fullPrompt case line of @@ -99,7 +87,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Just l -> case words l of [] -> go ws -> do - liftIO (parseInput codebase ppCtx currentProjectRoot numberedArgs IP.patternMap ws) >>= \case + liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case Left msg -> do -- We still add history that failed to parse so the user can easily reload -- the input and fix it. @@ -123,7 +111,15 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = historyFile = Just ".unisonHistory", autoAddHistory = False } - tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient ppCtx + tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient pp + +loopStateProjectPath :: + Codebase IO Symbol Ann -> + Cli.LoopState -> + IO PP.ProjectPath +loopStateProjectPath codebase loopState = do + let ppIds = NEL.head $ Cli.projectPathStack loopState + ppIds & PP.projectAndBranch_ %%~ \pabIds -> liftIO . Codebase.runTransaction codebase $ ProjectUtils.expectProjectAndBranchByIds pabIds main :: FilePath -> @@ -138,22 +134,22 @@ main :: Maybe Server.BaseUrl -> UCMVersion -> (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPath -> STM ()) -> ShouldWatchFiles -> IO () main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do rootVar <- newEmptyTMVarIO _ <- Ki.fork scope do - root <- Codebase.getRootBranch codebase + projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch atomically do -- Try putting the root, but if someone else as already written over the root, don't -- overwrite it. - void $ tryPutTMVar rootVar root + void $ tryPutTMVar rootVar projectRoot -- Start forcing thunks in a background thread. -- This might be overly aggressive, maybe we should just evaluate the top level but avoid -- recursive "deep*" things. UnliftIO.concurrently_ - (UnliftIO.evaluate root) + (UnliftIO.evaluate projectRoot) (UnliftIO.evaluate IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup let initialState = Cli.loopState0 rootVar ppIds Ki.fork_ scope do @@ -184,11 +180,11 @@ main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase currentEcho <- hGetEcho stdin liftIO $ restoreEcho currentEcho let getProjectRoot = atomically $ readTMVar rootVar - Codebase.runTransaction codebase Ops.expectProjectAndBranchNames + pp <- loopStateProjectPath codebase loopState getUserInput codebase authHTTPClient - (NEL.head $ Cli.projectPathStack loopState) + pp getProjectRoot (loopState ^. #numberedArgs) let loadSourceFile :: Text -> IO Cli.LoadSourceResult @@ -283,7 +279,9 @@ main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase Text.hPutStrLn stderr ("Encountered exception:\n" <> Text.pack (displayException e)) loop0 s0 Right (Right (result, s1)) -> do - when ((s0 ^. #currentPath) /= (s1 ^. #currentPath :: Path.Absolute)) (atomically . notifyPathChange $ s1 ^. #currentPath) + oldPP <- loopStateProjectPath codebase s0 + newPP <- loopStateProjectPath codebase s1 + when (oldPP /= newPP) (atomically . notifyPathChange $ newPP) case result of Cli.Success () -> loop0 s1 Cli.Continue -> loop0 s1 diff --git a/unison-cli/src/Unison/LSP/UCMWorker.hs b/unison-cli/src/Unison/LSP/UCMWorker.hs index 70212d29ad..14913f7fa4 100644 --- a/unison-cli/src/Unison/LSP/UCMWorker.hs +++ b/unison-cli/src/Unison/LSP/UCMWorker.hs @@ -31,7 +31,7 @@ ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestPro Env {codebase, completionsVar} <- ask let loop :: ProjectPath -> Lsp a loop currentProjectPath = do - currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch) + currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch . #projectId) (currentProjectPath ^. #branch . #branchId) Debug.debugM Debug.LSP "LSP path: " currentProjectPath let currentBranch0 = Branch.head currentBranch let currentNames = Branch.toNames currentBranch0 From 23fd0a005bcd0126480096b6bf36153ab0386d95 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 10:08:49 -0700 Subject: [PATCH 65/76] Allow passing project and branch as starting path --- .../U/Codebase/Sqlite/Queries.hs | 8 ++--- parser-typechecker/src/Unison/Codebase.hs | 19 +++++------- unison-cli/src/ArgParse.hs | 30 ++++++++++++------- unison-cli/src/Unison/Main.hs | 15 ++++------ unison-core/src/Unison/Project.hs | 15 ++++++++++ .../Unison/Server/Local/Endpoints/Current.hs | 10 ++----- 6 files changed, 55 insertions(+), 42 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 08cd1fe977..c1ec796c9c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -238,7 +238,7 @@ module U.Codebase.Sqlite.Queries elaborateHashes, -- * current project path - loadCurrentProjectPath, + expectCurrentProjectPath, setCurrentProjectPath, -- * migrations @@ -4283,9 +4283,9 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -loadCurrentProjectPath :: Transaction (Maybe (ProjectId, ProjectBranchId, [NameSegment])) -loadCurrentProjectPath = - queryMaybeRowCheck +expectCurrentProjectPath :: Transaction (ProjectId, ProjectBranchId, [NameSegment]) +expectCurrentProjectPath = + queryOneRowCheck [sql| SELECT project_id, branch_id, path FROM current_project_path diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index fff9c74571..3c1a5bde87 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -2,7 +2,7 @@ module Unison.Codebase ( Codebase, -- * UCM session state - loadCurrentProjectPath, + expectCurrentProjectPath, setCurrentProjectPath, -- * Terms @@ -536,16 +536,13 @@ unsafeGetTermComponent codebase hash = Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms -loadCurrentProjectPath :: Sqlite.Transaction (Maybe PP.ProjectPath) -loadCurrentProjectPath = do - mProjectInfo <- Q.loadCurrentProjectPath - case mProjectInfo of - Nothing -> pure Nothing - Just (projectId, projectBranchId, path) -> do - proj <- Q.expectProject projectId - projBranch <- Q.expectProjectBranch projectId projectBranchId - let absPath = Path.Absolute (Path.fromList path) - pure $ Just (PP.ProjectPath proj projBranch absPath) +expectCurrentProjectPath :: Sqlite.Transaction PP.ProjectPath +expectCurrentProjectPath = do + (projectId, projectBranchId, path) <- Q.expectCurrentProjectPath + proj <- Q.expectProject projectId + projBranch <- Q.expectProjectBranch projectId projectBranchId + let absPath = Path.Absolute (Path.fromList path) + pure $ PP.ProjectPath proj projBranch absPath setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index ab24fd16c5..0b354f9f57 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -52,16 +52,19 @@ import Options.Applicative.Help (bold, (<+>)) import Options.Applicative.Help.Pretty qualified as P import Stats import System.Environment (lookupEnv) +import Text.Megaparsec qualified as Megaparsec import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.ProjectPath (ProjectPathNames) import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.Types (ShouldWatchFiles (..)) +import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.HashQualified (HashQualified) import Unison.LSP (LspFormattingConfig (..)) import Unison.Name (Name) import Unison.Prelude import Unison.PrettyTerminal qualified as PT +import Unison.Project qualified as Project import Unison.Server.CodebaseServer (CodebaseServerOpts (..)) import Unison.Server.CodebaseServer qualified as Server import Unison.Syntax.HashQualified qualified as HQ @@ -104,8 +107,8 @@ data Command = Launch IsHeadless CodebaseServerOpts - -- Starting path - (Maybe Path.Absolute) + -- Starting project + (Maybe (ProjectAndBranch ProjectName ProjectBranchName)) ShouldWatchFiles | PrintVersion | -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released @@ -359,9 +362,9 @@ launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command launchParser envOpts isHeadless = do -- ApplicativeDo codebaseServerOpts <- codebaseServerOptsParser envOpts - startingPath <- startingPathOption + startingProject <- startingProjectOption shouldWatchFiles <- noFileWatchFlag - pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles) + pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles) initParser :: Parser Command initParser = pure Init @@ -428,15 +431,15 @@ saveCodebaseToFlag = do _ -> DontSaveCodebase ) -startingPathOption :: Parser (Maybe Path.Absolute) -startingPathOption = +startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName)) +startingProjectOption = let meta = - metavar ".path.in.codebase" - <> long "path" + metavar "project/branch" + <> long "project" <> short 'p' - <> help "Launch the UCM session at the provided path location." + <> help "Launch the UCM session at the provided project and branch." <> noGlobal - in optional $ option readAbsolutePath meta + in optional (option readProjectAndBranchNames meta) noFileWatchFlag :: Parser ShouldWatchFiles noFileWatchFlag = @@ -475,6 +478,13 @@ readPath' = do Left err -> OptParse.readerError (Text.unpack err) Right path' -> pure path' +readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName) +readProjectAndBranchNames = do + str <- OptParse.str + case Megaparsec.parse Project.fullyQualifiedProjectAndBranchNamesParser "arg" str of + Left errBundle -> OptParse.readerError $ Megaparsec.errorBundlePretty errBundle + Right projectAndBranch -> pure projectAndBranch + fileArgument :: String -> Parser FilePath fileArgument varName = strArgument diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 1d58ddb03f..97d9700fd7 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -70,6 +70,7 @@ import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResul import Unison.Codebase.Init qualified as CodebaseInit import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.SqliteCodebase qualified as SC import Unison.Codebase.TranscriptParser qualified as TR @@ -158,7 +159,7 @@ main version = do Run (RunFromSymbol mainName) args -> do getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do - withArgs args (execute theCodebase runtime mainName) >>= \case + withArgs args (execute theCodebase runtime _ mainName) >>= \case Left err -> exitError err Right () -> pure () Run (RunFromFile file mainName) args @@ -296,8 +297,7 @@ main version = do case mayStartingPath of Just startingPath -> pure startingPath Nothing -> do - segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace - pure (Path.Absolute (Path.fromList segments)) + Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash) rootCausalHashVar <- newTVarIO rootCausalHash @@ -512,9 +512,6 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba ) when (not completed) $ Exit.exitWith (Exit.ExitFailure 1) -defaultInitialPath :: Path.Absolute -defaultInitialPath = Path.absoluteEmpty - launch :: Version -> FilePath -> @@ -525,13 +522,13 @@ launch :: Codebase.Codebase IO Symbol Ann -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl -> - Maybe Path.Absolute -> + PP.ProjectPathIds -> InitResult -> (CausalHash -> STM ()) -> (Path.Absolute -> STM ()) -> CommandLine.ShouldWatchFiles -> IO () -launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do +launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist let isNewCodebase = case initResult of CreatedCodebase -> NewlyCreatedCodebase @@ -541,7 +538,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU in CommandLine.main dir welcome - (fromMaybe defaultInitialPath mayStartingPath) + startingPath config inputs runtime diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 77a96a448a..73070e7a1d 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -17,6 +17,7 @@ module Unison.Project ProjectBranchSpecifier (..), ProjectAndBranch (..), projectAndBranchNamesParser, + fullyQualifiedProjectAndBranchNamesParser, projectAndOptionalBranchParser, branchWithOptionalProjectParser, ProjectAndBranchNames (..), @@ -414,6 +415,20 @@ projectAndBranchNamesParser specifier = do Just branch -> These project branch else pure (This project) +-- | Parse a fully specified myproject/mybranch name. +-- +-- >>> import Text.Megaparsec (parseMaybe) +-- >>> parseMaybe fullyQualifiedProjectAndBranchNamesParser ("myproject/mybranch" :: Text) +-- Just (ProjectAndBranch {project = UnsafeProjectName "myproject", branch = UnsafeProjectBranchName "mybranch"}) +fullyQualifiedProjectAndBranchNamesParser :: Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName ProjectBranchName) +fullyQualifiedProjectAndBranchNamesParser = do + (project, hadSlash) <- projectNameParser + if hadSlash + then pure () + else void $ Megaparsec.char '/' + branch <- projectBranchNameParser False + pure (ProjectAndBranch project branch) + -- | @project/branch@ syntax, where the branch is optional. instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where from = \case diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 9065c5de45..68c10ce4b2 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -3,7 +3,6 @@ module Unison.Server.Local.Endpoints.Current where -import Control.Lens hiding ((.=)) import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema (..)) @@ -53,11 +52,6 @@ serveCurrent = lift . getCurrentProjectBranch getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current getCurrentProjectBranch codebase = do - pp <- - Codebase.runTransaction codebase Codebase.loadCurrentProjectPath <&> \case - Nothing -> - -- TODO: Come up with a better solution for this - error "No current project path context" - Just pp -> pp - let (PP.ProjectPath projName branchName path) = PP.toNames pp + pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath + let (PP.ProjectPath projName branchName path) = PP.toNames pp pure $ Current (Just projName) (Just branchName) path From 7298bbeffe4c3f3cc2668c7d3b67a304e706a8d4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 10:43:53 -0700 Subject: [PATCH 66/76] Revive causal hash signal in LSP --- unison-cli/src/Unison/LSP.hs | 23 ++++++++++++++++------- unison-cli/src/Unison/LSP/UCMWorker.hs | 24 ++++++++++++++---------- 2 files changed, 30 insertions(+), 17 deletions(-) diff --git a/unison-cli/src/Unison/LSP.hs b/unison-cli/src/Unison/LSP.hs index 4ef4b92750..5ec56f6967 100644 --- a/unison-cli/src/Unison/LSP.hs +++ b/unison-cli/src/Unison/LSP.hs @@ -27,6 +27,7 @@ import Language.LSP.VFS import Network.Simple.TCP qualified as TCP import System.Environment (lookupEnv) import System.IO (hPutStrLn) +import U.Codebase.HashTags import Unison.Codebase import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) @@ -60,8 +61,14 @@ getLspPort :: IO String getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT" -- | Spawn an LSP server on the configured port. -spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM PP.ProjectPath -> IO () -spawnLsp lspFormattingConfig codebase runtime latestPath = +spawnLsp :: + LspFormattingConfig -> + Codebase IO Symbol Ann -> + Runtime Symbol -> + STM CausalHash -> + STM PP.ProjectPath -> + IO () +spawnLsp lspFormattingConfig codebase runtime latestProjectRootHash latestPath = ifEnabled . TCP.withSocketsDo $ do lspPort <- getLspPort UnliftIO.handleIO (handleFailure lspPort) $ do @@ -81,7 +88,7 @@ spawnLsp lspFormattingConfig codebase runtime latestPath = -- different un-saved state for the same file. initVFS $ \vfs -> do vfsVar <- newMVar vfs - void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestPath) + void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestProjectRootHash latestPath) where handleFailure :: String -> IOException -> IO () handleFailure lspPort ioerr = @@ -112,15 +119,16 @@ serverDefinition :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> + STM CausalHash -> STM PP.ProjectPath -> ServerDefinition Config -serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestPath = +serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestProjectRootHash latestPath = ServerDefinition { defaultConfig = defaultLSPConfig, configSection = "unison", parseConfig = Config.parseConfig, onConfigChange = Config.updateConfig, - doInitialize = lspDoInitialize vfsVar codebase runtime scope latestPath, + doInitialize = lspDoInitialize vfsVar codebase runtime scope latestProjectRootHash latestPath, staticHandlers = lspStaticHandlers lspFormattingConfig, interpretHandler = lspInterpretHandler, options = lspOptions @@ -132,11 +140,12 @@ lspDoInitialize :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> + STM CausalHash -> STM PP.ProjectPath -> LanguageContextEnv Config -> Msg.TMessage 'Msg.Method_Initialize -> IO (Either Msg.ResponseError Env) -lspDoInitialize vfsVar codebase runtime scope latestPath lspContext _initMsg = do +lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspContext _initMsg = do checkedFilesVar <- newTVarIO mempty dirtyFilesVar <- newTVarIO mempty ppedCacheVar <- newEmptyTMVarIO @@ -155,7 +164,7 @@ lspDoInitialize vfsVar codebase runtime scope latestPath lspContext _initMsg = d } let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM Ki.fork scope (lspToIO Analysis.fileAnalysisWorker) - Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestPath) + Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestRootHash latestPath) pure $ Right $ env -- | LSP request handlers that don't register/unregister dynamically diff --git a/unison-cli/src/Unison/LSP/UCMWorker.hs b/unison-cli/src/Unison/LSP/UCMWorker.hs index 14913f7fa4..b0614c23e8 100644 --- a/unison-cli/src/Unison/LSP/UCMWorker.hs +++ b/unison-cli/src/Unison/LSP/UCMWorker.hs @@ -1,6 +1,7 @@ module Unison.LSP.UCMWorker where import Control.Monad.Reader +import U.Codebase.HashTags (CausalHash) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch @@ -25,12 +26,13 @@ ucmWorker :: TMVar Names -> TMVar (NameSearch Sqlite.Transaction) -> TMVar ProjectPath -> + STM CausalHash -> STM ProjectPath -> Lsp () -ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestProjectPath = do +ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestProjectRootHash getLatestProjectPath = do Env {codebase, completionsVar} <- ask - let loop :: ProjectPath -> Lsp a - loop currentProjectPath = do + let loop :: CausalHash -> ProjectPath -> Lsp a + loop currentProjectRootHash currentProjectPath = do currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch . #projectId) (currentProjectPath ^. #branch . #branchId) Debug.debugM Debug.LSP "LSP path: " currentProjectPath let currentBranch0 = Branch.head currentBranch @@ -47,16 +49,18 @@ ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestPro atomically do writeTMVar completionsVar (namesToCompletionTree currentNames) Debug.debugLogM Debug.LSP "LSP Initialized" - latest <- atomically $ do + (latestRootHash, latestProjectPath) <- atomically $ do + latestRootHash <- getLatestProjectRootHash latestPath <- getLatestProjectPath - guard $ (currentProjectPath /= latestPath) - pure latestPath + guard $ (currentProjectRootHash /= latestRootHash || currentProjectPath /= latestPath) + pure (latestRootHash, latestPath) Debug.debugLogM Debug.LSP "LSP Change detected" - loop latest - currentProjectPath <- atomically $ do + loop latestRootHash latestProjectPath + (currentProjectRootHash, currentProjectPath) <- atomically $ do + latestProjectRootHash <- getLatestProjectRootHash currentProjectPath <- getLatestProjectPath - pure currentProjectPath - loop currentProjectPath + pure (latestProjectRootHash, currentProjectPath) + loop currentProjectRootHash currentProjectPath where -- This is added in stm-2.5.1, remove this if we upgrade. writeTMVar :: TMVar a -> a -> STM () From 7aabcf5d8927408b181a95e15f9c110ef2316c9e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 10:43:53 -0700 Subject: [PATCH 67/76] Fix up Execute --- .../src/Unison/Codebase/Execute.hs | 27 ++++++-- unison-cli/src/Unison/Main.hs | 62 +++++++++++-------- 2 files changed, 58 insertions(+), 31 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 1149c5ee79..788bc5abe1 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -7,15 +7,22 @@ module Unison.Codebase.Execute where import Control.Exception (finally) import Control.Monad.Except +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.MainTerm (getMainTerm) import Unison.Codebase.MainTerm qualified as MainTerm +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.ProjectPath qualified as PP 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 (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) @@ -24,14 +31,22 @@ import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - Names -> - HQ.HashQualified Name -> + PP.ProjectPathNames -> IO (Either Runtime.Error ()) -execute codebase runtime names mainName = +execute codebase runtime mainPath = (`finally` Runtime.terminate runtime) . runExceptT $ do + (project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do + project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project)) + branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch)) + pure . Right $ (project, branch) + projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId let loadTypeOfTerm = Codebase.getTypeOfTerm codebase let mainType = Runtime.mainType runtime - mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm names mainName mainType + mainName <- case Path.toName (mainPath ^. PP.path_) of + Just n -> pure (HQ.NameOnly n) + Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath))) + + mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType case mt of 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} ()") diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 97d9700fd7..1149589063 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -48,6 +48,7 @@ import System.Directory ) import System.Environment (getExecutablePath, getProgName, withArgs) import System.Exit qualified as Exit +import System.Exit qualified as System import System.FilePath ( replaceExtension, takeDirectory, @@ -62,6 +63,7 @@ import System.IO.Temp qualified as Temp import System.Path qualified as Path import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Input qualified as Input @@ -159,7 +161,7 @@ main version = do Run (RunFromSymbol mainName) args -> do getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, _, theCodebase) -> do RTI.withRuntime False RTI.OneOff (Version.gitDescribeWithDate version) \runtime -> do - withArgs args (execute theCodebase runtime _ mainName) >>= \case + withArgs args (execute theCodebase runtime mainName) >>= \case Left err -> exitError err Right () -> pure () Run (RunFromFile file mainName) args @@ -175,7 +177,7 @@ main version = do let noOpRootNotifier _ = pure () let noOpPathNotifier _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -186,7 +188,7 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes noOpRootNotifier noOpPathNotifier @@ -202,7 +204,7 @@ main version = do let noOpRootNotifier _ = pure () let noOpPathNotifier _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -213,7 +215,7 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes noOpRootNotifier noOpPathNotifier @@ -287,32 +289,42 @@ main version = do case mrtsStatsFp of Nothing -> action Just fp -> recordRtsStats fp action - Launch isHeadless codebaseServerOpts mayStartingPath shouldWatchFiles -> do + Launch isHeadless codebaseServerOpts mayStartingProject shouldWatchFiles -> do getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do - startingPath <- case isHeadless of - WithCLI -> do - -- If the user didn't provide a starting path on the command line, put them in the most recent - -- path they cd'd to - case mayStartingPath of - Just startingPath -> pure startingPath - Nothing -> do - Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath - Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath + startingProjectPath <- do + -- If the user didn't provide a starting path on the command line, put them in the most recent + -- path they cd'd to + case mayStartingProject of + Just startingProject -> do + Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case + Nothing -> do + PT.putPrettyLn $ + P.callout + "❓" + ( P.lines + [ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject) + ] + ) + System.exitFailure + Just pab -> do + pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty + Nothing -> do + Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash) - rootCausalHashVar <- newTVarIO rootCausalHash - pathVar <- newTVarIO startingPath + projectRootHashVar <- newTVarIO rootCausalHash + projectPathVar <- newTVarIO startingProjectPath let notifyOnRootChanges :: CausalHash -> STM () notifyOnRootChanges b = do - writeTVar rootCausalHashVar b - let notifyOnPathChanges :: Path.Absolute -> STM () - notifyOnPathChanges = writeTVar pathVar + writeTVar projectRootHashVar b + let notifyOnPathChanges :: PP.ProjectPath -> STM () + notifyOnPathChanges = writeTVar projectPathVar -- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever -- when waiting for input on handles, so if we listen for LSP connections it will -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on -- Windows when we move to GHC 9.* -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224 - void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar) + void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar projectRootHashVar) (readTVar projectPathVar) Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do @@ -346,7 +358,7 @@ main version = do theCodebase [] (Just baseUrl) - (Just startingPath) + (PP.toIds startingProjectPath) initRes notifyOnRootChanges notifyOnPathChanges @@ -525,10 +537,10 @@ launch :: PP.ProjectPathIds -> InitResult -> (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPath -> STM ()) -> CommandLine.ShouldWatchFiles -> IO () -launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do +launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyProjPathChange shouldWatchFiles = do showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist let isNewCodebase = case initResult of CreatedCodebase -> NewlyCreatedCodebase @@ -548,7 +560,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU serverBaseUrl ucmVersion notifyRootChange - notifyPathChange + notifyProjPathChange shouldWatchFiles newtype MarkdownFile = MarkdownFile FilePath From 95fd37ad3fff82e987d80318382ccf3ba7b369c9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 12:39:33 -0700 Subject: [PATCH 68/76] Bootstrap scratch project in migration --- .../Migrations/MigrateSchema16To17.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs index 269f88de43..1a462706fc 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -3,12 +3,27 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Codebase qualified as Codebase +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName)) import Unison.Sqlite qualified as Sqlite --- | This migration adds the causal_object_id column to the project_branches table. +-- | This migration adds a new table to the schema, `currentProjectPath`, and sets it to contain the path to the scratch project. migrateSchema16To17 :: Sqlite.Transaction () migrateSchema16To17 = do Q.expectSchemaVersion 16 + scratchMain <- + Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case + Just pb -> pure pb + Nothing -> do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + (_proj, pb) <- Ops.insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + pure pb Q.addCurrentProjectPathTable + Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId [] Q.setSchemaVersion 17 + where + scratchProjectName = UnsafeProjectName "scratch" + scratchBranchName = UnsafeProjectBranchName "main" From 203f2ce0c20a8d9b81d3eb8551351eb9095ee3da Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 12:39:33 -0700 Subject: [PATCH 69/76] Add better callstacks to sqlite exceptions. --- .../src/Unison/Sqlite/Connection.hs | 34 ++++++------- .../src/Unison/Sqlite/Exception.hs | 10 ++-- .../src/Unison/Sqlite/Transaction.hs | 48 +++++++++---------- 3 files changed, 46 insertions(+), 46 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f46917ddc8..d749559298 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -151,7 +151,7 @@ logQuery (Sql sql params) result = -- Without results -execute :: Connection -> Sql -> IO () +execute :: HasCallStack => Connection -> Sql -> IO () execute conn@(Connection _ _ conn0) sql@(Sql s params) = do logQuery sql Nothing doExecute `catch` \(exception :: Sqlite.SQLError) -> @@ -171,7 +171,7 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do -- | Execute one or more semicolon-delimited statements. -- -- This function does not support parameters, and is mostly useful for executing DDL and migrations. -executeStatements :: Connection -> Text -> IO () +executeStatements :: HasCallStack => Connection -> Text -> IO () executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do logQuery (Sql sql []) Nothing Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) -> @@ -184,7 +184,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do -- With results, without checks -queryStreamRow :: Sqlite.FromRow a => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r +queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = run `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -201,7 +201,7 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = queryStreamCol :: forall a r. - (Sqlite.FromField a) => + (HasCallStack, Sqlite.FromField a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> @@ -212,7 +212,7 @@ queryStreamCol = @(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r) queryStreamRow -queryListRow :: forall a. (Sqlite.FromRow a) => Connection -> Sql -> IO [a] +queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a] queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do result <- doQuery @@ -237,35 +237,35 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do Just row -> loop (row : rows) loop [] -queryListCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a] +queryListCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO [a] queryListCol = coerce @(Connection -> Sql -> IO [Sqlite.Only a]) @(Connection -> Sql -> IO [a]) queryListRow -queryMaybeRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO (Maybe a) +queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO (Maybe a) queryMaybeRow conn s = queryListRowCheck conn s \case [] -> Right Nothing [x] -> Right (Just x) xs -> Left (ExpectedAtMostOneRowException (anythingToString xs)) -queryMaybeCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO (Maybe a) +queryMaybeCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO (Maybe a) queryMaybeCol conn s = coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow conn s) -queryOneRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO a +queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO a queryOneRow conn s = queryListRowCheck conn s \case [x] -> Right x xs -> Left (ExpectedExactlyOneRowException (anythingToString xs)) -queryOneCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO a +queryOneCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO a queryOneCol conn s = do coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s) -- With results, with checks queryListRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> ([a] -> Either e r) -> @@ -274,7 +274,7 @@ queryListRowCheck conn s check = gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check) gqueryListCheck :: - (Sqlite.FromRow a) => + (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> ([a] -> Either SomeSqliteExceptionReason r) -> @@ -293,7 +293,7 @@ gqueryListCheck conn sql check = do queryListColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> ([a] -> Either e r) -> @@ -302,7 +302,7 @@ queryListColCheck conn s check = queryListRowCheck conn s (coerce @([a] -> Either e r) @([Sqlite.Only a] -> Either e r) check) queryMaybeRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -315,7 +315,7 @@ queryMaybeRowCheck conn s check = queryMaybeColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -324,7 +324,7 @@ queryMaybeColCheck conn s check = queryMaybeRowCheck conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check) queryOneRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> @@ -336,7 +336,7 @@ queryOneRowCheck conn s check = queryOneColCheck :: forall a e r. - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Connection -> Sql -> (a -> Either e r) -> diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index cf760c4936..a573727461 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -24,7 +24,8 @@ where import Control.Concurrent (ThreadId, myThreadId) import Data.Typeable (cast) import Database.SQLite.Simple qualified as Sqlite -import GHC.Stack (currentCallStack) +import GHC.Stack (CallStack) +import GHC.Stack qualified as Stack import Unison.Prelude import Unison.Sqlite.Connection.Internal (Connection) import Unison.Sqlite.Sql (Sql (..)) @@ -112,7 +113,7 @@ data SqliteQueryException = SqliteQueryException -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant. exception :: SomeSqliteExceptionReason, - callStack :: [String], + callStack :: CallStack, connection :: Connection, threadId :: ThreadId } @@ -137,16 +138,15 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo exception :: SomeSqliteExceptionReason } -throwSqliteQueryException :: SqliteQueryExceptionInfo -> IO a +throwSqliteQueryException :: HasCallStack => SqliteQueryExceptionInfo -> IO a throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do threadId <- myThreadId - callStack <- currentCallStack throwIO SqliteQueryException { sql, params, exception, - callStack, + callStack = Stack.callStack, connection, threadId } diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 49a5e01aa8..e40f4a7639 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -88,7 +88,7 @@ instance MonadIO TransactionWithMonadIO where coerce @(IO a -> Transaction a) unsafeIO -- | Run a transaction on the given connection. -runTransaction :: (MonadIO m) => Connection -> Transaction a -> m a +runTransaction :: (MonadIO m, HasCallStack) => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do uninterruptibleMask \restore -> do Connection.begin conn @@ -117,7 +117,7 @@ instance Show RollingBack where -- | Run a transaction on the given connection, providing a function that can short-circuit (and roll back) the -- transaction. runTransactionWithRollback :: - (MonadIO m) => + (MonadIO m, HasCallStack) => Connection -> ((forall void. a -> Transaction void) -> Transaction a) -> m a @@ -137,13 +137,13 @@ runTransactionWithRollback conn transaction = liftIO do -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does -- attempt a write and gets SQLITE_BUSY, it's your fault! -runReadOnlyTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runReadOnlyTransaction :: (MonadUnliftIO m, HasCallStack) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runReadOnlyTransaction conn f = withRunInIO \runInIO -> runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) {-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} -runReadOnlyTransaction_ :: Connection -> IO a -> IO a +runReadOnlyTransaction_ :: HasCallStack => Connection -> IO a -> IO a runReadOnlyTransaction_ conn action = do bracketOnError_ (Connection.begin conn) @@ -160,7 +160,7 @@ runReadOnlyTransaction_ conn action = do -- BEGIN/COMMIT statements. -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. -runWriteTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runWriteTransaction :: (HasCallStack, MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runWriteTransaction conn f = withRunInIO \runInIO -> uninterruptibleMask \restore -> @@ -170,7 +170,7 @@ runWriteTransaction conn f = (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) {-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} -runWriteTransaction_ :: (forall x. IO x -> IO x) -> Connection -> IO a -> IO a +runWriteTransaction_ :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a runWriteTransaction_ restore conn transaction = do keepTryingToBeginImmediate restore conn result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn) @@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do pure result -- @BEGIN IMMEDIATE@ until success. -keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> IO () +keepTryingToBeginImmediate :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO () keepTryingToBeginImmediate restore conn = let loop = try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case @@ -217,7 +217,7 @@ savepoint (Transaction action) = do -- transaction needs to retry. -- -- /Warning/: attempting to run a transaction inside a transaction will cause an exception! -unsafeIO :: IO a -> Transaction a +unsafeIO :: HasCallStack => IO a -> Transaction a unsafeIO action = Transaction \_ -> action @@ -232,18 +232,18 @@ unsafeUnTransaction (Transaction action) = -- Without results -execute :: Sql -> Transaction () +execute :: HasCallStack => Sql -> Transaction () execute s = Transaction \conn -> Connection.execute conn s -executeStatements :: Text -> Transaction () +executeStatements :: HasCallStack => Text -> Transaction () executeStatements s = Transaction \conn -> Connection.executeStatements conn s -- With results, without checks queryStreamRow :: - (Sqlite.FromRow a) => + (Sqlite.FromRow a, HasCallStack) => Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r @@ -254,7 +254,7 @@ queryStreamRow sql callback = queryStreamCol :: forall a r. - (Sqlite.FromField a) => + (Sqlite.FromField a, HasCallStack) => Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r @@ -264,34 +264,34 @@ queryStreamCol = @(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r) queryStreamRow -queryListRow :: (Sqlite.FromRow a) => Sql -> Transaction [a] +queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a] queryListRow s = Transaction \conn -> Connection.queryListRow conn s -queryListCol :: (Sqlite.FromField a) => Sql -> Transaction [a] +queryListCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction [a] queryListCol s = Transaction \conn -> Connection.queryListCol conn s -queryMaybeRow :: (Sqlite.FromRow a) => Sql -> Transaction (Maybe a) +queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction (Maybe a) queryMaybeRow s = Transaction \conn -> Connection.queryMaybeRow conn s -queryMaybeCol :: (Sqlite.FromField a) => Sql -> Transaction (Maybe a) +queryMaybeCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction (Maybe a) queryMaybeCol s = Transaction \conn -> Connection.queryMaybeCol conn s -queryOneRow :: (Sqlite.FromRow a) => Sql -> Transaction a +queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction a queryOneRow s = Transaction \conn -> Connection.queryOneRow conn s -queryOneCol :: (Sqlite.FromField a) => Sql -> Transaction a +queryOneCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction a queryOneCol s = Transaction \conn -> Connection.queryOneCol conn s -- With results, with parameters, with checks queryListRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> ([a] -> Either e r) -> Transaction r @@ -299,7 +299,7 @@ queryListRowCheck sql check = Transaction \conn -> Connection.queryListRowCheck conn sql check queryListColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> ([a] -> Either e r) -> Transaction r @@ -307,7 +307,7 @@ queryListColCheck sql check = Transaction \conn -> Connection.queryListColCheck conn sql check queryMaybeRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction (Maybe r) @@ -315,7 +315,7 @@ queryMaybeRowCheck s check = Transaction \conn -> Connection.queryMaybeRowCheck conn s check queryMaybeColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction (Maybe r) @@ -323,7 +323,7 @@ queryMaybeColCheck s check = Transaction \conn -> Connection.queryMaybeColCheck conn s check queryOneRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e) => + (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction r @@ -331,7 +331,7 @@ queryOneRowCheck s check = Transaction \conn -> Connection.queryOneRowCheck conn s check queryOneColCheck :: - (Sqlite.FromField a, SqliteExceptionReason e) => + (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> (a -> Either e r) -> Transaction r From d53f26775c754a74889c5c7f4b28da4d7dc560e7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 12:39:33 -0700 Subject: [PATCH 70/76] Create scratch project during codebase creation --- .../U/Codebase/Sqlite/Operations.hs | 14 +++++ .../U/Codebase/Sqlite/ProjectReflog.hs | 37 +++++++++++ .../U/Codebase/Sqlite/Queries.hs | 62 +++++++++++-------- codebase2/codebase-sqlite/package.yaml | 1 + .../013-add-project-branch-reflog-table.sql | 26 ++++++++ .../unison-codebase-sqlite.cabal | 3 + parser-typechecker/src/Unison/Codebase.hs | 14 +---- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../Codebase/SqliteCodebase/Operations.hs | 41 +++++++++++- 9 files changed, 162 insertions(+), 40 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs create mode 100644 codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index c3965c1432..39dcd072ed 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -101,6 +101,8 @@ module U.Codebase.Sqlite.Operations -- * reflog getReflog, appendReflog, + getProjectReflog, + appendProjectReflog, -- * low-level stuff expectDbBranch, @@ -183,6 +185,7 @@ import U.Codebase.Sqlite.Patch.TypeEdit qualified as S import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference @@ -1455,6 +1458,17 @@ appendReflog entry = do dbEntry <- (bitraverse Q.saveCausalHash pure) entry Q.appendReflog dbEntry +-- | Gets the specified number of reflog entries in chronological order, most recent first. +getProjectReflog :: Int -> Transaction [ProjectReflog.Entry CausalHash] +getProjectReflog numEntries = do + entries <- Q.getProjectReflog numEntries + (traverse . traverse) Q.expectCausalHash entries + +appendProjectReflog :: ProjectReflog.Entry CausalHash -> Transaction () +appendProjectReflog entry = do + dbEntry <- traverse Q.saveCausalHash entry + Q.appendProjectReflog dbEntry + -- | Delete any name lookup that's not in the provided list. -- -- This can be used to garbage collect unreachable name lookups. diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs new file mode 100644 index 0000000000..a01bb7a2c6 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module U.Codebase.Sqlite.ProjectReflog where + +import Control.Lens +import Data.Text (Text) +import Data.Time (UTCTime) +import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId) +import Unison.Sqlite (FromRow (..), ToRow (..), field) + +data Entry causal = Entry + { project :: ProjectId, + branch :: ProjectBranchId, + time :: UTCTime, + fromRootCausalHash :: causal, + toRootCausalHash :: causal, + reason :: Text + } + deriving stock (Show, Functor, Foldable, Traversable) + +instance ToRow (Entry CausalHashId) where + toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) = + toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason) + +instance FromRow (Entry CausalHashId) where + fromRow = do + project <- field + branch <- field + time <- field + fromRootCausalHash <- field + toRootCausalHash <- field + reason <- field + pure $ Entry {..} + +causals_ :: Traversal (Entry causal) (Entry causal') causal causal' +causals_ f (Entry {..}) = Entry project branch time <$> f fromRootCausalHash <*> f toRootCausalHash <*> pure reason diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index c1ec796c9c..dc4e1de82c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -217,6 +217,8 @@ module U.Codebase.Sqlite.Queries -- * Reflog appendReflog, getReflog, + appendProjectReflog, + getProjectReflog, -- * garbage collection garbageCollectObjectsWithoutHashes, @@ -242,7 +244,7 @@ module U.Codebase.Sqlite.Queries setCurrentProjectPath, -- * migrations - createSchema, + runCreateSql, addTempEntityTables, addReflogTable, addNamespaceStatsTables, @@ -255,6 +257,7 @@ module U.Codebase.Sqlite.Queries addSquashResultTableIfNotExists, cdToProjectRoot, addCurrentProjectPathTable, + addProjectBranchReflogTable, -- ** schema version currentSchemaVersion, @@ -368,6 +371,7 @@ import U.Codebase.Sqlite.Orphans () import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import U.Codebase.Sqlite.Reference qualified as Reference import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference @@ -415,27 +419,11 @@ type TextPathSegments = [Text] -- * main squeeze currentSchemaVersion :: SchemaVersion -currentSchemaVersion = 16 +currentSchemaVersion = 17 -createSchema :: Transaction () -createSchema = do +runCreateSql :: Transaction () +runCreateSql = executeStatements $(embedProjectStringFile "sql/create.sql") - addTempEntityTables - addNamespaceStatsTables - addReflogTable - fixScopedNameLookupTables - addProjectTables - addMostRecentBranchTable - addNameLookupMountTables - addMostRecentNamespaceTable - execute insertSchemaVersionSql - addSquashResultTable - where - insertSchemaVersionSql = - [sql| - INSERT INTO schema_version (version) - VALUES (:currentSchemaVersion) - |] addTempEntityTables :: Transaction () addTempEntityTables = @@ -445,6 +433,7 @@ addNamespaceStatsTables :: Transaction () addNamespaceStatsTables = executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql") +-- | Deprecated in favour of project-branch reflog addReflogTable :: Transaction () addReflogTable = executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql") @@ -483,6 +472,15 @@ cdToProjectRoot :: Transaction () cdToProjectRoot = executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql") +addCurrentProjectPathTable :: Transaction () +addCurrentProjectPathTable = + executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql") + +-- | Deprecated in favour of project-branch reflog +addProjectBranchReflogTable :: Transaction () +addProjectBranchReflogTable = + executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql") + schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol @@ -491,10 +489,6 @@ schemaVersion = FROM schema_version |] -addCurrentProjectPathTable :: Transaction () -addCurrentProjectPathTable = - executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql") - data UnexpectedSchemaVersion = UnexpectedSchemaVersion { actual :: SchemaVersion, expected :: SchemaVersion @@ -3397,6 +3391,24 @@ getReflog numEntries = LIMIT :numEntries |] +appendProjectReflog :: ProjectReflog.Entry CausalHashId -> Transaction () +appendProjectReflog entry = + execute + [sql| + INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason) + VALUES (@entry, @, @, @, @, @) + |] + +getProjectReflog :: Int -> Transaction [ProjectReflog.Entry CausalHashId] +getProjectReflog numEntries = + queryListRow + [sql| + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + ORDER BY time DESC + LIMIT :numEntries + |] + -- | Does a project exist with this id? projectExists :: ProjectId -> Transaction Bool projectExists projectId = @@ -4283,7 +4295,7 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -expectCurrentProjectPath :: Transaction (ProjectId, ProjectBranchId, [NameSegment]) +expectCurrentProjectPath :: HasCallStack => Transaction (ProjectId, ProjectBranchId, [NameSegment]) expectCurrentProjectPath = queryOneRowCheck [sql| diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index a04fce3a56..cff3b6823f 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -27,6 +27,7 @@ dependencies: - nonempty-containers - safe - text + - time - transformers - unison-codebase - unison-codebase-sync diff --git a/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql new file mode 100644 index 0000000000..d5c66031ae --- /dev/null +++ b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql @@ -0,0 +1,26 @@ +CREATE TABLE project_branch_reflog ( + project_id INTEGER NOT NULL, + project_branch_id INTEGER NOT NULL, + -- Reminder that SQLITE doesn't have any actual 'time' type, + -- This column contains TEXT values formatted as ISO8601 strings + -- ("YYYY-MM-DD HH:MM:SS.SSS") + time TEXT NOT NULL, + -- from_root_causal_id will be null if the branch was just created + from_root_causal_id INTEGER NULL REFERENCES causal(self_hash_id), + to_root_causal_id INTEGER NOT NULL REFERENCES causal(self_hash_id), + reason TEXT NOT NULL, + + foreign key (project_id, branch_id) + references project_branch (project_id, branch_id) + on delete cascade +); + +CREATE INDEX project_branch_reflog_by_time ON reflog ( + project_branch_id, time DESC +); + + +CREATE INDEX project_reflog_by_time ON reflog ( + project_id, time DESC +); + diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 0791856217..090bc0d204 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -22,6 +22,7 @@ extra-source-files: sql/010-ensure-squash-cache-table.sql sql/011-cd-to-project-root.sql sql/012-add-current-project-path-table.sql + sql/013-add-project-branch-reflog-table.sql sql/create.sql source-repository head @@ -55,6 +56,7 @@ library U.Codebase.Sqlite.Patch.TypeEdit U.Codebase.Sqlite.Project U.Codebase.Sqlite.ProjectBranch + U.Codebase.Sqlite.ProjectReflog U.Codebase.Sqlite.Queries U.Codebase.Sqlite.Reference U.Codebase.Sqlite.Referent @@ -121,6 +123,7 @@ library , nonempty-containers , safe , text + , time , transformers , unison-codebase , unison-codebase-sync diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 3c1a5bde87..45fd7c50ce 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -106,7 +106,7 @@ module Unison.Codebase toCodeLookup, typeLookupForDependencies, unsafeGetComponentLength, - emptyCausalHash, + SqliteCodebase.Operations.emptyCausalHash, ) where @@ -536,7 +536,7 @@ unsafeGetTermComponent codebase hash = Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms -expectCurrentProjectPath :: Sqlite.Transaction PP.ProjectPath +expectCurrentProjectPath :: HasCallStack => Sqlite.Transaction PP.ProjectPath expectCurrentProjectPath = do (projectId, projectBranchId, path) <- Q.expectCurrentProjectPath proj <- Q.expectProject projectId @@ -547,13 +547,3 @@ expectCurrentProjectPath = do setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction () setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) = Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path)) - --- | Often we need to assign something to an empty causal, this ensures the empty causal --- exists in the codebase and returns its hash. -emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId) -emptyCausalHash = do - let emptyBranch = Branch.empty - SqliteCodebase.Operations.putBranch emptyBranch - let causalHash = Branch.headHash emptyBranch - causalHashId <- Queries.expectCausalHashIdByCausalHash causalHash - pure (causalHash, causalHashId) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 734020509e..1b15f79677 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -101,7 +101,7 @@ createCodebaseOrError onCreate debugName path lockOption action = do withConnection (debugName ++ ".createSchema") path \conn -> do Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do - Q.createSchema + CodebaseOps.createSchema onCreate sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case @@ -130,7 +130,7 @@ initSchemaIfNotExist path = liftIO do createDirectoryIfMissing True (makeCodebaseDirPath path) unlessM (doesFileExist $ makeCodebasePath path) $ withConnection "initSchemaIfNotExist" path \conn -> - Sqlite.runTransaction conn Q.createSchema + Sqlite.runTransaction conn CodebaseOps.createSchema -- 1) buffer up the component -- 2) in the event that the component is complete, then what? diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index b6a5464f1f..c82e467145 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction -- monad. @@ -38,6 +40,7 @@ import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import Unison.Builtin qualified as Builtins import Unison.Codebase.Branch (Branch (..)) +import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path @@ -46,7 +49,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT -import Unison.Core.Project (ProjectBranchName, ProjectName) +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as Decl import Unison.Hash (Hash) @@ -77,6 +80,32 @@ import Unison.Util.Set qualified as Set import Unison.WatchKind qualified as UF import UnliftIO.STM +createSchema :: Transaction () +createSchema = do + Q.runCreateSql + Q.addTempEntityTables + Q.addNamespaceStatsTables + Q.addReflogTable + Q.fixScopedNameLookupTables + Q.addProjectTables + Q.addMostRecentBranchTable + Q.addNameLookupMountTables + Q.addMostRecentNamespaceTable + Sqlite.execute insertSchemaVersionSql + Q.addSquashResultTable + (_, emptyCausalHashId) <- emptyCausalHash + void $ insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + Q.addProjectBranchReflogTable + where + scratchProjectName = UnsafeProjectName "scratch" + scratchBranchName = UnsafeProjectBranchName "main" + currentSchemaVersion = Q.currentSchemaVersion + insertSchemaVersionSql = + [Sqlite.sql| + INSERT INTO schema_version (version) + VALUES (:currentSchemaVersion) + |] + ------------------------------------------------------------------------------------------------------------------------ -- Buffer entry @@ -740,3 +769,13 @@ insertProjectAndBranch projectName branchName chId = do projectBranch Q.setMostRecentBranch projectId branchId pure (Project {name = projectName, projectId}, ProjectBranch {projectId, name = branchName, branchId, parentBranchId = Nothing}) + +-- | Often we need to assign something to an empty causal, this ensures the empty causal +-- exists in the codebase and returns its hash. +emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId) +emptyCausalHash = do + let emptyBranch = Branch.empty + putBranch emptyBranch + let causalHash = Branch.headHash emptyBranch + causalHashId <- Q.expectCausalHashIdByCausalHash causalHash + pure (causalHash, causalHashId) From 6ba3e87b8586b186e9157de3dd1085351fc6bc4f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 15:07:16 -0700 Subject: [PATCH 71/76] Add to project reflog --- .../U/Codebase/Sqlite/ProjectReflog.hs | 6 +--- .../U/Codebase/Sqlite/Queries.hs | 30 +++++++++++++++---- 2 files changed, 26 insertions(+), 10 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs index a01bb7a2c6..4b7ff67a05 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs @@ -3,7 +3,6 @@ module U.Codebase.Sqlite.ProjectReflog where -import Control.Lens import Data.Text (Text) import Data.Time (UTCTime) import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId) @@ -13,7 +12,7 @@ data Entry causal = Entry { project :: ProjectId, branch :: ProjectBranchId, time :: UTCTime, - fromRootCausalHash :: causal, + fromRootCausalHash :: Maybe causal, toRootCausalHash :: causal, reason :: Text } @@ -32,6 +31,3 @@ instance FromRow (Entry CausalHashId) where toRootCausalHash <- field reason <- field pure $ Entry {..} - -causals_ :: Traversal (Entry causal) (Entry causal') causal causal' -causals_ f (Entry {..}) = Entry project branch time <$> f fromRootCausalHash <*> f toRootCausalHash <*> pure reason diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index dc4e1de82c..bf79576875 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -319,6 +319,7 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Text.Lazy +import Data.Time qualified as Time import Data.Vector qualified as Vector import GHC.Stack (callStack) import Network.URI (URI) @@ -405,6 +406,7 @@ import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude import Unison.Sqlite +import Unison.Sqlite qualified as Sqlite import Unison.Util.Alternative qualified as Alternative import Unison.Util.FileEmbed (embedProjectStringFile) import Unison.Util.Lens qualified as Lens @@ -3700,12 +3702,10 @@ loadProjectAndBranchNames projectId branchId = -- | Insert a project branch. insertProjectBranch :: Text -> CausalHashId -> ProjectBranch -> Transaction () -insertProjectBranch _description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do +insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do -- Ensure we never point at a causal we don't have the branch for. _ <- expectBranchObjectIdByCausalHashId causalHashId - error "Implement project branch reflog" - execute [sql| INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) @@ -3717,6 +3717,16 @@ insertProjectBranch _description causalHashId (ProjectBranch projectId branchId INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id) VALUES (:projectId, :parentBranchId, :branchId) |] + time <- Sqlite.unsafeIO $ Time.getCurrentTime + appendProjectReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time, + fromRootCausalHash = Nothing, + toRootCausalHash = causalHashId, + reason = description + } -- | Rename a project branch. -- @@ -3791,16 +3801,26 @@ deleteProjectBranch projectId branchId = do -- | Set project branch HEAD setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () -setProjectBranchHead _description projectId branchId causalHashId = do - error "Implement project branch reflog" +setProjectBranchHead description projectId branchId causalHashId = do -- Ensure we never point at a causal we don't have the branch for. _ <- expectBranchObjectIdByCausalHashId causalHashId + oldRootCausalHashId <- expectProjectBranchHead projectId branchId execute [sql| UPDATE project_branch SET causal_hash_id = :causalHashId WHERE project_id = :projectId AND branch_id = :branchId |] + time <- Sqlite.unsafeIO $ Time.getCurrentTime + appendProjectReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time = time, + fromRootCausalHash = Just oldRootCausalHashId, + toRootCausalHash = causalHashId, + reason = description + } expectProjectBranchHead :: ProjectId -> ProjectBranchId -> Transaction CausalHashId expectProjectBranchHead projectId branchId = From cdf10c96213717f95622537fc48e0424f2623f5f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 12 Jun 2024 15:16:07 -0700 Subject: [PATCH 72/76] Migration to port project branches to have causal ids. --- .../U/Codebase/Sqlite/Queries.hs | 5 + .../014-add-project-branch-causal-hash-id.sql | 2 + .../unison-codebase-sqlite.cabal | 1 + .../Codebase/SqliteCodebase/Migrations.hs | 29 +++-- .../Migrations/MigrateSchema16To17.hs | 115 +++++++++++++++++- .../Codebase/SqliteCodebase/Operations.hs | 2 + 6 files changed, 138 insertions(+), 16 deletions(-) create mode 100644 codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index bf79576875..f12053d7d4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -258,6 +258,7 @@ module U.Codebase.Sqlite.Queries cdToProjectRoot, addCurrentProjectPathTable, addProjectBranchReflogTable, + addProjectBranchCausalHashIdColumn, -- ** schema version currentSchemaVersion, @@ -483,6 +484,10 @@ addProjectBranchReflogTable :: Transaction () addProjectBranchReflogTable = executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql") +addProjectBranchCausalHashIdColumn :: Transaction () +addProjectBranchCausalHashIdColumn = + executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql") + schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol diff --git a/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql b/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql new file mode 100644 index 0000000000..588c6228eb --- /dev/null +++ b/codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql @@ -0,0 +1,2 @@ +-- Add a new column to the project_branch table to store the causal_hash_id +ALTER TABLE project_branch ADD COLUMN causal_hash_id INTEGER NOT NULL; diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 090bc0d204..c5f8133271 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -23,6 +23,7 @@ extra-source-files: sql/011-cd-to-project-root.sql sql/012-add-current-project-path-table.sql sql/013-add-project-branch-reflog-table.sql + sql/014-add-project-branch-causal-hash-id.sql sql/create.sql source-repository head diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index eec913cb61..39026c7f36 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -48,10 +48,10 @@ migrations :: TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> CodebasePath -> - Map SchemaVersion (Sqlite.Transaction ()) + Map SchemaVersion (Sqlite.Connection -> IO ()) migrations getDeclType termBuffer declBuffer rootCodebasePath = Map.fromList - [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), + [ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer), -- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this -- caused an issue: -- @@ -68,31 +68,34 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath = -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)), - (4, migrateSchema3To4), + (4, runT migrateSchema3To4), -- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share sqlMigration 5 Q.addTempEntityTables, - (6, migrateSchema5To6 rootCodebasePath), - (7, migrateSchema6To7), - (8, migrateSchema7To8), + (6, runT $ migrateSchema5To6 rootCodebasePath), + (7, runT migrateSchema6To7), + (8, runT migrateSchema7To8), -- Recreates the name lookup tables because the primary key was missing the root hash id. sqlMigration 9 Q.fixScopedNameLookupTables, sqlMigration 10 Q.addProjectTables, sqlMigration 11 Q.addMostRecentBranchTable, - (12, migrateSchema11To12), + (12, runT migrateSchema11To12), sqlMigration 13 Q.addMostRecentNamespaceTable, sqlMigration 14 Q.addSquashResultTable, sqlMigration 15 Q.addSquashResultTableIfNotExists, sqlMigration 16 Q.cdToProjectRoot, - sqlMigration 17 migrateSchema16To17 + (17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn) ] where - sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ()) + runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO () + runT t conn = Sqlite.runWriteTransaction conn (\run -> run t) + sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ()) sqlMigration ver migration = ( ver, - do - Q.expectSchemaVersion (ver - 1) - migration - Q.setSchemaVersion ver + \conn -> Sqlite.runWriteTransaction conn \run -> run + do + Q.expectSchemaVersion (ver - 1) + migration + Q.setSchemaVersion ver ) data CodebaseVersionStatus diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs index 1a462706fc..31a7e63661 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -3,16 +3,38 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where +import Control.Lens +import Data.Text qualified as Text +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import U.Codebase.Branch.Type qualified as V2Branch +import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase qualified as Codebase +import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Operations qualified as Ops import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName)) +import Unison.NameSegment (NameSegment) +import Unison.NameSegment.Internal (NameSegment (NameSegment)) +import Unison.NameSegment.Internal qualified as NameSegment +import Unison.Prelude import Unison.Sqlite qualified as Sqlite +import Unison.Syntax.NameSegment qualified as NameSegment +import UnliftIO qualified +import UnliftIO qualified as UnsafeIO --- | This migration adds a new table to the schema, `currentProjectPath`, and sets it to contain the path to the scratch project. -migrateSchema16To17 :: Sqlite.Transaction () -migrateSchema16To17 = do +-- | This migration converts the codebase from having all projects in a single codebase root to having separate causal +-- roots for each project branch. +-- It: +-- * adds a new table to the schema, `currentProjectPath`, and sets it to contain the path to the scratch project. +-- * Adds the causal_hash_id column to the project_branch table. +-- +-- It requires a Connection argument rather than working inside a Transaction because it needs to temporarily disable +-- foreign key checking, and the foreign_key pragma cannot be set within a transaction. +migrateSchema16To17 :: Sqlite.Connection -> IO () +migrateSchema16To17 conn = withDisabledForeignKeys $ do Q.expectSchemaVersion 16 scratchMain <- Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case @@ -23,7 +45,94 @@ migrateSchema16To17 = do pure pb Q.addCurrentProjectPathTable Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId [] + addCausalHashesToProjectBranches + -- TODO: Add causal hash id to project branch table and migrate existing project branches somehow Q.setSchemaVersion 17 where scratchProjectName = UnsafeProjectName "scratch" scratchBranchName = UnsafeProjectBranchName "main" + withDisabledForeignKeys :: Sqlite.Transaction r -> IO r + withDisabledForeignKeys m = do + let disable = Sqlite.runWriteTransaction conn \run -> run $ Sqlite.execute [Sqlite.sql| PRAGMA foreign_keys=OFF |] + let enable = Sqlite.runWriteTransaction conn \run -> run $ Sqlite.execute [Sqlite.sql| PRAGMA foreign_keys=ON |] + let action = Sqlite.runWriteTransaction conn \run -> run $ m + UnsafeIO.bracket disable (const enable) (const action) + +newtype ForeignKeyFailureException + = ForeignKeyFailureException + -- We leave the data as raw as possible to ensure we can display it properly rather than get decoding errors while + -- trying to display some other error. + [[Sqlite.SQLData]] + deriving stock (Show) + deriving anyclass (Exception) + +addCausalHashesToProjectBranches :: Sqlite.Transaction () +addCausalHashesToProjectBranches = do + -- Create the new version of the project_branch table with the causal_hash_id column. + Sqlite.execute + [Sqlite.sql| +CREATE TABLE new_project_branch ( + project_id uuid NOT NULL REFERENCES project (id), + branch_id uuid NOT NULL, + name text NOT NULL, + causal_hash_id integer NOT NULL REFERENCES causal(self_hash_id), + + primary key (project_id, branch_id), + + unique (project_id, name) +) +without rowid; +|] + rootCausalHashId <- Q.expectNamespaceRoot + rootCh <- Q.expectCausalHash rootCausalHashId + projectsRoot <- Codebase.getShallowCausalAtPathFromRootHash rootCh (Path.singleton $ NameSegment.unsafeParseText "__projects") >>= V2Causal.value + ifor_ (V2Branch.children projectsRoot) \projectIdNS projectsCausal -> do + projectId <- case projectIdNS of + UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID + _ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS + projectsBranch <- V2Causal.value projectsCausal + ifor_ (V2Branch.children projectsBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do + projectBranchId <- case branchIdNS of + UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID + _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS + let branchCausalHash = V2Causal.causalHash projectBranchCausal + causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash + ProjectBranch {name = branchName} <- MaybeT $ Q.loadProjectBranch projectId projectBranchId + -- Insert the full project branch with HEAD into the new table + lift $ + Sqlite.execute + [Sqlite.sql| + INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id) + VALUES (:projectId, :projectBranchId, :branchName, :causalHashId) + |] + + -- Delete any project branch data that don't have a matching branch in the current root. + -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite + -- foreign key references. + -- We have to do this manually since we had to disable foreign key checks to add the new column. + Sqlite.execute + [Sqlite.sql| DELETE FROM project_branch_parent pbp + WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id) + |] + Sqlite.execute + [Sqlite.sql| DELETE FROM project_branch_remote_mapping pbrp + WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id) + |] + + -- Drop the old project_branch table and rename the new one to take its place. + Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |] + Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |] + foreignKeyErrs <- Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |] + when (not . null $ foreignKeyErrs) . Sqlite.unsafeIO . UnliftIO.throwIO $ ForeignKeyFailureException foreignKeyErrs + +-- migrateLooseCodeIntoLegacyProject :: Sqlite.Transaction () +-- migrateLooseCodeIntoLegacyProject = do () + +pattern UUIDNameSegment :: UUID -> NameSegment +pattern UUIDNameSegment uuid <- + ( NameSegment.toUnescapedText -> + (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) + ) + where + UUIDNameSegment uuid = + NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index c82e467145..6c2850d6f9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -95,7 +95,9 @@ createSchema = do Q.addSquashResultTable (_, emptyCausalHashId) <- emptyCausalHash void $ insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + Q.addProjectBranchCausalHashIdColumn Q.addProjectBranchReflogTable + Q.addProjectBranchCausalHashIdColumn where scratchProjectName = UnsafeProjectName "scratch" scratchBranchName = UnsafeProjectBranchName "main" From 6c115761c57ed9ce1770d5f33e52f010476c4a36 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 14:55:32 -0700 Subject: [PATCH 73/76] Split migrations into separate transactions --- .../Codebase/SqliteCodebase/Migrations.hs | 93 ++++++++++--------- 1 file changed, 48 insertions(+), 45 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 39026c7f36..dcb7cb59f5 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -36,20 +36,20 @@ import Unison.Prelude import Unison.Sqlite qualified as Sqlite import Unison.Sqlite.Connection qualified as Sqlite.Connection import Unison.Util.Monoid (foldMapM) -import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as Pretty import UnliftIO qualified -- | Mapping from schema version to the migration required to get there. -- E.g. The migration at index 2 must be run on a codebase at version 1. migrations :: + (MVar Region.ConsoleRegion) -> -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> CodebasePath -> Map SchemaVersion (Sqlite.Connection -> IO ()) -migrations getDeclType termBuffer declBuffer rootCodebasePath = +migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath = Map.fromList [ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer), -- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this @@ -68,11 +68,11 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath = -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)), - (4, runT migrateSchema3To4), + (4, runT (migrateSchema3To4 *> runIntegrityChecks regionVar)), -- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share sqlMigration 5 Q.addTempEntityTables, (6, runT $ migrateSchema5To6 rootCodebasePath), - (7, runT migrateSchema6To7), + (7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)), (8, runT migrateSchema7To8), -- Recreates the name lookup tables because the primary key was missing the root hash id. sqlMigration 9 Q.fixScopedNameLookupTables, @@ -145,7 +145,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh Region.displayConsoleRegions do (`UnliftIO.finally` finalizeRegion) do - let migs = migrations getDeclType termBuffer declBuffer root + let migs = migrations regionVar getDeclType termBuffer declBuffer root -- The highest schema that this ucm knows how to migrate to. let highestKnownSchemaVersion = fst . head $ Map.toDescList migs currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion @@ -154,11 +154,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh when shouldPrompt do putStrLn "Press to start the migration once all other ucm processes are shutdown..." void $ liftIO getLine - ranMigrations <- - Sqlite.runWriteTransaction conn \run -> do + ranMigrations <- do + currentSchemaVersion <- Sqlite.runTransaction conn $ do -- Get the schema version again now that we're in a transaction. - currentSchemaVersion <- run Q.schemaVersion - let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs + Q.schemaVersion -- This is a bit of a hack, hopefully we can remove this when we have a more -- reliable way to freeze old migration code in time. -- The problem is that 'saveObject' has been changed to flush temp entity tables, @@ -168,42 +167,15 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh -- -- Hopefully we can remove this once we've got better methods of freezing migration -- code in time. - when (currentSchemaVersion < 5) $ run Q.addTempEntityTables - when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables - for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do - putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..." - run migration - let ranMigrations = not (null migrationsToRun) - when ranMigrations do - region <- - UnliftIO.mask_ do - region <- Region.openConsoleRegion Region.Linear - putMVar regionVar region - pure region - result <- do - -- Ideally we'd check everything here, but certain codebases are known to have objects - -- with missing Hash Objects, we'll want to clean that up in a future migration. - -- integrityCheckAllHashObjects, - let checks = - Monoid.whenM - (currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked - [ integrityCheckAllBranches, - integrityCheckAllCausals - ] - - zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do - Region.setConsoleRegion - region - (Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks))) - run check - case result of - NoIntegrityErrors -> pure () - IntegrityErrorDetected errs -> do - let msg = prettyPrintIntegrityErrors errs - let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) - Region.setConsoleRegion region (Text.pack rendered) - run (abortMigration "Codebase integrity error detected.") - pure ranMigrations + when (currentSchemaVersion < 5) Q.addTempEntityTables + when (currentSchemaVersion < 6) Q.addNamespaceStatsTables + pure currentSchemaVersion + let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs + for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do + putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..." + migration conn + let ranMigrations = not (null migrationsToRun) + pure ranMigrations when ranMigrations do region <- readMVar regionVar -- Vacuum once now that any migrations have taken place. @@ -229,3 +201,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL putStrLn ("📋 I backed up your codebase to " ++ (root backupPath)) putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase." + +runIntegrityChecks :: + (MVar Region.ConsoleRegion) -> + Sqlite.Transaction () +runIntegrityChecks regionVar = do + region <- Sqlite.unsafeIO . UnliftIO.mask_ $ do + region <- Region.openConsoleRegion Region.Linear + putMVar regionVar region + pure region + result <- do + -- Ideally we'd check everything here, but certain codebases are known to have objects + -- with missing Hash Objects, we'll want to clean that up in a future migration. + -- integrityCheckAllHashObjects, + let checks = + [ integrityCheckAllBranches, + integrityCheckAllCausals + ] + + zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do + Sqlite.unsafeIO $ + Region.setConsoleRegion + region + (Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks))) + check + case result of + NoIntegrityErrors -> pure () + IntegrityErrorDetected errs -> do + let msg = prettyPrintIntegrityErrors errs + let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) + Sqlite.unsafeIO $ Region.setConsoleRegion region (Text.pack rendered) + (abortMigration "Codebase integrity error detected.") From ff2c270fcf750d94ec7cddfc7236b9d7edca3c40 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 15:41:50 -0700 Subject: [PATCH 74/76] Fix up a buncha sql --- .../U/Codebase/Sqlite/Queries.hs | 4 +- .../012-add-current-project-path-table.sql | 7 ++- .../013-add-project-branch-reflog-table.sql | 6 +-- .../Migrations/MigrateSchema16To17.hs | 50 ++++++++++++------- 4 files changed, 42 insertions(+), 25 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f12053d7d4..89d4839421 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -4343,10 +4343,10 @@ setCurrentProjectPath :: Transaction () setCurrentProjectPath projId branchId path = do execute - [sql| TRUNCATE TABLE current_project_path |] + [sql| DELETE FROM current_project_path |] execute [sql| - INSERT INTO most_recent_namespace(project_id, branch_id, path) + INSERT INTO current_project_path(project_id, branch_id, path) VALUES (:projId, :branchId, :jsonPath) |] where diff --git a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql index 5a511a4394..b00290be50 100644 --- a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql +++ b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql @@ -4,7 +4,10 @@ CREATE TABLE current_project_path ( project_id INTEGER NOT NULL REFERENCES project (id), branch_id INTEGER NOT NULL REFERENCES project_branch (id), -- A json array like ["foo", "bar"]; the root namespace is represented by the empty array - path TEXT PRIMARY KEY NOT NULL + path TEXT PRIMARY KEY NOT NULL, + + foreign key (project_id, branch_id) + references project_branch (project_id, branch_id), ) WITHOUT ROWID; -DROP TABLE "most_recent_namespace"; +DROP TABLE most_recent_namespace; diff --git a/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql index d5c66031ae..589ed1812f 100644 --- a/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql +++ b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql @@ -10,17 +10,17 @@ CREATE TABLE project_branch_reflog ( to_root_causal_id INTEGER NOT NULL REFERENCES causal(self_hash_id), reason TEXT NOT NULL, - foreign key (project_id, branch_id) + foreign key (project_id, project_branch_id) references project_branch (project_id, branch_id) on delete cascade ); -CREATE INDEX project_branch_reflog_by_time ON reflog ( +CREATE INDEX project_branch_reflog_by_time ON project_branch_reflog ( project_branch_id, time DESC ); -CREATE INDEX project_reflog_by_time ON reflog ( +CREATE INDEX project_reflog_by_time ON project_branch_reflog ( project_id, time DESC ); diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs index 31a7e63661..674466212f 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -4,6 +4,7 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where import Control.Lens +import Data.Map qualified as Map import Data.Text qualified as Text import Data.UUID (UUID) import Data.UUID qualified as UUID @@ -36,6 +37,8 @@ import UnliftIO qualified as UnsafeIO migrateSchema16To17 :: Sqlite.Connection -> IO () migrateSchema16To17 conn = withDisabledForeignKeys $ do Q.expectSchemaVersion 16 + Q.addProjectBranchReflogTable + addCausalHashesToProjectBranches scratchMain <- Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case Just pb -> pure pb @@ -45,8 +48,6 @@ migrateSchema16To17 conn = withDisabledForeignKeys $ do pure pb Q.addCurrentProjectPathTable Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId [] - addCausalHashesToProjectBranches - -- TODO: Add causal hash id to project branch table and migrate existing project branches somehow Q.setSchemaVersion 17 where scratchProjectName = UnsafeProjectName "scratch" @@ -91,31 +92,44 @@ without rowid; UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID _ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS projectsBranch <- V2Causal.value projectsCausal - ifor_ (V2Branch.children projectsBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do - projectBranchId <- case branchIdNS of - UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID - _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS - let branchCausalHash = V2Causal.causalHash projectBranchCausal - causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash - ProjectBranch {name = branchName} <- MaybeT $ Q.loadProjectBranch projectId projectBranchId - -- Insert the full project branch with HEAD into the new table - lift $ - Sqlite.execute - [Sqlite.sql| - INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id) - VALUES (:projectId, :projectBranchId, :branchName, :causalHashId) - |] + case (Map.lookup (NameSegment.unsafeParseText "branches") $ V2Branch.children projectsBranch) of + Nothing -> pure () + Just branchesCausal -> do + branchesBranch <- V2Causal.value branchesCausal + ifor_ (V2Branch.children branchesBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do + projectBranchId <- case branchIdNS of + UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID + _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS + let branchCausalHash = V2Causal.causalHash projectBranchCausal + causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash + branchName <- + MaybeT $ + Sqlite.queryMaybeCol @ProjectBranchName + [Sqlite.sql| + SELECT project_branch.name + FROM project_branch + WHERE + project_branch.project_id = :projectId + AND project_branch.branch_id = :projectBranchId + |] + -- Insert the full project branch with HEAD into the new table + lift $ + Sqlite.execute + [Sqlite.sql| + INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id) + VALUES (:projectId, :projectBranchId, :branchName, :causalHashId) + |] -- Delete any project branch data that don't have a matching branch in the current root. -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite -- foreign key references. -- We have to do this manually since we had to disable foreign key checks to add the new column. Sqlite.execute - [Sqlite.sql| DELETE FROM project_branch_parent pbp + [Sqlite.sql| DELETE FROM project_branch_parent AS pbp WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id) |] Sqlite.execute - [Sqlite.sql| DELETE FROM project_branch_remote_mapping pbrp + [Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id) |] From f192edbed4feba5572aa235a2902366864218566 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 16:42:58 -0700 Subject: [PATCH 75/76] Fix up migration quirks --- .../U/Codebase/Sqlite/Queries.hs | 3 +-- .../012-add-current-project-path-table.sql | 6 +++--- .../Codebase/SqliteCodebase/Migrations.hs | 13 +++++++++++-- .../Migrations/MigrateSchema16To17.hs | 19 +++++++++++++++++-- 4 files changed, 32 insertions(+), 9 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 89d4839421..092a9b0d30 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3551,8 +3551,7 @@ loadProjectBranchSql projectId branchId = project_branch.project_id, project_branch.branch_id, project_branch.name, - project_branch_parent.parent_branch_id, - project_branch.causal_hash_id + project_branch_parent.parent_branch_id FROM project_branch LEFT JOIN project_branch_parent ON project_branch.project_id = project_branch_parent.project_id diff --git a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql index b00290be50..63b3d07559 100644 --- a/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql +++ b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql @@ -1,13 +1,13 @@ -- The most recent namespace that a user cd'd to. -- This table should never have more than one row. CREATE TABLE current_project_path ( - project_id INTEGER NOT NULL REFERENCES project (id), - branch_id INTEGER NOT NULL REFERENCES project_branch (id), + project_id INTEGER NOT NULL, + branch_id INTEGER NOT NULL, -- A json array like ["foo", "bar"]; the root namespace is represented by the empty array path TEXT PRIMARY KEY NOT NULL, foreign key (project_id, branch_id) - references project_branch (project_id, branch_id), + references project_branch (project_id, branch_id) ) WITHOUT ROWID; DROP TABLE most_recent_namespace; diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index dcb7cb59f5..5244facbf8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -31,6 +31,7 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2 import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath) import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.ConstructorType qualified as CT +import Unison.Debug qualified as Debug import Unison.Hash (Hash) import Unison.Prelude import Unison.Sqlite qualified as Sqlite @@ -176,12 +177,20 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh migration conn let ranMigrations = not (null migrationsToRun) pure ranMigrations + Debug.debugLogM Debug.Migration "Migrations complete" when ranMigrations do - region <- readMVar regionVar + region <- + UnliftIO.mask_ do + region <- Region.openConsoleRegion Region.Linear + putMVar regionVar region + pure region -- Vacuum once now that any migrations have taken place. Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text) case vacuumStrategy of - Vacuum -> void $ Sqlite.Connection.vacuum conn + Vacuum -> do + Debug.debugLogM Debug.Migration "About to VACUUM" + void $ Sqlite.Connection.vacuum conn + Debug.debugLogM Debug.Migration "Done VACUUM" NoVacuum -> pure () Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs index 674466212f..3feba3768a 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -17,11 +17,13 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Operations qualified as Ops import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName)) +import Unison.Debug qualified as Debug import Unison.NameSegment (NameSegment) import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude import Unison.Sqlite qualified as Sqlite +import Unison.Sqlite.Connection qualified as Connection import Unison.Syntax.NameSegment qualified as NameSegment import UnliftIO qualified import UnliftIO qualified as UnsafeIO @@ -38,7 +40,9 @@ migrateSchema16To17 :: Sqlite.Connection -> IO () migrateSchema16To17 conn = withDisabledForeignKeys $ do Q.expectSchemaVersion 16 Q.addProjectBranchReflogTable + Debug.debugLogM Debug.Migration "Adding causal hashes to project branches table." addCausalHashesToProjectBranches + Debug.debugLogM Debug.Migration "Adding scratch project" scratchMain <- Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case Just pb -> pure pb @@ -46,16 +50,19 @@ migrateSchema16To17 conn = withDisabledForeignKeys $ do (_, emptyCausalHashId) <- Codebase.emptyCausalHash (_proj, pb) <- Ops.insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId pure pb + Debug.debugLogM Debug.Migration "Adding current project path table" Q.addCurrentProjectPathTable + Debug.debugLogM Debug.Migration "Setting current project path to scratch project" Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId [] + Debug.debugLogM Debug.Migration "Done migrating to version 17" Q.setSchemaVersion 17 where scratchProjectName = UnsafeProjectName "scratch" scratchBranchName = UnsafeProjectBranchName "main" withDisabledForeignKeys :: Sqlite.Transaction r -> IO r withDisabledForeignKeys m = do - let disable = Sqlite.runWriteTransaction conn \run -> run $ Sqlite.execute [Sqlite.sql| PRAGMA foreign_keys=OFF |] - let enable = Sqlite.runWriteTransaction conn \run -> run $ Sqlite.execute [Sqlite.sql| PRAGMA foreign_keys=ON |] + let disable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=OFF |] + let enable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=ON |] let action = Sqlite.runWriteTransaction conn \run -> run $ m UnsafeIO.bracket disable (const enable) (const action) @@ -69,6 +76,7 @@ newtype ForeignKeyFailureException addCausalHashesToProjectBranches :: Sqlite.Transaction () addCausalHashesToProjectBranches = do + Debug.debugLogM Debug.Migration "Creating new_project_branch" -- Create the new version of the project_branch table with the causal_hash_id column. Sqlite.execute [Sqlite.sql| @@ -91,6 +99,7 @@ without rowid; projectId <- case projectIdNS of UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID _ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS + Debug.debugM Debug.Migration "Migrating project" projectId projectsBranch <- V2Causal.value projectsCausal case (Map.lookup (NameSegment.unsafeParseText "branches") $ V2Branch.children projectsBranch) of Nothing -> pure () @@ -100,6 +109,7 @@ without rowid; projectBranchId <- case branchIdNS of UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS + Debug.debugM Debug.Migration "Migrating project branch" projectBranchId let branchCausalHash = V2Causal.causalHash projectBranchCausal causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash branchName <- @@ -120,6 +130,7 @@ without rowid; VALUES (:projectId, :projectBranchId, :branchName, :causalHashId) |] + Debug.debugLogM Debug.Migration "Deleting orphaned project branch data" -- Delete any project branch data that don't have a matching branch in the current root. -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite -- foreign key references. @@ -128,14 +139,18 @@ without rowid; [Sqlite.sql| DELETE FROM project_branch_parent AS pbp WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id) |] + Debug.debugLogM Debug.Migration "Deleting orphaned remote mapping data" Sqlite.execute [Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id) |] + Sqlite.execute [Sqlite.sql| DELETE FROM most_recent_branch |] + Debug.debugLogM Debug.Migration "Swapping old and new project branch tables" -- Drop the old project_branch table and rename the new one to take its place. Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |] Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |] + Debug.debugLogM Debug.Migration "Checking foreign keys" foreignKeyErrs <- Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |] when (not . null $ foreignKeyErrs) . Sqlite.unsafeIO . UnliftIO.throwIO $ ForeignKeyFailureException foreignKeyErrs From cc441e97bbcaec271a02b7c6a041ed8e74fc4cdf Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 14 Jun 2024 17:05:34 -0700 Subject: [PATCH 76/76] Fix projectpath updating in memory branch --- unison-cli/src/Unison/Cli/Monad.hs | 21 +++++++++++++++++---- unison-cli/src/Unison/Cli/MonadUtils.hs | 8 +------- unison-cli/src/Unison/Cli/Pretty.hs | 7 ++++++- 3 files changed, 24 insertions(+), 12 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index b6c137c3ce..7663066237 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -48,6 +48,10 @@ module Unison.Cli.Monad runTransaction, runTransactionWithRollback, + -- * Internal + setMostRecentProjectPath, + setInMemoryCurrentProjectRoot, + -- * Misc types LoadSourceResult (..), ) @@ -81,10 +85,10 @@ import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime (Runtime) +import Unison.Core.Project (ProjectAndBranch (..)) import Unison.Debug qualified as Debug import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..)) import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) @@ -387,11 +391,21 @@ cd path = do setMostRecentProjectPath newPP #projectPathStack %= NonEmpty.cons newPP +-- | Set the in-memory project root to the given branch, without updating the database. +setInMemoryCurrentProjectRoot :: Branch IO -> Cli () +setInMemoryCurrentProjectRoot !newRoot = do + rootVar <- use #currentProjectRoot + atomically do + void $ swapTMVar rootVar newRoot + switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () switchProject (ProjectAndBranch projectId branchId) = do + Env {codebase} <- ask let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty #projectPathStack %= NonEmpty.cons newPP runTransaction $ Q.setMostRecentBranch projectId branchId + pbr <- liftIO $ Codebase.expectProjectBranchRoot codebase projectId branchId + setInMemoryCurrentProjectRoot pbr setMostRecentProjectPath newPP -- | Pop the latest path off the stack, if it's not the only path in the stack. @@ -408,9 +422,8 @@ popd = do pure True setMostRecentProjectPath :: PP.ProjectPathIds -> Cli () -setMostRecentProjectPath _loc = - -- runTransaction . Queries.setMostRecentLocation . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute - error "Implement setMostRecentLocation" +setMostRecentProjectPath loc = + runTransaction $ Codebase.setCurrentProjectPath loc respond :: Output -> Cli () respond output = do diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 2e6abfdc30..5cd11912d5 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -458,15 +458,9 @@ updateProjectBranchRoot projectBranch reason f = do causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId if projectBranch.branchId == currentPB.branchId - then setCurrentProjectRoot new + then Cli.setInMemoryCurrentProjectRoot new else pure () pure result - where - setCurrentProjectRoot :: Branch IO -> Cli () - setCurrentProjectRoot !newRoot = do - rootVar <- use #currentProjectRoot - atomically do - void $ swapTMVar rootVar newRoot updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () updateProjectBranchRoot_ projectBranch reason f = do diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index ac56a7d644..96ec98d48f 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -121,6 +121,7 @@ import Unison.Term (Term) import Unison.Type (Type) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P import Unison.Var (Var) import Unison.Var qualified as Var @@ -200,7 +201,11 @@ prettyAbsolute :: Path.Absolute -> Pretty prettyAbsolute = P.blue . P.shown prettyProjectPath :: PP.ProjectPath -> Pretty -prettyProjectPath = P.blue . P.shown +prettyProjectPath (PP.ProjectPath project branch path) = + prettyProjectAndBranchName (ProjectAndBranch project.name branch.name) + <> + -- Only show the path if it's not the root + Monoid.whenM (path /= Path.absoluteEmpty) (P.cyan (":" <> P.shown path)) prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)