diff --git a/.gitignore b/.gitignore index e02fc7f2b28..94b29b69e8f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,14 @@ # Unison .unison* test-output -transcript-* -scratch.u unisonLocal.zip +*.uc +# Ignore all scratch files... +*.u +# Except those in unison-src +!unison-src/**/*.u +# And integration tests +!unison-cli-integration/integration-tests/IntegrationTests/**/*.u # Auto-generated jit-tests.md @@ -19,6 +24,7 @@ dist-newstyle # GHC *.hie *.prof +*.prof.html /.direnv/ /.envrc diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 324177438f6..5c4e0836168 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, @@ -13,6 +8,7 @@ module U.Codebase.Sqlite.Operations saveBranchV3, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, + expectBranchByCausalHashId, expectBranchByBranchHash, expectBranchByBranchHashId, expectNamespaceStatsByHash, @@ -100,9 +96,16 @@ module U.Codebase.Sqlite.Operations fuzzySearchDefinitions, namesPerspectiveForRootAndPath, + -- * Projects + expectProjectAndBranchNames, + expectProjectBranchHead, + -- * reflog - getReflog, - appendReflog, + getDeprecatedRootReflog, + getProjectReflog, + getProjectBranchReflog, + getGlobalReflog, + appendProjectReflog, -- * low-level stuff expectDbBranch, @@ -183,6 +186,9 @@ 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.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 @@ -200,6 +206,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) @@ -232,23 +239,10 @@ 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 -> [NameSegment] -> Transaction (Maybe CausalHash) -loadCausalHashAtPath mayRootCausalHash = +loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash) +loadCausalHashAtPath rootCausalHash = let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash go hashId = \case [] -> lift (Q.expectCausalHash hashId) @@ -258,15 +252,13 @@ loadCausalHashAtPath mayRootCausalHash = (_, hashId') <- MaybeT (pure (Map.lookup tid children)) go hashId' ts in \path -> do - hashId <- case mayRootCausalHash of - Nothing -> Q.expectNamespaceRoot - Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH + hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash runMaybeT (go hashId path) -- | Expect the causal hash at the given path from the provided root, if Nothing, use the -- codebase root. -expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash -expectCausalHashAtPath mayRootCausalHash = +expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash +expectCausalHashAtPath rootCausalHash = let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash go hashId = \case [] -> Q.expectCausalHash hashId @@ -276,23 +268,21 @@ expectCausalHashAtPath mayRootCausalHash = let (_, hashId') = children Map.! tid go hashId' ts in \path -> do - hashId <- case mayRootCausalHash of - Nothing -> Q.expectNamespaceRoot - Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH + hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash go hashId path loadCausalBranchAtPath :: - Maybe CausalHash -> + CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.CausalBranch Transaction)) -loadCausalBranchAtPath maybeRootCausalHash path = - loadCausalHashAtPath maybeRootCausalHash path >>= \case +loadCausalBranchAtPath rootCausalHash path = + loadCausalHashAtPath rootCausalHash path >>= \case Nothing -> pure Nothing Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash -loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction)) -loadBranchAtPath maybeRootCausalHash path = - loadCausalBranchAtPath maybeRootCausalHash path >>= \case +loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction)) +loadBranchAtPath rootCausalHash path = + loadCausalBranchAtPath rootCausalHash path >>= \case Nothing -> pure Nothing Just causal -> Just <$> C.Causal.value causal @@ -613,16 +603,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 @@ -749,9 +729,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 @@ -1510,15 +1487,43 @@ namespaceStatsForDbBranch = \case expectNamespaceStatsByHashId bhId -- | Gets the specified number of reflog entries in chronological order, most recent first. -getReflog :: Int -> Transaction [Reflog.Entry CausalHash Text] -getReflog numEntries = do - entries <- Q.getReflog numEntries +getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHash Text] +getDeprecatedRootReflog numEntries = do + entries <- Q.getDeprecatedRootReflog numEntries traverse (bitraverse Q.expectCausalHash pure) entries -appendReflog :: Reflog.Entry CausalHash Text -> Transaction () -appendReflog entry = do - dbEntry <- (bitraverse Q.saveCausalHash pure) entry - Q.appendReflog dbEntry +-- | Gets the specified number of reflog entries for the given project in chronological order, most recent first. +getProjectReflog :: Int -> Db.ProjectId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getProjectReflog numEntries projectId = do + entries <- Q.getProjectReflog numEntries projectId + traverse hydrateProjectReflogEntry entries + +-- | Gets the specified number of reflog entries for the specified ProjectBranch in chronological order, most recent first. +getProjectBranchReflog :: Int -> Db.ProjectBranchId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getProjectBranchReflog numEntries projectBranchId = do + entries <- Q.getProjectBranchReflog numEntries projectBranchId + traverse hydrateProjectReflogEntry entries + +-- | Gets the specified number of reflog entries in chronological order, most recent first. +getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash] +getGlobalReflog numEntries = do + entries <- Q.getGlobalReflog numEntries + traverse hydrateProjectReflogEntry entries + +hydrateProjectReflogEntry :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId Db.CausalHashId -> Transaction (ProjectReflog.Entry Project ProjectBranch CausalHash) +hydrateProjectReflogEntry entry = do + traverse Q.expectCausalHash entry + >>= ProjectReflog.projectAndBranch_ + %%~ ( \(projId, branchId) -> do + proj <- Q.expectProject projId + branch <- Q.expectProjectBranch projId branchId + pure (proj, branch) + ) + +appendProjectReflog :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId CausalHash -> Transaction () +appendProjectReflog entry = do + dbEntry <- traverse Q.saveCausalHash entry + Q.appendProjectBranchReflog dbEntry -- | Delete any name lookup that's not in the provided list. -- @@ -1584,3 +1589,14 @@ 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) + +expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash +expectProjectBranchHead projId projectBranchId = do + chId <- Q.expectProjectBranchHead projId projectBranchId + Q.expectCausalHash chId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs index 2707e09c74d..94e90b5c00a 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/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs new file mode 100644 index 00000000000..b759df25865 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module U.Codebase.Sqlite.ProjectReflog + ( Entry (..), + project_, + branch_, + projectAndBranch_, + ) +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 project branch causal = Entry + { project :: project, + branch :: branch, + time :: UTCTime, + fromRootCausalHash :: Maybe causal, + toRootCausalHash :: causal, + reason :: Text + } + deriving stock (Eq, Show, Functor, Foldable, Traversable) + +project_ :: Lens (Entry project branch causal) (Entry project' branch causal) project project' +project_ = lens project (\e p -> e {project = p}) + +branch_ :: Lens (Entry project branch causal) (Entry project branch' causal) branch branch' +branch_ = lens branch (\e b -> e {branch = b}) + +-- | Both Project and Branch Ids are required to load a branch, so this is often more useful. +projectAndBranch_ :: Lens (Entry project branch causal) (Entry project' branch' causal) (project, branch) (project', branch') +projectAndBranch_ = lens (\Entry {..} -> (project, branch)) (\e (project, branch) -> e {project = project, branch = branch}) + +instance ToRow (Entry ProjectId ProjectBranchId CausalHashId) where + toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) = + toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason) + +instance FromRow (Entry ProjectId ProjectBranchId CausalHashId) where + fromRow = do + project <- field + branch <- field + time <- field + fromRootCausalHash <- field + toRootCausalHash <- field + reason <- field + pure $ Entry {..} diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4d436a9982c..927021ecec5 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -66,12 +66,6 @@ module U.Codebase.Sqlite.Queries loadTermObject, expectTermObject, - -- * namespace_root table - loadNamespaceRoot, - setNamespaceRoot, - expectNamespaceRoot, - expectNamespaceRootBranchHashId, - -- * namespace_statistics table saveNamespaceStats, loadNamespaceStatsByHashId, @@ -135,6 +129,8 @@ module U.Codebase.Sqlite.Queries insertProjectBranch, renameProjectBranch, deleteProjectBranch, + setProjectBranchHead, + expectProjectBranchHead, setMostRecentBranch, loadMostRecentBranch, @@ -215,8 +211,11 @@ module U.Codebase.Sqlite.Queries fuzzySearchTypes, -- * Reflog - appendReflog, - getReflog, + getDeprecatedRootReflog, + appendProjectBranchReflog, + getProjectReflog, + getProjectBranchReflog, + getGlobalReflog, -- * garbage collection garbageCollectObjectsWithoutHashes, @@ -237,12 +236,12 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashes, - -- * most recent namespace - expectMostRecentNamespace, - setMostRecentNamespace, + -- * current project path + expectCurrentProjectPath, + setCurrentProjectPath, -- * migrations - createSchema, + runCreateSql, addTempEntityTables, addReflogTable, addNamespaceStatsTables, @@ -254,6 +253,9 @@ module U.Codebase.Sqlite.Queries addSquashResultTable, addSquashResultTableIfNotExists, cdToProjectRoot, + addCurrentProjectPathTable, + addProjectBranchReflogTable, + addProjectBranchCausalHashIdColumn, -- ** schema version currentSchemaVersion, @@ -315,6 +317,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) @@ -367,7 +370,8 @@ 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.Reference qualified as S (Reference, ReferenceH, TermReference, TermReferenceId, TextReference, TypeReference, TypeReferenceId) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog +import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference import U.Codebase.Sqlite.Referent qualified as S (TextReferent) import U.Codebase.Sqlite.Referent qualified as S.Referent @@ -399,6 +403,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.Defns (Defns (..), DefnsF) import Unison.Util.FileEmbed (embedProjectStringFile) @@ -414,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 = @@ -444,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") @@ -482,6 +472,19 @@ 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") + +addProjectBranchCausalHashIdColumn :: Transaction () +addProjectBranchCausalHashIdColumn = + executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql") + schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol @@ -1337,32 +1340,6 @@ loadCausalParentsByHash hash = WHERE h1.base32 = :hash COLLATE NOCASE |] -expectNamespaceRootBranchHashId :: Transaction BranchHashId -expectNamespaceRootBranchHashId = do - chId <- expectNamespaceRoot - expectCausalValueHashId chId - -expectNamespaceRoot :: Transaction CausalHashId -expectNamespaceRoot = - queryOneCol loadNamespaceRootSql - -loadNamespaceRoot :: Transaction (Maybe CausalHashId) -loadNamespaceRoot = - queryMaybeCol loadNamespaceRootSql - -loadNamespaceRootSql :: Sql -loadNamespaceRootSql = - [sql| - SELECT causal_id - FROM namespace_root - |] - -setNamespaceRoot :: CausalHashId -> Transaction () -setNamespaceRoot id = - queryOneCol [sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case - False -> execute [sql| INSERT INTO namespace_root VALUES (:id) |] - True -> execute [sql| UPDATE namespace_root SET causal_id = :id |] - saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction () saveWatch k r blob = do execute @@ -3496,20 +3473,55 @@ loadNamespaceStatsByHashId bhId = do WHERE namespace_hash_id = :bhId |] -appendReflog :: Reflog.Entry CausalHashId Text -> Transaction () -appendReflog entry = +getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text] +getDeprecatedRootReflog numEntries = + queryListRow + [sql| + SELECT time, from_root_causal_id, to_root_causal_id, reason + FROM reflog + ORDER BY time DESC + LIMIT :numEntries + |] + +appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction () +appendProjectBranchReflog entry = execute [sql| - INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason) - VALUES (@entry, @, @, @) + INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason) + VALUES (@entry, @, @, @, @, @) |] -getReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text] -getReflog numEntries = +-- | Get x number of entries from the project reflog for the provided project +getProjectReflog :: Int -> ProjectId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getProjectReflog numEntries projectId = queryListRow [sql| - SELECT time, from_root_causal_id, to_root_causal_id, reason - FROM reflog + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + WHERE project_id = :projectId + ORDER BY time DESC + LIMIT :numEntries + |] + +-- | Get x number of entries from the project reflog for the provided branch. +getProjectBranchReflog :: Int -> ProjectBranchId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getProjectBranchReflog numEntries projectBranchId = + queryListRow + [sql| + SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason + FROM project_branch_reflog + WHERE project_branch_id = :projectBranchId + ORDER BY time DESC + LIMIT :numEntries + |] + +-- | Get x number of entries from the global reflog spanning all projects +getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId] +getGlobalReflog 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 |] @@ -3803,12 +3815,15 @@ loadProjectAndBranchNames projectId branchId = |] -- | Insert a project branch. -insertProjectBranch :: ProjectBranch -> Transaction () -insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do +insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction () +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 + 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 @@ -3816,6 +3831,16 @@ insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBran INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id) VALUES (:projectId, :parentBranchId, :branchId) |] + time <- Sqlite.unsafeIO $ Time.getCurrentTime + appendProjectBranchReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time, + fromRootCausalHash = Nothing, + toRootCausalHash = causalHashId, + reason = description + } -- | Rename a project branch. -- @@ -3864,7 +3889,7 @@ deleteProject projectId = do -- After deleting `topic`: -- -- main <- topic2 -deleteProjectBranch :: ProjectId -> ProjectBranchId -> Transaction () +deleteProjectBranch :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction () deleteProjectBranch projectId branchId = do maybeParentBranchId :: Maybe ProjectBranchId <- queryMaybeCol @@ -3888,6 +3913,38 @@ deleteProjectBranch projectId branchId = do WHERE project_id = :projectId AND branch_id = :branchId |] +-- | Set project branch HEAD +setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction () +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 + appendProjectBranchReflog $ + ProjectReflog.Entry + { project = projectId, + branch = branchId, + time = time, + fromRootCausalHash = Just oldRootCausalHashId, + toRootCausalHash = causalHashId, + reason = description + } + +expectProjectBranchHead :: (HasCallStack) => 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 @@ -4372,33 +4429,39 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -expectMostRecentNamespace :: Transaction [NameSegment] -expectMostRecentNamespace = - queryOneColCheck +expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment]) +expectCurrentProjectPath = + queryOneRowCheck [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 :: [NameSegment] -> Transaction () -setMostRecentNamespace namespace = +setCurrentProjectPath :: + ProjectId -> + ProjectBranchId -> + [NameSegment] -> + Transaction () +setCurrentProjectPath projId branchId path = do + execute + [sql| DELETE FROM current_project_path |] execute [sql| - UPDATE most_recent_namespace - SET namespace = :json + INSERT INTO current_project_path(project_id, branch_id, path) + VALUES (:projId, :branchId, :jsonPath) |] where - json :: Text - json = - Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace) + jsonPath :: Text + jsonPath = + Text.Lazy.toStrict (Aeson.encodeToLazyText $ 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/package.yaml b/codebase2/codebase-sqlite/package.yaml index 3f6006ff0ce..01c4c225444 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/012-add-current-project-path-table.sql b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql new file mode 100644 index 00000000000..8de5f05169f --- /dev/null +++ b/codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql @@ -0,0 +1,15 @@ +-- 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, + 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) + -- Prevent deleting the project you're currently in. + on delete no action +) WITHOUT ROWID; + +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 new file mode 100644 index 00000000000..51420510333 --- /dev/null +++ b/codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql @@ -0,0 +1,32 @@ +-- A reflog which is tied to the project/branch +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, project_branch_id) + references project_branch (project_id, branch_id) + on delete cascade +); + +CREATE INDEX project_branch_reflog_by_time ON project_branch_reflog ( + project_branch_id, time DESC +); + + +CREATE INDEX project_reflog_by_time ON project_branch_reflog ( + project_id, time DESC +); + +CREATE INDEX global_reflog_by_time ON project_branch_reflog ( + time DESC +); + + 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 00000000000..588c6228ebc --- /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 886a47a5101..f5211b310de 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,9 @@ 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/013-add-project-branch-reflog-table.sql + sql/014-add-project-branch-causal-hash-id.sql sql/create.sql source-repository head @@ -54,6 +57,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 +125,7 @@ library , nonempty-containers , safe , text + , time , transformers , unison-codebase , unison-codebase-sync diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f46917ddc84..d7495592988 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 cf760c49367..a5737274618 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 49a5e01aa88..e40f4a76392 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 diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 107b765c3ed..6187f056485 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,6 +1,11 @@ module Unison.Codebase ( Codebase, + -- * UCM session state + expectCurrentProjectPath, + setCurrentProjectPath, + resolveProjectPathIds, + -- * Terms getTerm, unsafeGetTerm, @@ -43,18 +48,20 @@ module Unison.Codebase lca, SqliteCodebase.Operations.before, getShallowBranchAtPath, + getMaybeShallowBranchAtPath, getShallowCausalAtPath, - getBranchAtPath, Operations.expectCausalBranchByCausalHash, - getShallowCausalFromRoot, - getShallowRootBranch, - getShallowRootCausal, + getShallowCausalAtPathFromRootHash, + getShallowProjectBranchRoot, + expectShallowProjectBranchRoot, + getShallowBranchAtProjectPath, + getMaybeShallowBranchAtProjectPath, + getShallowProjectRootByNames, + expectProjectBranchRoot, + getBranchAtProjectPath, + preloadProjectBranch, -- * Root branch - getRootBranch, - SqliteCodebase.Operations.getRootBranchExists, - Operations.expectRootCausalHash, - putRootBranch, SqliteCodebase.Operations.namesAtPath, -- * Patches @@ -70,7 +77,10 @@ module Unison.Codebase Queries.clearWatches, -- * Reflog - Operations.getReflog, + Operations.getDeprecatedRootReflog, + Operations.getProjectBranchReflog, + Operations.getProjectReflog, + Operations.getGlobalReflog, -- * Unambiguous hash length SqliteCodebase.Operations.hashLength, @@ -103,16 +113,19 @@ module Unison.Codebase toCodeLookup, typeLookupForDependencies, unsafeGetComponentLength, + SqliteCodebase.Operations.emptyCausalHash, ) 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) +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 @@ -122,11 +135,13 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import Unison.Codebase.CodeLookup qualified as CL 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 (..)) 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) @@ -134,6 +149,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 @@ -164,72 +180,105 @@ 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 - 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 +getShallowCausalAtPathFromRootHash rootCausalHash p = do + rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash + 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. 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 = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch + +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getMaybeShallowBranchAtPath :: + Path -> + V2Branch.Branch Sqlite.Transaction -> + Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getMaybeShallowBranchAtPath path branch = do case path of - Path.Empty -> pure branch + Path.Empty -> pure $ Just branch ns Path.:< p -> do case V2Branch.childAt ns branch of - Nothing -> pure V2Branch.empty + Nothing -> pure Nothing Just childCausal -> do childBranch <- V2Causal.value childCausal - getShallowBranchAtPath p (Just childBranch) + getMaybeShallowBranchAtPath p childBranch + +-- | 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 = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp --- | Get a v1 branch from the root following the given path. -getBranchAtPath :: +-- | Recursively descend into causals following the given path, +-- Use the root causal if none is provided. +getMaybeShallowBranchAtProjectPath :: + PP.ProjectPath -> + Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction)) +getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do + getShallowProjectBranchRoot projectBranch >>= \case + Nothing -> pure Nothing + Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch + +getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) +getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do + ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName + causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId + causalHash <- lift $ Q.expectCausalHash causalHashId + lift $ Operations.expectCausalBranchByCausalHash causalHash + +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 + 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 -> - Path.Absolute -> - m (Branch m) -getBranchAtPath codebase path = do - V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing - expectBranchForHash codebase causalHash + PP.ProjectPath -> + m (Maybe (Branch m)) +getBranchAtProjectPath codebase pp = runMaybeT do + 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. expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m) @@ -347,9 +396,12 @@ typeLookupForDependencies codebase s = do unseen :: TL.TypeLookup Symbol a -> Reference -> Bool unseen tl r = isNothing - ( Map.lookup r (TL.dataDecls tl) $> () - <|> Map.lookup r (TL.typeOfTerms tl) $> () - <|> Map.lookup r (TL.effectDecls tl) $> () + ( Map.lookup r (TL.dataDecls tl) + $> () + <|> Map.lookup r (TL.typeOfTerms tl) + $> () + <|> Map.lookup r (TL.effectDecls tl) + $> () ) toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann @@ -509,3 +561,30 @@ unsafeGetTermComponent codebase hash = getTermComponentWithTypes codebase hash <&> \case Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found")) Just terms -> terms + +expectCurrentProjectPath :: (HasCallStack) => 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) = + Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path)) + +-- | Hydrate the project and branch from IDs. +resolveProjectPathIds :: PP.ProjectPathIds -> Sqlite.Transaction PP.ProjectPath +resolveProjectPathIds (PP.ProjectPath projectId projectBranchId path) = do + proj <- Q.expectProject projectId + projBranch <- Q.expectProjectBranch projectId projectBranchId + pure $ PP.ProjectPath proj projBranch path + +-- | Starts loading the given project branch into cache in a background thread without blocking. +preloadProjectBranch :: (MonadUnliftIO m) => Codebase m v a -> ProjectAndBranch Db.ProjectId Db.ProjectBranchId -> m () +preloadProjectBranch codebase (ProjectAndBranch projectId branchId) = do + ch <- runTransaction codebase $ do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId + preloadProjectRoot codebase ch diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index d0025cd87e3..aff8f08c1b3 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/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index a3d5c63f51b..bd352cbc268 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/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 7d162618216..788bc5abe15 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -6,19 +6,23 @@ module Unison.Codebase.Execute where import Control.Exception (finally) -import Control.Monad.Except (throwError, runExceptT) -import Control.Monad.IO.Class (liftIO) +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 qualified as Names import Unison.Parser.Ann (Ann) +import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) @@ -27,15 +31,22 @@ import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - HQ.HashQualified Name -> + PP.ProjectPathNames -> IO (Either Runtime.Error ()) -execute codebase runtime mainName = +execute codebase runtime mainPath = (`finally` Runtime.terminate runtime) . runExceptT $ do - root <- liftIO $ Codebase.getRootBranch codebase - let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root)) - loadTypeOfTerm = Codebase.getTypeOfTerm codebase + (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 parseNames 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/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index e97a93ce8c6..b38c4edc99c 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -5,7 +5,9 @@ module Unison.Codebase.Path Path' (..), Absolute (..), pattern AbsolutePath', + absPath_, Relative (..), + relPath_, pattern RelativePath', Resolve (..), pattern Empty, @@ -30,6 +32,8 @@ module Unison.Codebase.Path prefixNameIfRel, unprefixName, HQSplit, + HQSplitAbsolute, + AbsSplit, Split, Split', HQSplit', @@ -58,6 +62,8 @@ module Unison.Codebase.Path toName', toText, toText', + absToText, + relToText, unsplit, unsplit', unsplitAbsolute, @@ -113,12 +119,19 @@ instance GHC.IsList Path where toList (Path segs) = Foldable.toList segs fromList = Path . Seq.fromList --- | A namespace path that starts from the root. +-- | An absolute from the current project root newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) +absPath_ :: Lens' Absolute Path +absPath_ = lens unabsolute (\_ new -> Absolute new) + -- | A namespace path that doesn’t necessarily start from the root. +-- Typically refers to a path from the current namespace. newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord) +relPath_ :: Lens' Relative Path +relPath_ = lens unrelative (\_ new -> Relative new) + -- | A namespace that may be either absolute or relative, This is the most general type that should be used. newtype Path' = Path' {unPath' :: Either Absolute Relative} deriving (Eq, Ord) @@ -148,14 +161,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 @@ -175,6 +188,8 @@ nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative) nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a +type AbsSplit = (Absolute, NameSegment) + type Split = (Path, NameSegment) type HQSplit = (Path, HQ'.HQSegment) @@ -368,11 +383,29 @@ 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 = 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 @@ -509,6 +542,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 new file mode 100644 index 00000000000..ffb7b085053 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -0,0 +1,136 @@ +module Unison.Codebase.ProjectPath + ( ProjectPathG (..), + ProjectPathIds, + ProjectPathNames, + ProjectPath, + fromProjectAndBranch, + projectBranchRoot, + toRoot, + absPath_, + path_, + path, + toProjectAndBranch, + projectAndBranch_, + toText, + toIds, + toNames, + projectPathParser, + parseProjectPath, + + -- * Re-exports, this also helps with using dot-notation + ProjectAndBranch (..), + Project (..), + ProjectBranch (..), + ) +where + +import Control.Lens hiding (from) +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, + branch :: branch, + absPath :: Path.Absolute + } + deriving stock (Eq, Ord, Show, Generic) + +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 +projectBranchRoot (ProjectAndBranch proj branch) = ProjectPath proj branch Path.absoluteEmpty + +-- | Discard any path within the project and get the project's root +toRoot :: ProjectPath -> ProjectPath +toRoot (ProjectPath proj branch _) = ProjectPath proj branch Path.absoluteEmpty + +fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath +fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path + +-- | Project a project context into a project path of just IDs +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 +toNames :: ProjectPath -> ProjectPathNames +toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path + +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 + +instance Bifoldable ProjectPathG where + bifoldMap f g (ProjectPath p b _) = f p <> g b + +instance Bitraversable ProjectPathG where + bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure 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 absPath set + where + 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_ + +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 + 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/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs b/parser-typechecker/src/Unison/Codebase/RootBranchCache.hs deleted file mode 100644 index ab092c8031e..00000000000 --- 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/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 7e8b40e75bd..2872ec53d2b 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -10,6 +10,7 @@ where import Data.Set qualified as Set import Data.Text qualified as Text +import U.Codebase.HashTags (CausalHash (unCausalHash)) import U.Util.Base32Hex qualified as Base32Hex import Unison.Hash qualified as Hash import Unison.Prelude @@ -24,9 +25,9 @@ toString = Text.unpack . toText toHash :: (Coercible Hash.Hash h) => ShortCausalHash -> Maybe h toHash = fmap coerce . Hash.fromBase32HexText . toText -fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash +fromHash :: Int -> CausalHash -> ShortCausalHash fromHash len = - ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce + ShortCausalHash . Text.take len . Hash.toBase32HexText . unCausalHash -- | This allows a full hash to be preserved as a `ShortCausalHash`. -- @@ -47,3 +48,6 @@ fromText _ = Nothing instance Show ShortCausalHash where show (ShortCausalHash h) = '#' : Text.unpack h + +instance From ShortCausalHash Text where + from = toText diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f21330e24..045a310199b 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,13 +34,12 @@ 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 +import Unison.Codebase.SqliteCodebase.ProjectRootCache qualified as ProjectRootCache import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.Codebase.Type qualified as C @@ -62,6 +58,8 @@ import Unison.Type (Type) import Unison.Util.Timing (time) import Unison.WatchKind qualified as UF import UnliftIO (UnliftIO (..), finally) +import UnliftIO qualified as UnliftIO +import UnliftIO.Concurrent qualified as UnliftIO import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.STM @@ -106,8 +104,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 - void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty + CodebaseOps.createSchema onCreate sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case @@ -136,7 +133,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? @@ -167,8 +164,8 @@ 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 + projectRootCache <- ProjectRootCache.newProjectRootCache 5 {- Cache the last n project roots for quick switching. -} getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer @@ -238,37 +235,6 @@ 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)) - - 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)) @@ -280,6 +246,16 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action withRunInIO \runInIO -> runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) + preloadProjectRoot :: CausalHash -> m () + preloadProjectRoot h = do + void . UnliftIO.forkIO $ void $ do + getBranchForHash h >>= \case + Nothing -> pure () + Just b -> do + ProjectRootCache.stashBranch projectRootCache b + UnliftIO.evaluate b + pure () + syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m () syncFromDirectory srcRoot b = withConnection (debugName ++ ".sync.src") srcRoot \srcConn -> @@ -334,8 +310,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putTypeDeclaration, putTypeDeclarationComponent, getTermComponentWithTypes, - getRootBranch, - putRootBranch, getBranchForHash, putBranch, syncFromDirectory, @@ -347,7 +321,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action filterTermsByReferentIdHavingTypeImpl, termReferentsByPrefix = referentsByPrefix, withConnection = withConn, - withConnectionIO = withConnection debugName root + withConnectionIO = withConnection debugName root, + preloadProjectRoot } Right <$> action codebase where diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 68dc7c0a9fa..5244facbf80 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) @@ -30,27 +31,28 @@ 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 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.Transaction ()) -migrations getDeclType termBuffer declBuffer rootCodebasePath = + Map SchemaVersion (Sqlite.Connection -> IO ()) +migrations regionVar 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: -- @@ -67,30 +69,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 *> runIntegrityChecks regionVar)), -- 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 *> runIntegrityChecks regionVar)), + (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 16 Q.cdToProjectRoot, + (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 @@ -140,7 +146,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 @@ -149,11 +155,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, @@ -163,48 +168,29 @@ 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 + 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) @@ -224,3 +210,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.") 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 00000000000..ce34d514345 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +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 +import U.Codebase.Branch.Type qualified as V2Branch +import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Sqlite.DbId (CausalHashId, 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.Branch qualified as Branch +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.SqliteCodebase.Branch.Cache qualified as BranchCache +import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps +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 + +-- | 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 the new project reflog table +-- * Adds the project-branch head as a causal-hash-id column on the project-branch table, and populates it from all the projects in the project root. +-- * Makes a new legacy project from the existing root branch (minus .__projects) +-- * Adds a new scratch/main project +-- * Adds a currentProjectPath table to replace the most-recent-path functionality. +-- +-- 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 + Q.addProjectBranchReflogTable + Debug.debugLogM Debug.Migration "Adding causal hashes to project branches table." + addCausalHashesToProjectBranches + Debug.debugLogM Debug.Migration "Making legacy project from loose code." + makeLegacyProjectFromLooseCode + Debug.debugLogM Debug.Migration "Adding scratch project" + scratchMain <- + Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case + Just pb -> pure pb + Nothing -> 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 = 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) + +data 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]] + | MissingRootBranch + deriving stock (Show) + deriving anyclass (Exception) + +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| +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 <- expectNamespaceRoot + rootCh <- Q.expectCausalHash rootCausalHashId + projectsRoot <- Codebase.getShallowCausalAtPathFromRootHash rootCh (Path.singleton $ projectsNameSegment) >>= 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 + Debug.debugM Debug.Migration "Migrating project" projectId + projectsBranch <- V2Causal.value projectsCausal + case (Map.lookup branchesNameSegment $ 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 + Debug.debugM Debug.Migration "Migrating project branch" projectBranchId + 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) + |] + + 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. + -- 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 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 + +makeLegacyProjectFromLooseCode :: Sqlite.Transaction () +makeLegacyProjectFromLooseCode = do + rootChId <- + Sqlite.queryOneCol @CausalHashId + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + rootCh <- Q.expectCausalHash rootChId + branchCache <- Sqlite.unsafeIO BranchCache.newBranchCache + getDeclType <- Sqlite.unsafeIO $ CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType + rootBranch <- + CodebaseOps.getBranchForHash branchCache getDeclType rootCh `whenNothingM` do + Sqlite.unsafeIO . UnliftIO.throwIO $ MissingRootBranch + -- Remove the hidden projects root if one existed. + let rootWithoutProjects = rootBranch & over (Branch.head_ . Branch.children) (Map.delete projectsNameSegment) + CodebaseOps.putBranch rootWithoutProjects + let legacyBranchRootHash = Branch.headHash rootWithoutProjects + legacyBranchRootHashId <- Q.expectCausalHashIdByCausalHash legacyBranchRootHash + + let findLegacyName :: Maybe Int -> Sqlite.Transaction ProjectName + findLegacyName mayN = do + let tryProjName = case mayN of + Nothing -> UnsafeProjectName "legacy" + Just n -> UnsafeProjectName $ "legacy" <> Text.pack (show n) + Q.loadProjectBranchByNames tryProjName legacyBranchName >>= \case + Nothing -> pure tryProjName + Just _ -> findLegacyName . Just $ maybe 1 succ mayN + legacyProjName <- findLegacyName Nothing + void $ Ops.insertProjectAndBranch legacyProjName legacyBranchName legacyBranchRootHashId + pure () + where + legacyBranchName = UnsafeProjectBranchName "main" + +expectNamespaceRoot :: Sqlite.Transaction CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + +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))) + +projectsNameSegment :: NameSegment +projectsNameSegment = NameSegment.unsafeParseText "__projects" + +branchesNameSegment :: NameSegment +branchesNameSegment = NameSegment.unsafeParseText "branches" diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 475e19d3388..76e7a671216 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 @@ -103,7 +104,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." log "Updating Namespace Root..." - rootCausalHashId <- Q.expectNamespaceRoot + rootCausalHashId <- expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch watches <- @@ -115,7 +116,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId log "Updating Namespace Root..." - Q.setNamespaceRoot newRootCausalHashId + setNamespaceRoot newRootCausalHashId log "Rewriting old object IDs..." ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do Q.recordObjectRehash oldObjId newObjId @@ -149,6 +150,23 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do allDone = lift $ log $ "\nFinished migrating, initiating cleanup." in Sync.Progress {need, done, error = errorHandler, allDone} +expectNamespaceRoot :: Sqlite.Transaction CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + +setNamespaceRoot :: CausalHashId -> Sqlite.Transaction () +setNamespaceRoot id = + Sqlite.queryOneCol [Sqlite.sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case + False -> Sqlite.execute [Sqlite.sql| INSERT INTO namespace_root VALUES (:id) |] + True -> Sqlite.execute [Sqlite.sql| UPDATE namespace_root SET causal_id = :id |] + log :: String -> Sqlite.Transaction () log = Sqlite.unsafeIO . putStrLn diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs index 57dbdea27b4..b68ee1541e6 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs @@ -81,7 +81,7 @@ numMigrated = migrateSchema3To4 :: Sqlite.Transaction () migrateSchema3To4 = do Q.expectSchemaVersion 3 - rootCausalHashId <- Q.expectNamespaceRoot + rootCausalHashId <- expectNamespaceRoot totalCausals <- causalCount migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId] let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState @@ -98,6 +98,17 @@ migrateSchema3To4 = do SELECT count(*) FROM causal; |] +expectNamespaceRoot :: Sqlite.Transaction DB.CausalHashId +expectNamespaceRoot = + Sqlite.queryOneCol loadNamespaceRootSql + +loadNamespaceRootSql :: Sqlite.Sql +loadNamespaceRootSql = + [Sqlite.sql| + SELECT causal_id + FROM namespace_root + |] + migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId migrationProgress totalCausals = Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone} diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs index 9395c3919db..2fa0205484c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) where +import Data.Bitraversable import Data.Text qualified as Text import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import System.FilePath (()) import U.Codebase.HashTags (CausalHash (CausalHash)) import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Operations qualified as Ops import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase (CodebasePath) import Unison.Hash qualified as Hash @@ -30,12 +33,21 @@ migrateCurrentReflog codebasePath = do -- so we check first to avoid triggering a bad foreign key constraint. haveFrom <- isJust <$> Q.loadCausalByCausalHash (Reflog.fromRootCausalHash oldEntry) haveTo <- isJust <$> Q.loadCausalByCausalHash (Reflog.toRootCausalHash oldEntry) - when (haveFrom && haveTo) $ Ops.appendReflog oldEntry + when (haveFrom && haveTo) $ appendReflog oldEntry Sqlite.unsafeIO . putStrLn $ "I migrated old reflog entries from " <> reflogPath <> " into the codebase; you may delete that file now if you like." where reflogPath :: FilePath reflogPath = codebasePath "reflog" + appendReflog :: Reflog.Entry CausalHash Text -> Sqlite.Transaction () + appendReflog entry = do + dbEntry <- (bitraverse Q.saveCausalHash pure) entry + Sqlite.execute + [Sqlite.sql| + INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason) + VALUES (@dbEntry, @, @, @) + |] + oldReflogEntries :: CodebasePath -> UTCTime -> IO [Reflog.Entry CausalHash Text] oldReflogEntries reflogPath now = ( do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 98a6db75eff..050d7f5fdaf 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. @@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import Data.Map qualified as Map import Data.Maybe (fromJust) import Data.Set qualified as Set +import Data.UUID.V4 qualified as UUID import U.Codebase.Branch qualified as V2Branch import U.Codebase.Branch.Diff (TreeDiff (TreeDiff)) import U.Codebase.Branch.Diff qualified as BranchDiff @@ -30,11 +33,14 @@ import U.Codebase.Sqlite.NamedRef qualified as S import U.Codebase.Sqlite.ObjectType qualified as OT import U.Codebase.Sqlite.Operations (NamesInPerspective (..)) import U.Codebase.Sqlite.Operations qualified as Ops +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.Project qualified as Project import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) 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 @@ -43,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) @@ -74,6 +80,35 @@ 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 + Q.addCurrentProjectPathTable + Q.addProjectBranchReflogTable + Q.addProjectBranchCausalHashIdColumn + (_, emptyCausalHashId) <- emptyCausalHash + (_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId + Q.setCurrentProjectPath projectId branchId [] + where + scratchProjectName = UnsafeProjectName "scratch" + scratchBranchName = UnsafeProjectBranchName "main" + currentSchemaVersion = Q.currentSchemaVersion + insertSchemaVersionSql = + [Sqlite.sql| + INSERT INTO schema_version (version) + VALUES (:currentSchemaVersion) + |] + ------------------------------------------------------------------------------------------------------------------------ -- Buffer entry @@ -382,25 +417,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 - --- | 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 :: @@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do conn <- Sqlite.unsafeGetConnection Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x) -insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction () -insertProjectAndBranch projectId projectName branchId branchName = do - Q.insertProject projectId projectName +-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project. +insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch) +insertProjectAndBranch projectName branchName chId = do + projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do + projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom) + Q.insertProject projectId projectName + pure projectId + branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom) + let projectBranch = + ProjectBranch + { projectId, + branchId, + name = branchName, + parentBranchId = Nothing + } Q.insertProjectBranch - ProjectBranch - { projectId, - branchId, - name = branchName, - parentBranchId = Nothing - } + "Project Created" + chId + 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) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/ProjectRootCache.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/ProjectRootCache.hs new file mode 100644 index 00000000000..9dd6f604aae --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/ProjectRootCache.hs @@ -0,0 +1,28 @@ +-- | Simple cache which just keeps the last n relevant project branches in memory. +-- The Branch Cache handles all the lookups of the actual branch data by hash, this cache serves only to keep the last +-- n accessed branches in memory so they don't get garbage collected. See the Branch Cache for more context. +-- +-- This speeds up switching back and forth between project branches, and also serves to keep the current project branch +-- in memory so it won't be cleaned up by the Branch Cache, since the Branch Cache only keeps +-- a weak reference to the current branch and we no longer keep the actual branch in LoopState. +module Unison.Codebase.SqliteCodebase.ProjectRootCache + ( newProjectRootCache, + stashBranch, + ) +where + +import Control.Concurrent.STM +import Unison.Codebase.Branch +import Unison.Prelude + +data ProjectRootCache m = ProjectRootCache {capacity :: Int, cached :: TVar [Branch m]} + +newProjectRootCache :: (MonadIO m) => Int -> m (ProjectRootCache n) +newProjectRootCache capacity = do + var <- liftIO $ newTVarIO [] + pure (ProjectRootCache capacity var) + +stashBranch :: (MonadIO n) => ProjectRootCache m -> Branch m -> n () +stashBranch ProjectRootCache {capacity, cached} branch = do + liftIO . atomically $ do + modifyTVar cached $ \branches -> take capacity (branch : filter (/= branch) branches) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 0b803dd73a7..f89fe8381ca 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -55,13 +55,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. @@ -87,7 +80,12 @@ data Codebase m v a = Codebase -- | Acquire a new connection to the same underlying database file this codebase object connects to. withConnection :: forall x. (Sqlite.Connection -> m x) -> m x, -- | Acquire a new connection to the same underlying database file this codebase object connects to. - withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x + withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x, + -- | This optimization allows us to pre-fetch a branch from SQLite into the branch cache when we know we'll need it + -- soon, but not immediately. E.g. the user has switched a branch, but hasn't run any commands on it yet. + -- + -- This combinator returns immediately, but warms the cache in the background with the desired branch. + preloadProjectRoot :: CausalHash -> m () } -- | Whether a codebase is local or remote. diff --git a/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs b/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs index d2e9aa5bcfb..649a629cdcf 100644 --- a/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs @@ -10,6 +10,7 @@ import U.Codebase.Branch qualified as Codebase.Branch import U.Codebase.Decl qualified as Codebase.Decl import U.Codebase.Reference qualified as Codebase.Reference import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite @@ -21,8 +22,8 @@ import Witherable (witherM) -- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed -- by a cache. loadUniqueTypeGuid :: - ([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) -> - [NameSegment] -> + (ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) -> + ProjectPath -> NameSegment -> Sqlite.Transaction (Maybe Text) loadUniqueTypeGuid loadNamespaceAtPath path name = diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs deleted file mode 100644 index 2848a07564b..00000000000 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ /dev/null @@ -1,158 +0,0 @@ -module Unison.Project.Util - ( projectPath, - projectBranchesPath, - projectBranchPath, - projectBranchSegment, - projectPathPrism, - projectBranchPathPrism, - projectContextFromPath, - pattern UUIDNameSegment, - ProjectContext (..), - 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.Internal (NameSegment (NameSegment)) -import Unison.NameSegment.Internal 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 - --- | 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) - where - ProjectsNameSegment = projectsNameSegment - -pattern BranchesNameSegment :: NameSegment -pattern BranchesNameSegment <- - ((== branchesNameSegment) -> True) - where - BranchesNameSegment = branchesNameSegment - -projectsNameSegment :: NameSegment -projectsNameSegment = NameSegment "__projects" - -branchesNameSegment :: NameSegment -branchesNameSegment = NameSegment "branches" diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 61b4ad037b2..43f2b176348 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -60,8 +60,8 @@ library Unison.Codebase.Patch Unison.Codebase.Path Unison.Codebase.Path.Parse + Unison.Codebase.ProjectPath Unison.Codebase.PushBehavior - Unison.Codebase.RootBranchCache Unison.Codebase.Runtime Unison.Codebase.Serialization Unison.Codebase.ShortCausalHash @@ -72,6 +72,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 @@ -80,6 +81,7 @@ library Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 Unison.Codebase.SqliteCodebase.Operations Unison.Codebase.SqliteCodebase.Paths + Unison.Codebase.SqliteCodebase.ProjectRootCache Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.TermEdit Unison.Codebase.TermEdit.Typing @@ -131,7 +133,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-integration/integration-tests/IntegrationTests/transcript.md b/unison-cli-integration/integration-tests/IntegrationTests/transcript.md index c8b10ea2680..2db0994f0e4 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/transcript.md +++ b/unison-cli-integration/integration-tests/IntegrationTests/transcript.md @@ -1,18 +1,13 @@ # Integration test: transcript ```ucm:hide -.> builtins.mergeio -.> load ./unison-src/transcripts-using-base/base.u -``` - -```ucm:hide -.> builtins.mergeio -.> load ./unison-src/transcripts-using-base/base.u -.> add +scratch/main> builtins.mergeio lib.builtins +scratch/main> load ./unison-src/transcripts-using-base/base.u +scratch/main> add ``` ```unison -use .builtin +use lib.builtins unique type MyBool = MyTrue | MyFalse @@ -39,6 +34,6 @@ main = do ``` ```ucm -.> add -.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main +scratch/main> add +scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main ``` diff --git a/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md b/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md index 2cf4f325cc3..92a636f2c10 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md +++ b/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md @@ -1,7 +1,7 @@ # Integration test: transcript ``` unison -use .builtin +use lib.builtins unique type MyBool = MyTrue | MyFalse @@ -44,7 +44,7 @@ main = do ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -53,6 +53,6 @@ main = do main : '{IO, Exception} () resume : Request {g, Break} x -> x -.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main +scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main ``` diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 5e7032942a8..0b354f9f570 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -52,14 +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 @@ -68,7 +73,7 @@ import Unison.Util.Pretty (Width (..)) -- | Valid ways to provide source code to the run command data RunSource = RunFromPipe (HashQualified Name) - | RunFromSymbol (HashQualified Name) + | RunFromSymbol ProjectPathNames | RunFromFile FilePath (HashQualified Name) | RunCompiled FilePath deriving (Show, Eq) @@ -102,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 @@ -357,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 @@ -374,9 +379,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 = @@ -422,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 = @@ -469,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/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 73783e1a0f3..398982889c3 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, + getProjectPathIds, -- * Lifting IO actions ioE, @@ -33,6 +34,7 @@ module Unison.Cli.Monad -- * Changing the current directory cd, popd, + switchProject, -- * Communicating output to the user respond, @@ -46,38 +48,42 @@ module Unison.Cli.Monad runTransaction, runTransactionWithRollback, + -- * Internal + setMostRecentProjectPath, + -- * Misc types LoadSourceResult (..), ) 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 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) import Unison.Codebase qualified as Codebase -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 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 @@ -88,7 +94,6 @@ import Unison.Syntax.Parser qualified as Parser import Unison.Term (Term) import Unison.Type (Type) import Unison.UnisonFile qualified as UF -import UnliftIO.STM import Unsafe.Coerce (unsafeCoerce) -- | The main command-line app monad. @@ -170,7 +175,10 @@ data Env = Env sandboxedRuntime :: Runtime Symbol, nativeRuntime :: Runtime Symbol, serverBaseUrl :: Maybe Server.BaseUrl, - ucmVersion :: UCMVersion + ucmVersion :: UCMVersion, + -- | Whether we're running in a transcript test or not. + -- Avoid using this except when absolutely necessary. + isTranscriptTest :: Bool } deriving stock (Generic) @@ -178,10 +186,8 @@ 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, + { -- the current position in the codebase, with the head being the most recent lcoation. + projectPathStack :: List.NonEmpty PP.ProjectPathIds, -- TBD -- , _activeEdits :: Set Branch.EditGuid @@ -206,26 +212,11 @@ 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 :: PP.ProjectPathIds -> LoopState +loopState0 p = do LoopState - { root = b, - lastSavedRootHash = lastSavedRootHash, - currentPathStack = pure p, + { projectPathStack = pure p, latestFile = Nothing, latestTypecheckedFile = Nothing, lastInput = Nothing, @@ -387,11 +378,25 @@ time label action = ms = ns / 1_000_000 s = ns / 1_000_000_000 +getProjectPathIds :: Cli PP.ProjectPathIds +getProjectPathIds = do + NonEmpty.head <$> use #projectPathStack + cd :: Path.Absolute -> Cli () cd path = do - setMostRecentNamespace path - State.modify' \state -> - state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)} + pp <- getProjectPathIds + let newPP = pp & PP.absPath_ .~ path + setMostRecentProjectPath newPP + #projectPathStack %= NonEmpty.cons newPP + +switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () +switchProject pab@(ProjectAndBranch projectId branchId) = do + Env {codebase} <- ask + let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty + #projectPathStack %= NonEmpty.cons newPP + runTransaction $ do Q.setMostRecentBranch projectId branchId + setMostRecentProjectPath newPP + liftIO $ Codebase.preloadProjectBranch codebase pab -- | Pop the latest path off the stack, if it's not the only path in the stack. -- @@ -399,16 +404,16 @@ cd path = do popd :: Cli Bool popd = do state <- State.get - case List.NonEmpty.uncons (currentPathStack state) of + case List.NonEmpty.uncons (projectPathStack state) of (_, Nothing) -> pure False (_, Just paths) -> do - setMostRecentNamespace (List.NonEmpty.head paths) - State.put state {currentPathStack = paths} + setMostRecentProjectPath (List.NonEmpty.head paths) + State.put state {projectPathStack = paths} pure True -setMostRecentNamespace :: Path.Absolute -> Cli () -setMostRecentNamespace = - runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute +setMostRecentProjectPath :: PP.ProjectPathIds -> Cli () +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 a397a3b0935..25034b4b45e 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -6,10 +6,18 @@ module Unison.Cli.MonadUtils -- * Paths getCurrentPath, + getCurrentProjectName, + getCurrentProjectBranchName, + getCurrentProjectPath, resolvePath, resolvePath', + resolvePath'ToAbsolute, resolveSplit', + -- * Project and branch resolution + getCurrentProjectAndBranch, + getCurrentProjectBranch, + -- * Branches -- ** Resolving branch identifiers @@ -20,18 +28,15 @@ module Unison.Cli.MonadUtils resolveShortCausalHash, -- ** Getting/setting branches - getRootBranch, - setRootBranch, - modifyRootBranch, - getRootBranch0, + getCurrentProjectRoot, + getCurrentProjectRoot0, getCurrentBranch, getCurrentBranch0, - getBranchAt, - getBranch0At, - getLastSavedRootHash, - setLastSavedRootHash, - getMaybeBranchAt, - getMaybeBranch0At, + getProjectBranchRoot, + getBranchFromProjectPath, + getBranch0FromProjectPath, + getMaybeBranchFromProjectPath, + getMaybeBranch0FromProjectPath, expectBranchAtPath, expectBranchAtPath', expectBranch0AtPath, @@ -43,13 +48,10 @@ module Unison.Cli.MonadUtils stepAt', stepAt, stepAtM, - stepAtNoSync', - stepAtNoSync, stepManyAt, - stepManyAtMNoSync, - stepManyAtNoSync, - syncRoot, - updateRoot, + stepManyAtM, + updateProjectBranchRoot, + updateProjectBranchRoot_, updateAtM, updateAt, updateAndStepAt, @@ -91,6 +93,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 @@ -103,6 +108,8 @@ 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 import Unison.HashQualified qualified as HQ @@ -112,6 +119,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Reference (TypeReference) import Unison.Referent (Referent) import Unison.Sqlite qualified as Sqlite @@ -123,7 +131,6 @@ import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UFN import Unison.Util.Set qualified as Set import Unison.Var qualified as Var -import UnliftIO.STM ------------------------------------------------------------------------------------------------------------------------ -- .unisonConfig things @@ -137,25 +144,50 @@ getConfig key = do ------------------------------------------------------------------------------------------------------------------------ -- Getting paths, path resolution, etc. --- | Get the current path. +getCurrentProjectPath :: Cli PP.ProjectPath +getCurrentProjectPath = do + ppIds <- Cli.getProjectPathIds + Cli.runTransaction $ Codebase.resolveProjectPathIds ppIds + +getCurrentProjectAndBranch :: Cli (ProjectAndBranch Project ProjectBranch) +getCurrentProjectAndBranch = do + PP.toProjectAndBranch <$> getCurrentProjectPath + +getCurrentProjectBranch :: Cli ProjectBranch +getCurrentProjectBranch = do + view #branch <$> getCurrentProjectPath + +-- | Get the current path relative to the current project. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - use #currentPath + view PP.absPath_ <$> getCurrentProjectPath + +getCurrentProjectName :: Cli ProjectName +getCurrentProjectName = do + view (#project . #name) <$> getCurrentProjectPath + +getCurrentProjectBranchName :: Cli ProjectBranchName +getCurrentProjectBranchName = do + 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' + +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 (Path.Absolute, a) +resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a) resolveSplit' = traverseOf _1 resolvePath' @@ -166,23 +198,27 @@ 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 path -> getBranchAt path + 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 :: (forall void. Output.Output -> Sqlite.Transaction void) -> + ProjectAndBranch Project ProjectBranch -> Input.AbsBranchId -> Sqlite.Transaction (V2.Branch Sqlite.Transaction) -resolveAbsBranchIdV2 rollback = \case - Left shortHash -> do +resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case + Input.BranchAtSCH 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 + 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). @@ -194,7 +230,7 @@ resolveBranchId branchId = do -- | Resolve a @BranchId@ to an @AbsBranchId@. resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId resolveBranchIdToAbsBranchId = - traverseOf _Right 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) @@ -222,77 +258,54 @@ resolveShortCausalHashToCausalHash rollback shortHash = do -- Getting/Setting branches -- | Get the root branch. -getRootBranch :: Cli (Branch IO) -getRootBranch = do - use #root >>= atomically . readTMVar +getCurrentProjectRoot :: Cli (Branch IO) +getCurrentProjectRoot = do + Cli.Env {codebase} <- ask + ProjectAndBranch proj branch <- getCurrentProjectAndBranch + liftIO $ Codebase.expectProjectBranchRoot codebase proj.projectId branch.branchId -- | Get the root branch0. -getRootBranch0 :: Cli (Branch0 IO) -getRootBranch0 = - Branch.head <$> getRootBranch - --- | 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) - --- | 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 - atomically do - root <- takeTMVar rootVar - let !newRoot = f root - putTMVar rootVar newRoot - pure newRoot +getCurrentProjectRoot0 :: Cli (Branch0 IO) +getCurrentProjectRoot0 = + Branch.head <$> getCurrentProjectRoot -- | Get the current branch. getCurrentBranch :: Cli (Branch IO) getCurrentBranch = do - path <- getCurrentPath Cli.Env {codebase} <- ask - liftIO $ Codebase.getBranchAtPath codebase path + pp <- getCurrentProjectPath + fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp) -- | Get the current branch0. 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 = - getMaybeBranchAt path <&> fromMaybe Branch.empty +-- | Get the branch at an absolute path from the project root. +getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO) +getBranchFromProjectPath pp = + getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty -- | Get the branch0 at an absolute path. -getBranch0At :: Path.Absolute -> Cli (Branch0 IO) -getBranch0At path = - Branch.head <$> getBranchAt path +getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO) +getBranch0FromProjectPath pp = + Branch.head <$> getBranchFromProjectPath pp + +getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO) +getProjectBranchRoot projectBranch = do + Cli.Env {codebase} <- ask + liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId -- | Get the maybe-branch at an absolute path. -getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO)) -getMaybeBranchAt path = do - rootBranch <- getRootBranch - pure (Branch.getAt (Path.unabsolute path) rootBranch) +getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO)) +getMaybeBranchFromProjectPath pp = do + Cli.Env {codebase} <- ask + liftIO $ Codebase.getBranchAtProjectPath codebase pp -- | Get the maybe-branch0 at an absolute path. -getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO)) -getMaybeBranch0At path = - fmap Branch.head <$> getMaybeBranchAt 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) @@ -303,7 +316,7 @@ expectBranchAtPath = expectBranchAtPath' :: Path' -> Cli (Branch IO) expectBranchAtPath' path0 = do path <- resolvePath' path0 - getMaybeBranchAt 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) @@ -329,167 +342,138 @@ 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 +makeActionsUnabsolute :: (Functor f) => f (Path.Absolute, x) -> f (Path, x) +makeActionsUnabsolute = fmap (first Path.unabsolute) + stepAt :: Text -> - (Path, Branch0 IO -> Branch0 IO) -> + (ProjectPath, Branch0 IO -> Branch0 IO) -> Cli () -stepAt cause = stepManyAt @[] cause . pure +stepAt cause (pp, action) = stepManyAt pp.branch cause [(pp.absPath, action)] stepAt' :: Text -> - (Path, Branch0 IO -> Cli (Branch0 IO)) -> - Cli Bool -stepAt' cause = stepManyAt' @[] cause . pure - -stepAtNoSync' :: - (Path, Branch0 IO -> Cli (Branch0 IO)) -> + (ProjectPath, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool -stepAtNoSync' = stepManyAtNoSync' @[] . pure - -stepAtNoSync :: - (Path, Branch0 IO -> Branch0 IO) -> - Cli () -stepAtNoSync = stepManyAtNoSync @[] . pure +stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)] stepAtM :: Text -> - (Path, Branch0 IO -> IO (Branch0 IO)) -> + (ProjectPath, Branch0 IO -> IO (Branch0 IO)) -> Cli () -stepAtM cause = stepManyAtM @[] cause . pure +stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)] stepManyAt :: - (Foldable f) => + ProjectBranch -> Text -> - f (Path, Branch0 IO -> Branch0 IO) -> + [(Path.Absolute, Branch0 IO -> Branch0 IO)] -> Cli () -stepManyAt reason actions = do - stepManyAtNoSync actions - syncRoot reason +stepManyAt pb reason actions = do + updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions) stepManyAt' :: - (Foldable f) => + ProjectBranch -> Text -> - 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)) -> + [(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] -> Cli Bool -stepManyAtNoSync' actions = do - origRoot <- getRootBranch - newRoot <- Branch.stepManyAtM actions origRoot - setRootBranch newRoot - pure (origRoot /= newRoot) +stepManyAt' pb reason actions = do + origRoot <- getProjectBranchRoot pb + newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot + didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot)) + pure didChange -- 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) => + ProjectBranch -> 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)) -> + [(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] -> Cli () -stepManyAtMNoSync actions = do - oldRoot <- getRootBranch - newRoot <- liftIO (Branch.stepManyAtM actions oldRoot) - setRootBranch newRoot - --- | Sync the in-memory root branch. -syncRoot :: Text -> Cli () -syncRoot description = do - rootBranch <- getRootBranch - updateRoot rootBranch description +stepManyAtM pb reason actions = 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 :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool -updateAtM reason (Path.Absolute p) f = do - b <- getRootBranch - b' <- Branch.modifyAtM p f b - updateRoot b' reason - pure $ b /= b' +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 :: Text -> - Path.Absolute -> + ProjectPath -> (Branch IO -> Branch IO) -> Cli Bool -updateAt reason p f = do - updateAtM reason p (pure . f) +updateAt reason pp f = do + updateAtM reason pp (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 - root <- - (Branch.stepManyAt steps) - . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates) - <$> getRootBranch - updateRoot root reason - -updateRoot :: Branch IO -> Text -> Cli () -updateRoot new reason = - Cli.time "updateRoot" 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 +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 (first Path.unabsolute <$> steps)) + updateProjectBranchRoot_ projectBranch reason f + +updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r +updateProjectBranchRoot projectBranch reason f = do + Cli.Env {codebase} <- ask + Cli.time "updateProjectBranchRoot" do + old <- getProjectBranchRoot projectBranch + (new, result) <- f old + when (old /= new) do + liftIO $ Codebase.putBranch codebase new + Cli.runTransaction $ do + -- TODO: If we transactionally check that the project branch hasn't changed while we were computing the new + -- branch, and if it has, abort the transaction and return an error, then we can + -- remove the single UCM per codebase restriction. + causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new) + Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId + pure result + +updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () +updateProjectBranchRoot_ projectBranch reason f = do + updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ())) ------------------------------------------------------------------------------------------------------------------------ -- Getting terms -getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent) -getTermsAt path = do - rootBranch0 <- getRootBranch0 - pure (BranchUtil.getTerm (first Path.unabsolute 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 <- getRootBranch0 - pure (BranchUtil.getType (first Path.unabsolute 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 @@ -507,8 +491,8 @@ getPatchAt path = -- | Get the patch at a path. getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch) getMaybePatchAt path0 = do - (path, name) <- resolveSplit' path0 - branch <- getBranch0At path + (pp, name) <- resolveSplit' path0 + branch <- getBranch0FromProjectPath pp liftIO (Branch.getMaybePatch name branch) ------------------------------------------------------------------------------------------------------------------------ diff --git a/unison-cli/src/Unison/Cli/NamesUtils.hs b/unison-cli/src/Unison/Cli/NamesUtils.hs index 8e360204593..889e055bdf5 100644 --- a/unison-cli/src/Unison/Cli/NamesUtils.hs +++ b/unison-cli/src/Unison/Cli/NamesUtils.hs @@ -1,15 +1,27 @@ -- | Utilities that have to do with constructing names objects. module Unison.Cli.NamesUtils ( currentNames, + currentProjectRootNames, + projectBranchNames, ) where +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) import Unison.Cli.Monad (Cli) -import Unison.Cli.MonadUtils (getCurrentBranch0) +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) -- | Produce a 'Names' object which contains names for the current branch. currentNames :: Cli Names currentNames = do - Branch.toNames <$> getCurrentBranch0 + Branch.toNames <$> Cli.getCurrentBranch0 + +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/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index a336d860d20..96ec98d48fc 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -5,7 +5,8 @@ module Unison.Cli.Pretty ( displayBranchHash, prettyAbsolute, - prettyAbsoluteStripProject, + prettyProjectPath, + prettyBranchRelativePath, prettyBase32Hex#, prettyBase32Hex, prettyBranchId, @@ -33,7 +34,6 @@ module Unison.Cli.Pretty prettyRepoInfo, prettySCH, prettySemver, - prettyShareLink, prettySharePath, prettyShareURI, prettySlashProjectBranchName, @@ -57,12 +57,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 @@ -70,23 +68,20 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Util.Base32Hex (Base32Hex) import U.Util.Base32Hex qualified as Base32Hex import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..)) -import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), - ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - shareUserHandleToText, ) 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 +import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.Core.Project (ProjectBranchName) import Unison.DataDeclaration qualified as DD import Unison.Debug qualified as Debug @@ -126,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 @@ -150,7 +146,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 +157,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 @@ -194,16 +182,17 @@ 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)) 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 @@ -211,6 +200,13 @@ prettyRelative = P.blue . P.shown prettyAbsolute :: Path.Absolute -> Pretty prettyAbsolute = P.blue . P.shown +prettyProjectPath :: PP.ProjectPath -> Pretty +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) @@ -271,6 +267,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 @@ -343,7 +342,7 @@ prettyTypeName ppe r = prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case WhichBranchEmptyHash hash -> P.shown hash - WhichBranchEmptyPath path -> prettyPath' path + WhichBranchEmptyPath pp -> prettyProjectPath pp -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef displayBranchHash :: CausalHash -> Text @@ -389,15 +388,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/PrettyPrintUtils.hs b/unison-cli/src/Unison/Cli/PrettyPrintUtils.hs index 17abdd49c5c..8ee18756f4a 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 diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index f1ae7dd7d13..4f196c1b613 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -1,21 +1,10 @@ -- | 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, + resolveProjectBranch, + resolveProjectBranchInProject, -- * Name hydration hydrateNames, @@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils -- * Loading local project info expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, - expectProjectAndBranchByTheseNames, getProjectAndBranchByNames, - expectLooseCodeOrProjectBranch, + expectProjectAndBranchByTheseNames, getProjectBranchCausalHash, -- * Loading remote project info @@ -59,65 +47,43 @@ 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 (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.ProjectPath +resolveBranchRelativePath brp = do + case brp of + BranchPathInCurrentProject projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName) + pure $ PP.fromProjectAndBranch projectAndBranch path + QualifiedBranchPath projName projBranchName path -> do + projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) + pure $ PP.fromProjectAndBranch projectAndBranch path + UnqualifiedPath newPath' -> do + pp <- Cli.getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId justTheIds x = @@ -152,58 +118,11 @@ 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 - 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 = - 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: @@ -214,8 +133,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) + pp <- Cli.getCurrentProjectPath + pure (ProjectAndBranch (pp ^. #project . #name) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) @@ -244,11 +163,15 @@ 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) - These projectName branchName -> - Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName)) + (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 + project <- MaybeT (Queries.loadProjectByName projectName) + branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName) + pure (ProjectAndBranch project branch) -- Expect a local project branch by a "these names", using the following defaults if a name is missing: -- @@ -260,7 +183,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 <- Cli.getCurrentProjectPath branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName)) @@ -275,31 +198,33 @@ 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 branch reference 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 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. +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 :: 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 {projectId, branchId} = do + causalHashId <- Q.expectProjectBranchHead projectId branchId + Q.expectCausalHash causalHashId ------------------------------------------------------------------------------------------------------------------------ -- Remote project utils @@ -384,7 +309,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 <- 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/Cli/UniqueTypeGuidLookup.hs b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs index 21aa5662562..8ed07da067e 100644 --- a/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs +++ b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs @@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup ) where -import Control.Lens (unsnoc) -import Data.Foldable qualified as Foldable -import Data.Maybe (fromJust) import U.Codebase.Branch qualified as Codebase.Branch -import U.Codebase.Sqlite.Operations qualified as Operations +import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.UniqueTypeGuidLookup qualified as Codebase import Unison.Name (Name) -import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite -loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text) -loadUniqueTypeGuid currentPath name0 = do - -- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path - -- to the unique type, plus its final distinguished name segment. - let (branchPath, name) = - name0 - & Path.fromName' - & Path.resolve currentPath - & Path.unabsolute - & Path.toSeq - & unsnoc - -- This is safe because we were handed a Name, which can't be empty - & fromJust +loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text) +loadUniqueTypeGuid pp name0 = do + let (namePath, finalSegment) = Path.splitFromName name0 + let fullPP = pp & over PP.path_ (<> namePath) -- Define an operation to load a branch by its full path from the root namespace. -- -- This ought to probably lean somewhat on a cache (so long as the caller is aware of the cache, and discrads it at -- an appropriate time, such as after the current unison file finishes parsing). - let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction)) - loadBranchAtPath = Operations.loadBranchAtPath Nothing + let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction)) + loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath - Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name + Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs deleted file mode 100644 index c062c7b4760..00000000000 --- 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.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6ca0b0733b3..fe04d2cf0f8 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 @@ -29,14 +28,13 @@ 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 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 @@ -83,6 +81,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch) import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch) +import Unison.Codebase.Editor.HandleInput.Reflogs qualified as Reflogs import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils @@ -95,7 +94,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 @@ -107,9 +105,10 @@ import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityChec import Unison.Codebase.Metadata qualified as Metadata import Unison.Codebase.Path (Path, Path' (..)) 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 @@ -117,7 +116,6 @@ import Unison.CommandLine.InputPatterns qualified as IP import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.ConstructorReference (GConstructorReference (..)) import Unison.DataDeclaration qualified as DD -import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.LabeledDependency (LabeledDependency) @@ -134,12 +132,8 @@ 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.Project.Util (projectContextFromPath) import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) @@ -204,6 +198,7 @@ loop e = do Cli.respond $ Typechecked (Text.pack sourceName) suffixifiedPPE sr uf in Cli.time "InputPattern" case input of ApiI -> do + pp <- Cli.getCurrentProjectPath Cli.Env {serverBaseUrl} <- ask whenJust serverBaseUrl \baseUrl -> Cli.respond $ @@ -211,17 +206,17 @@ loop e = do P.lines [ "The API information is as follows:", P.newline, - P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl))), + P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.ProjectBranchUI (PP.toProjectAndBranch . PP.toNames $ pp) Path.absoluteEmpty Nothing) baseUrl))), P.newline, P.indentN 2 (P.hiBlue ("API: " <> Pretty.text (Server.urlFor Server.Api baseUrl))) ] CreateMessage pretty -> Cli.respond $ PrintMessage pretty - ShowReflogI -> do + ShowRootReflogI -> do let numEntriesToShow = 500 (schLength, entries) <- Cli.runTransaction $ - (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow + (,) <$> Codebase.branchHashLength <*> Codebase.getDeprecatedRootReflog numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) let (shortEntries, numberedEntries) = @@ -250,86 +245,20 @@ loop e = do -- No expectation, either because this is the most recent entry or -- because we're recovering from a discontinuity Nothing -> ((Just time, toRootCausalHash, reason), (rest, Just fromRootCausalHash, moreEntriesToLoad)) + ShowProjectBranchReflogI mayProjBranch -> do + Reflogs.showProjectBranchReflog mayProjBranch + ShowGlobalReflogI -> do + Reflogs.showGlobalReflog + ShowProjectReflogI mayProj -> do + Reflogs.showProjectReflog mayProj 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 - 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)) - ) - ) - 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) - + newRoot <- resolveBranchId2 newRoot 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))) + Nothing -> Cli.getCurrentProjectPath + 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 @@ -337,22 +266,23 @@ 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 - Cli.updateRoot newRoot description + pb <- getCurrentProjectBranch + void $ Cli.updateProjectBranchRoot_ pb description (const newRoot) 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.AbsolutePath' absPath - srcb <- Cli.expectBranchAtPath' srcp - pure (srcb, WhichBranchEmptyPath srcp) + srcPP <- ProjectUtils.resolveBranchRelativePath path' + srcb <- Cli.getBranchFromProjectPath srcPP + pure (srcb, WhichBranchEmptyPath srcPP) description <- inputDescription input - dest <- ProjectUtils.branchRelativePathToAbsolute dest0 + dest <- ProjectUtils.resolveBranchRelativePath dest0 ok <- Cli.updateAtM description dest (const $ pure srcb) Cli.respond if ok @@ -360,45 +290,43 @@ loop e = do else BranchEmpty branchEmpty MergeI branch -> handleMerge branch MergeCommitI -> handleCommitMerge - MergeLocalBranchI src0 dest0 mergeMode -> do + MergeLocalBranchI unresolvedSrc mayUnresolvedDest 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 - 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 - src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0 - dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0 - srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0 - dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0 - destb <- Cli.getBranchAt dest - 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 <- traverse ProjectUtils.resolveBranchRelativePath before + beforeBranch0 <- Branch.head <$> resolveBranchId2 before + afterLoc <- traverse ProjectUtils.resolveBranchRelativePath after + afterBranch0 <- Branch.head <$> resolveBranchId2 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 @@ -406,8 +334,8 @@ loop e = do 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, _) -> @@ -418,10 +346,11 @@ loop e = do HistoryI resultsCap diffCap from -> do branch <- case from of - Left hash -> Cli.resolveShortCausalHash hash - Right path' -> do - path <- Cli.resolvePath' path' - Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path)) + 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 @@ -439,7 +368,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.getCurrentProjectRoot (_, prev) <- liftIO (Branch.uncons rootBranch) & onNothingM do Cli.returnEarly . CantUndo $ @@ -447,7 +376,8 @@ loop e = do then CantUndoPastStart else CantUndoPastMerge description <- inputDescription input - Cli.updateRoot prev description + pb <- getCurrentProjectBranch + 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' @@ -466,8 +396,8 @@ loop e = do Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText) DocsToHtmlI namespacePath' sourceDirectory -> do Cli.Env {codebase, sandboxedRuntime} <- ask - absPath <- ProjectUtils.branchRelativePathToAbsolute namespacePath' - branch <- liftIO $ Codebase.getBranchAtPath codebase absPath + projPath <- ProjectUtils.resolveBranchRelativePath namespacePath' + branch <- Cli.getBranchFromProjectPath projPath _evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory) pure () AliasTermI force src' dest' -> do @@ -492,7 +422,7 @@ loop e = do when (not force && not (Set.null destTerms)) do Cli.returnEarly (TermAlreadyExists dest' destTerms) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm) + Cli.stepAt description (BranchUtil.makeAddTermName dest srcTerm) Cli.respond Success AliasTypeI force src' dest' -> do src <- traverseOf _Right Cli.resolveSplit' src' @@ -515,22 +445,22 @@ loop e = do when (not force && not (Set.null destTypes)) do Cli.returnEarly (TypeAlreadyExists dest' destTypes) description <- inputDescription input - Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType) + Cli.stepAt description (BranchUtil.makeAddTypeName dest srcType) Cli.respond Success -- 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.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 + 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' destAbs ppe diff) + Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff) when (not (null unknown)) do Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown where @@ -539,28 +469,29 @@ 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 + 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) -> @@ -577,15 +508,10 @@ loop e = do fixupOutput = HQ'.toHQ . Path.nameFromHQSplit NamesI global query -> do hqLength <- Cli.runTransaction Codebase.hashLength - root <- Cli.getRootBranch (names, pped) <- - if global || any Name.isAbsolute query + if global then do - let root0 = Branch.head root - -- 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 @@ -615,11 +541,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 (first Path.unabsolute authorPath) (d authorRef), - BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef), - BranchUtil.makeAddTermName (first Path.unabsolute 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 @@ -642,48 +570,54 @@ loop e = 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 - Cli.updateRoot 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.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) 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 + 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 Nothing -> do + hasConfirmed <- confirmedCommand input + if hasConfirmed || insistence == Force + then do + description <- inputDescription input + pp <- Cli.getCurrentProjectPath + _ <- Cli.updateAt description pp (const Branch.empty) + 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.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) 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 @@ -699,16 +633,15 @@ loop e = do let vars = Set.map Name.toVar requestedNames uf <- Cli.expectLatestTypecheckedFile Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath 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 + pp <- Cli.getCurrentProjectPath + Cli.stepAt description (pp, 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 @@ -758,7 +691,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 @@ -785,7 +719,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 @@ -807,22 +742,21 @@ 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 + pp <- Cli.getCurrentProjectPath + let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "") Cli.respond (DisplayDebugCompletions completions) DebugLSPNameCompletionI prefix -> do LSPDebug.debugLspNameCompletion prefix 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 + pp <- Cli.getCurrentProjectPath + results <- liftIO $ getOptions codebase pp currentBranch Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do Cli.respond DebugFuzzyOptionsNoResolver @@ -892,13 +826,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.getCurrentProjectRoot + void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot] DebugDumpNamespaceSimpleI -> do - rootBranch0 <- Cli.getRootBranch0 - for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) -> + 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 $ 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 @@ -938,7 +872,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 @@ -959,26 +893,23 @@ 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" Branch.SquashMerge -> "merge.squash" 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 + ResetI newRoot tgt -> do + hashTxt <- bid2 newRoot 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 force src0 dest0 -> do src <- hhqs' src0 @@ -1117,9 +1048,19 @@ inputDescription input = QuitI {} -> wat ReleaseDraftI {} -> wat ShowDefinitionI {} -> wat - ShowReflogI {} -> wat StructuredFindI {} -> wat StructuredFindReplaceI {} -> wat + ShowRootReflogI {} -> pure "deprecated.root-reflog" + ShowGlobalReflogI {} -> pure "reflog.global" + ShowProjectReflogI mayProjName -> do + case mayProjName of + Nothing -> pure "project.reflog" + Just projName -> pure $ "project.reflog" <> into @Text projName + ShowProjectBranchReflogI mayProjBranch -> do + case mayProjBranch of + Nothing -> pure "branch.reflog" + Just (PP.ProjectAndBranch Nothing branchName) -> pure $ "branch.reflog" <> into @Text branchName + Just (PP.ProjectAndBranch (Just projName) branchName) -> pure $ "branch.reflog" <> into @Text (PP.ProjectAndBranch projName branchName) SwitchBranchI {} -> wat TestI {} -> wat TodoI {} -> wat @@ -1129,14 +1070,12 @@ inputDescription input = UpgradeI {} -> wat VersionI -> wat where - hp' :: Either SCH.ShortCausalHash Path' -> Cli Text - hp' = either (pure . Text.pack . show) p' p :: Path -> Cli Text - p = fmap tShow . Cli.resolvePath + p = fmap (into @Text) . Cli.resolvePath p' :: Path' -> Cli Text - p' = fmap tShow . Cli.resolvePath' + p' = fmap (into @Text) . Cli.resolvePath' brp :: BranchRelativePath -> Cli Text - brp = fmap from . ProjectUtils.resolveBranchRelativePath + brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath ops :: Maybe Path.Split -> Cli Text ops = maybe (pure ".") ps wat = error $ show input ++ " is not expected to alter the branch" @@ -1151,12 +1090,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) + bid2 :: BranchId2 -> Cli Text + bid2 = \case + Left sch -> pure $ into @Text sch + Right p -> brp p handleFindI :: Bool -> @@ -1169,7 +1106,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. @@ -1177,17 +1114,18 @@ 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. 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.getCurrentProjectRoot0 + 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 = @@ -1323,16 +1261,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.getCurrentProjectRoot 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.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names @@ -1534,8 +1472,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' @@ -1554,25 +1492,20 @@ 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 - -- __FIXME__: `resolvedPath` is ostensiby `Absolute`, but the paths here must be `Relative` below - resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) + (pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1) + let resolvedSplit = (pp.absPath, ns) return - ( resolvedPath, - Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath, - hq ^. _2, - hq ^. _3 - ) + (resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . 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 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.getCurrentProjectRoot0 -- get only once for the entire deletion set let allTermsToDelete :: Set LabeledDependency allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete) @@ -1581,7 +1514,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 @@ -1596,7 +1529,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 @@ -1605,7 +1539,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) @@ -1666,7 +1600,7 @@ displayI outputLoc hq = do (names, pped) <- if useRoot then do - root <- Cli.getRootBranch + root <- Cli.getCurrentProjectRoot let root0 = Branch.head root let names = Names.makeAbsolute $ Branch.toNames root0 pped <- Cli.prettyPrintEnvDeclFromNames names @@ -1778,14 +1712,10 @@ addWatch watchName (Just uf) = do ) _ -> 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) - ) - ) +resolveBranchId2 :: BranchId2 -> Cli (Branch IO) +resolveBranchId2 = \case + Left sch -> Cli.resolveShortCausalHash sch + Right brp -> do + pp <- ProjectUtils.resolveBranchRelativePath brp + Cli.Env {codebase} <- ask + fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs index e9d396cb29b..ef96ecb9831 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs @@ -19,7 +19,6 @@ 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.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Name (Name) @@ -37,16 +36,16 @@ 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.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) + pp <- Cli.getCurrentProjectPath + Cli.stepAt description (pp, 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/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 057d6a0c26a..6df6178d5a9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -1,44 +1,42 @@ -- | @branch@ input handler module Unison.Codebase.Editor.HandleInput.Branch - ( handleBranch, - CreateFrom (..), - doCreateBranch, - doCreateBranch', + ( CreateFrom (..), + handleBranch, + createBranch, ) 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 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 (getBranchAt, 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 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 data CreateFrom - = CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) - | CreateFrom'LooseCode Path.Absolute + = 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 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 @@ -50,93 +48,81 @@ handleBranch sourceI projectAndBranchNames0 = do Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () + currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name) + let projectName = (fromMaybe currentProjectName mayProjectName) + destProject <- do + 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 (ProjectAndBranch projectName newBranchName)) + -- Compute what we should create the branch from. - createFrom <- + maySrcProjectAndBranch <- 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 - 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 - - 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) + Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath + Input.BranchSourceI'Empty -> pure Nothing + Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do + pp <- Cli.getCurrentProjectPath + Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames) + 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 (pure newBranchName) + Nothing -> do + let description = "Empty branch created" + void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName) Cli.respond $ Output.CreatedProjectBranch - ( case createFrom of - CreateFrom'Branch sourceBranch -> - if sourceBranch ^. #project . #projectId == project ^. #projectId + ( case maySrcProjectAndBranch of + Just sourceBranch -> + if sourceBranch ^. #project . #projectId == destProject ^. #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 + Nothing -> Output.CreatedProjectBranchFrom'Nothingness ) - projectAndBranchNames + (projectAndBranchNames & #project .~ projectName) --- | @doCreateBranch createFrom project branch description@: +-- | @createBranch description createFrom project getNewBranchName@: -- --- 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 in @project@ at the name from @getNewBranchName@ (failing if branch already exists in @project@). +-- 2. 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.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) - CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath - CreateFrom'Nothingness -> pure Branch.empty - let parentBranchId = - case createFrom of - CreateFrom'Branch (ProjectAndBranch _ sourceBranch) - | sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId - _ -> Nothing - (newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description - pure newBranchId - -doCreateBranch' :: - Branch IO -> - Maybe ProjectBranchId -> +-- Returns the branch id and name of the newly-created branch. +createBranch :: + Text -> + CreateFrom -> Sqlite.Project -> Sqlite.Transaction ProjectBranchName -> - Text -> Cli (ProjectBranchId, ProjectBranchName) -doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do +createBranch description createFrom project getNewBranchName = do let projectId = project ^. #projectId - (newBranchId, newBranchName) <- + Cli.Env {codebase} <- ask + (mayParentBranchId, newBranchCausalHashId) <- case createFrom of + CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do + newBranchCausalHashId <- Q.expectProjectBranchHead parentBranch.projectId parentBranch.branchId + let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing + pure (parentBranchId, 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) + let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing + pure (parentBranchId, newBranchCausalHashId) + CreateFrom'Namespace branch -> do + liftIO $ Codebase.putBranch codebase branch + Cli.runTransaction $ do + newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch) + pure (Nothing, newBranchCausalHashId) + (newBranchName, newBranchId) <- Cli.runTransactionWithRollback \rollback -> do newBranchName <- getNewBranchName Queries.projectBranchExistsByName projectId newBranchName >>= \case @@ -146,16 +132,15 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de -- `bar`, so the fork will succeed. newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom) Queries.insertProjectBranch + description + newBranchCausalHashId Sqlite.ProjectBranch { projectId, branchId = newBranchId, name = newBranchName, - parentBranchId = parentBranchId + parentBranchId = mayParentBranchId } - Queries.setMostRecentBranch projectId newBranchId - pure (newBranchId, newBranchName) + pure (newBranchName, newBranchId) - let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId) - _ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject) - Cli.cd newBranchPath + Cli.switchProject (ProjectAndBranch projectId newBranchId) pure (newBranchId, newBranchName) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs index cc739366839..fdb5bdf6c8d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs @@ -7,14 +7,15 @@ where 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 ba7bf5c8859..99381ea7c62 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/CommitMerge.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs index 96312952196..62c46b2b5d9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs @@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) 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 @@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..)) handleCommitMerge :: Cli () handleCommitMerge = do - (mergeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + mergeProjectAndBranch <- Cli.getCurrentProjectAndBranch -- Assert that this is a "merge" branch, get its parent (which is the branch we were on when we ran `merge`), -- and switch to the parent. @@ -33,9 +34,8 @@ handleCommitMerge = do parentBranch <- Cli.runTransaction do parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId - Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId pure parentBranch - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId)) + Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId) -- Merge the merge branch into the parent diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index a7d61a8cdbc..93d1188830d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) 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 @@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..)) handleCommitUpgrade :: Cli () handleCommitUpgrade = do - (upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + upgradeProjectAndBranch <- Cli.getCurrentProjectAndBranch -- Assert that this is an "upgrade" branch, get its parent (which is the branch we were on when we ran `upgrade`), -- and switch to the parent. @@ -33,9 +34,8 @@ handleCommitUpgrade = do parentBranch <- Cli.runTransaction do parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId - Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId pure parentBranch - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId)) + Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId) -- Merge the upgrade branch into the parent diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index 72df1028fd3..ccbcfcb2670 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -5,19 +5,26 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch ) where -import Data.Map.Strict qualified as Map -import Data.These (These (..)) +import Control.Lens +import Data.List qualified as List +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) 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.Path qualified as Path +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.HandleInput.ProjectCreate +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch (..)) +import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -- | Delete a project branch. @@ -27,44 +34,64 @@ import Witch (unsafeFrom) -- project. handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleDeleteBranch projectAndBranchNamesToDelete = do - projectAndBranchToDelete <- - ProjectUtils.expectProjectAndBranchByTheseNames - case projectAndBranchNamesToDelete of - ProjectAndBranch Nothing branch -> That branch - ProjectAndBranch (Just project) branch -> These project branch - - maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch - - doDeleteProjectBranch projectAndBranchToDelete + ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath + projectAndBranchToDelete@(ProjectAndBranch projectOfBranchToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just) -- 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 \(currentProjectAndBranch, _restPath) -> - when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do - newPath <- - case projectAndBranchToDelete.branch.parentBranchId of - Nothing -> - let loadMain = - Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main") - in Cli.runTransaction loadMain <&> \case - Nothing -> Path.Absolute Path.empty - Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch) - Just parentBranchId -> - pure $ - ProjectUtils.projectBranchPath - (ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId) - Cli.cd newPath + -- 3. Any other branch in the codebase + -- 4. Create a new branch in the current project + when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do + mayNextLocation <- + Cli.runTransaction . runMaybeT $ + asum + [ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId), + findMainBranchInProjectExcept (currentProject ^. #projectId) (branchToDelete ^. #branchId), + -- Any branch in the codebase except the one we're deleting + findAnyBranchInProjectExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId), + findAnyBranchInCodebaseExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId), + createNewBranchInProjectExcept projectOfBranchToDelete.name branchToDelete.name + ] + + nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing + Cli.switchProject nextLoc + doDeleteProjectBranch projectAndBranchToDelete + where + parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + parentBranch projectId mayParentBranchId = do + parentBranchId <- hoistMaybe mayParentBranchId + pure (ProjectAndBranch projectId parentBranchId) + + findMainBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findMainBranchInProjectExcept projectId exceptBranchId = do + branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main") + guard (branch ^. #branchId /= exceptBranchId) + pure (ProjectAndBranch projectId (branch ^. #branchId)) + + findAnyBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInProjectExcept projectId exceptBranchId = do + (someBranchId, _) <- MaybeT . fmap (List.find (\(branchId, _) -> branchId /= exceptBranchId)) $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing + pure (ProjectAndBranch projectId someBranchId) + + findAnyBranchInCodebaseExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + findAnyBranchInCodebaseExcept exceptProjectId exceptBranchId = do + (_, pbIds) <- MaybeT . fmap (List.find (\(_, ids) -> ids /= ProjectAndBranch exceptProjectId exceptBranchId)) $ Queries.loadAllProjectBranchNamePairs + pure pbIds + + createNewBranchInProjectExcept :: ProjectName -> ProjectBranchName -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + createNewBranchInProjectExcept projectName (UnsafeProjectBranchName "main") = lift $ do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main2") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId + createNewBranchInProjectExcept projectName _ = lift $ do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId -- | Delete a project branch and record an entry in the reflog. -doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli () +doDeleteProjectBranch :: (HasCallStack) => 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/DeleteProject.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs index 3ff51cf8183..ee662c91adf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteProject.hs @@ -4,39 +4,53 @@ module Unison.Codebase.Editor.HandleInput.DeleteProject ) where -import Data.Function (on) +import Control.Lens +import Data.List qualified as List +import U.Codebase.Sqlite.DbId +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) 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 qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPathG (..)) +import Unison.Codebase.SqliteCodebase.Operations qualified as Ops +import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectName) +import Unison.Project (ProjectAndBranch (..)) +import Unison.Sqlite qualified as Sqlite -- | Delete a project handleDeleteProject :: ProjectName -> Cli () handleDeleteProject projectName = do - maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch + ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath - deletedProject <- + projectToDelete <- Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - Queries.deleteProject (project ^. #projectId) - pure project + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) - let projectId = deletedProject ^. #projectId + when (projectToDelete.projectId == currentProject.projectId) do + nextLoc <- Cli.runTransaction $ findAnyBranchInCodebaseNotInProject (projectToDelete.projectId) `whenNothingM` createDummyProjectExcept projectToDelete.name + Cli.switchProject nextLoc - Cli.updateAt - ("delete.project " <> into @Text projectName) - (ProjectUtils.projectPath projectId) - (const Branch.empty) + Cli.runTransaction do + Queries.deleteProject (projectToDelete ^. #projectId) + where + findAnyBranchInCodebaseNotInProject :: ProjectId -> Sqlite.Transaction (Maybe (ProjectAndBranch ProjectId ProjectBranchId)) + findAnyBranchInCodebaseNotInProject exceptProjectId = do + Queries.loadAllProjectBranchNamePairs + <&> List.find (\(_, ProjectAndBranch projId _) -> projId /= exceptProjectId) + <&> fmap \(_, pbIds) -> pbIds - -- 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) + createDummyProjectExcept :: ProjectName -> Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId) + createDummyProjectExcept (UnsafeProjectName "scratch") = do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch (UnsafeProjectName "scratch2") (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId + createDummyProjectExcept _ = do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + Ops.insertProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main") emptyCausalHashId + <&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 4c301201700..52e70188c89 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 @@ -22,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) @@ -40,14 +39,6 @@ import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText) handleInstallLib :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli () handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do - (currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - - let currentProjectBranchPath = - ProjectUtils.projectBranchPath $ - ProjectAndBranch - currentProjectAndBranch.project.projectId - currentProjectAndBranch.branch.branchId - libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName libdepBranchName <- @@ -79,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.getBranch0At currentProjectBranchPath + currentBranchObject <- Cli.getCurrentProjectRoot0 pure $ fresh (\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText) @@ -90,13 +81,12 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran (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) + 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/Load.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs index a9259fc969f..f050df2086a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs @@ -78,7 +78,7 @@ loadUnisonFile sourceName text = do Text -> Cli (TypecheckedUnisonFile Symbol Ann) withFile names sourceName text = do - currentPath <- Cli.getCurrentPath + pp <- Cli.getCurrentProjectPath State.modify' \loopState -> loopState & #latestFile .~ Just (Text.unpack sourceName, False) @@ -88,7 +88,7 @@ loadUnisonFile sourceName text = do let parsingEnv = Parser.ParsingEnv { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, + uniqueTypeGuid = Cli.loadUniqueTypeGuid pp, names } unisonFile <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs index 3fd6e43f4f1..55be69f3a73 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs @@ -8,9 +8,11 @@ import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.PrettyPrintUtils qualified as Cli +import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Path (Path') +import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Server.Backend qualified as Backend @@ -18,9 +20,9 @@ import Unison.Server.Backend qualified as Backend handleLs :: Path' -> Cli () handleLs 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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 33ab84de712..ea319b74af0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -69,6 +69,8 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.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 @@ -147,7 +149,8 @@ import Prelude hiding (unzip, zip, zipWith) 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. - (aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath + let aliceProjectAndBranch = ProjectAndBranch aliceProject aliceProjectBranch -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch -- name, and causal hash. @@ -197,7 +200,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 @@ -214,7 +216,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) done (Output.MergeSuccessFastForward mergeSourceAndTarget) -- Create a bunch of cached database lookup functions @@ -397,7 +399,7 @@ doMerge info = do in if thisMergeHasConflicts then pure Nothing else do - currentPath <- Cli.getCurrentPath + currentPath <- Cli.getCurrentProjectPath parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe @@ -408,12 +410,12 @@ doMerge info = do Nothing -> do Cli.Env {writeSource} <- ask (_temporaryBranchId, temporaryBranchName) <- - HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch parents.alice parents.bob) - (Just info.alice.projectAndBranch.branch.branchId) + HandleInput.Branch.createBranch + info.description + (HandleInput.Branch.CreateFrom'NamespaceWithParent info.alice.projectAndBranch.branch (Branch.mergeNode stageOneBranch parents.alice parents.bob)) info.alice.projectAndBranch.project (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) - info.description + scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" @@ -423,11 +425,10 @@ doMerge info = do Just tuf -> do Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - _ <- - Cli.updateAt - info.description - alicePath - (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + Cli.updateProjectBranchRoot_ + info.alice.projectAndBranch.branch + info.description + (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) pure (Output.MergeSuccess mergeSourceAndTarget) Cli.respond finalOutput @@ -436,8 +437,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) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveAll.hs index 77b4bc85145..f8068a67f23 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 hasConfirmed 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 21b41511b05..eb6b3effbf8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs @@ -7,17 +7,21 @@ 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 +-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if +-- needed. 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' + -- 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.getMaybeBranchAt 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. @@ -37,6 +41,7 @@ doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli () doMoveBranch actionDescription hasConfirmed src' dest' = do moveBranchFunc hasConfirmed 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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs index c3290603034..5dd0bc2cc23 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 @@ -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,11 +30,11 @@ moveTermSteps src' dest' = do destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest) when (not (Set.null destTerms)) do Cli.returnEarly (Output.TermAlreadyExists dest' destTerms) - let p = first Path.unabsolute 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, - BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm + BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm ] doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () @@ -41,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 bdf9fe88cd0..286cdb91c85 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,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 -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 @@ -29,11 +30,11 @@ moveTypeSteps src' dest' = do destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest) when (not (Set.null destTypes)) do Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes) - let p = first Path.unabsolute 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 (first Path.unabsolute dest) srcType + BranchUtil.makeAddTypeName (over _1 (view PP.absPath_) dest) srcType ] doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli () @@ -41,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/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 068a28832bc..aa35d39ddee 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.getMaybeBranch0At path & onNothingM do - Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path))) + Cli.getMaybeBranch0FromProjectPath pp & onNothingM do + Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp)) externalDependencies <- Cli.runTransaction (namespaceDependencies codebase branch) - currentPPED <- Cli.currentPrettyPrintEnvDecl - globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0 - globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames - -- 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 - 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 5d15bf659cb..8a872d18b82 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -5,24 +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.ProjectUtils (projectBranchPath) +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 @@ -39,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 @@ -78,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) @@ -181,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 @@ -199,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 @@ -215,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 = @@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do pure (localProjectId, localProjectName) 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, branchId = localBranchId, @@ -277,12 +269,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 :: diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 8ffe4e97777..e9f6e99e951 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.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +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.ProjectUtils (projectBranchPath) 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.Codebase.SqliteCodebase.Operations qualified as Ops import Unison.NameSegment qualified as NameSegment import Unison.Prelude @@ -55,14 +55,12 @@ 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 <- + (project, branch) <- case maybeProjectName of Nothing -> do randomProjectNames <- liftIO generateRandomProjectNames @@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do let loop = \case [] -> error (reportBug "E066388" "project name supply is supposed to be infinite") projectName : projectNames -> - Queries.projectExistsByName projectName >>= \case - False -> do - Ops.insertProjectAndBranch projectId projectName branchId branchName - pure projectName - True -> loop projectNames + Queries.loadProjectByName projectName >>= \case + Nothing -> do + (project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId + pure (project, branch) + Just _project -> loop projectNames loop randomProjectNames Just projectName -> do Cli.runTransactionWithRollback \rollback -> do Queries.projectExistsByName projectName >>= \case False -> do - Ops.insertProjectAndBranch projectId projectName branchId branchName - pure projectName + Ops.insertProjectAndBranch projectName branchName emptyCausalHashId True -> rollback (Output.ProjectNameAlreadyExists projectName) - let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId} - Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName) - Cli.cd path + Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name) + Cli.switchProject (ProjectAndBranch project.projectId branch.branchId) maybeBaseLatestReleaseBranchObject <- if tryDownloadingBase @@ -126,30 +122,29 @@ 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.unabsolute path, 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" project.projectId branch.branchId baseBranchCausalHashId Cli.respond Output.HappyCoding - where - reflogDescription = - case maybeProjectName of - Nothing -> "project.create" - Just projectName -> "project.create " <> into @Text projectName + pure ProjectAndBranch {project = project.projectId, branch = branch.branchId} -- An infinite list of random project names that looks like -- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs index f7d960d2df5..117f12bb809 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 ef668fa477b..8799fa4e2f6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -5,11 +5,11 @@ module Unison.Codebase.Editor.HandleInput.ProjectSwitch where import Data.These (These (..)) -import U.Codebase.Sqlite.Project qualified -import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +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 @@ -28,51 +28,46 @@ 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 switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli () switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do - branch <- - case projectAndBranchNames0 of - This projectName -> - Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - Queries.loadMostRecentBranch project.projectId >>= \case - Nothing -> do - let branchName = unsafeFrom @Text "main" - branch <- - Queries.loadProjectBranchByName project.projectId branchName & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) - Queries.setMostRecentBranch branch.projectId branch.branchId - pure branch - Just branchId -> Queries.expectProjectBranch project.projectId branchId - _ -> do - projectAndBranchNames <- ProjectUtils.hydrateNames projectAndBranchNames0 - Cli.runTransactionWithRollback \rollback -> do - branch <- - Queries.loadProjectBranchByNames projectAndBranchNames.project projectAndBranchNames.branch & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - Queries.setMostRecentBranch branch.projectId branch.branchId - pure branch - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId)) + branch <- case projectAndBranchNames0 of + This projectName -> + Cli.runTransactionWithRollback \rollback -> do + project <- + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) + Queries.loadMostRecentBranch (project ^. #projectId) >>= \case + Nothing -> do + let branchName = unsafeFrom @Text "main" + branch <- + Queries.loadProjectBranchByName project.projectId branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) + pure branch + Just branchId -> Queries.expectProjectBranch project.projectId branchId + _ -> do + projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 + Cli.runTransactionWithRollback \rollback -> do + branch <- + Queries.loadProjectBranchByNames projectName branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) + pure branch + Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId)) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 6165d60bc3e..3ff70122201 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -21,9 +21,9 @@ 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.Cli.UnisonConfigUtils (resolveConfiguredUrl) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch @@ -34,13 +34,11 @@ 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 +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 +74,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,22 +89,18 @@ 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 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 - 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 @@ -139,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do didUpdate <- Cli.updateAtM description - targetAbsolutePath + targetProjectPath (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) Cli.respond @@ -167,30 +160,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.toProjectAndBranch pp + (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 +200,7 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch + localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath let localProjectId = localProjectAndBranch.project.projectId let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case @@ -243,8 +235,7 @@ resolveExplicitSource includeSquashed = \case resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) resolveImplicitTarget = do - (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch - pure projectAndBranch + 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 @@ -253,8 +244,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 @@ -266,7 +257,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 @@ -276,19 +267,19 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb loadPropagateDiffDefaultPatch :: Text -> - Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> - Path.Absolute -> + Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -> + 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) @@ -297,10 +288,11 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do propagatePatch :: Text -> Patch -> - Path.Absolute -> + PP.ProjectPath -> Cli Bool propagatePatch inputDescription patch scopePath = do Cli.time "propagatePatch" do + rootNames <- Cli.projectBranchNames scopePath.branch Cli.stepAt' (inputDescription <> " (applying patch)") - (Path.unabsolute scopePath, Propagate.propagateAndApply patch) + (scopePath, Propagate.propagateAndApply rootNames patch) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index a9aba3224c1..1bb63940d64 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) @@ -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 (..), @@ -32,13 +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.Editor.RemoteRepo - ( WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - ) -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) @@ -67,49 +59,16 @@ 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) - -- 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 - 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 + PushSourceTarget1 remoteProjectAndBranch0 -> do + localProjectAndBranch <- Cli.getCurrentProjectAndBranch + pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) -- 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 @@ -119,24 +78,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 - _ <- 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 :: @@ -147,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) @@ -471,7 +409,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do Share.TransportError err -> ShareErrorTransport err afterUploadAction let ProjectAndBranch projectName branchName = remoteBranch - Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName))) + Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName)) ------------------------------------------------------------------------------------------------------------------------ -- After upload actions @@ -563,7 +501,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 @@ -633,14 +571,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/HandleInput/Reflogs.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs new file mode 100644 index 00000000000..f2006dca7e4 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs @@ -0,0 +1,60 @@ +-- | Helpers for working with various kinds of reflogs. +module Unison.Codebase.Editor.HandleInput.Reflogs + ( showProjectBranchReflog, + showProjectReflog, + showGlobalReflog, + ) +where + +import Control.Monad.Reader +import Data.Time (getCurrentTime) +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Project (Project) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog +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.Editor.Output qualified as Output +import Unison.Codebase.ShortCausalHash qualified as SCH +import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Prelude +import Unison.Sqlite qualified as Sqlite + +showProjectBranchReflog :: Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> Cli () +showProjectBranchReflog mayProjectAndBranch = do + ProjectAndBranch _project branch <- case mayProjectAndBranch of + Nothing -> Cli.getCurrentProjectAndBranch + Just pab -> ProjectUtils.resolveProjectBranch (second Just pab) + reflogHelper (\n -> Codebase.getProjectBranchReflog n (branch ^. #branchId)) + +showProjectReflog :: Maybe ProjectName -> Cli () +showProjectReflog mayProject = do + ProjectAndBranch project _ <- ProjectUtils.resolveProjectBranch (ProjectAndBranch mayProject Nothing) + reflogHelper (\n -> Codebase.getProjectReflog n (project ^. #projectId)) + +showGlobalReflog :: Cli () +showGlobalReflog = do + reflogHelper Codebase.getGlobalReflog + +reflogHelper :: (Int -> Sqlite.Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]) -> Cli () +reflogHelper getEntries = do + let numEntriesToShow = 500 + entries <- + Cli.runTransaction $ do + schLength <- Codebase.branchHashLength + entries <- getEntries numEntriesToShow + entries + & (fmap . fmap) (\ch -> (ch, SCH.fromHash schLength ch)) + & pure + let moreEntriesToLoad = + if length entries == numEntriesToShow + then Output.MoreEntriesThanShown + else Output.AllEntriesShown + mayNow <- + asks Cli.isTranscriptTest >>= \case + True -> pure Nothing + False -> Just <$> liftIO getCurrentTime + Cli.respondNumbered $ Output.ShowProjectBranchReflog mayNow moreEntriesToLoad entries diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ReleaseDraft.hs index 13caf9b1acd..e6cdbffc7e6 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) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs index 85ce5922f51..b80d1616740 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs @@ -11,16 +11,14 @@ 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 +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 +26,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,39 +36,27 @@ 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 ^. PP.absPath_) -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@(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) + 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 @@ -89,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/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index b6bb301056a..38bac30323b 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 @@ -35,6 +36,7 @@ import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.TermEdit qualified as TermEdit import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.DataDeclaration (Decl) @@ -73,7 +75,8 @@ import Unison.WatchKind (WatchKind) handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli () handleUpdate input optionalPatch requestedNames = do Cli.Env {codebase} <- ask - currentPath' <- Cli.getCurrentPath + ppRoot <- PP.toRoot <$> Cli.getCurrentProjectPath + currentPathAbs <- Cli.getCurrentPath let patchPath = case optionalPatch of NoPatch -> Nothing @@ -165,43 +168,56 @@ handleUpdate input optionalPatch requestedNames = do p' = foldl' step1 p typeEdits step1 p (_, r, r') = Patch.updateType r (TypeEdit.Replace r') p step2 p (_, r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p - (p, seg) = Path.toAbsoluteSplit currentPath' patchPath + (p, seg) = Path.toAbsoluteSplit currentPathAbs patchPath updatePatches :: (Monad m) => Branch0 m -> m (Branch0 m) updatePatches = Branch.modifyPatches seg updatePatch 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)] - ) - Cli.runTransaction - . Codebase.addDefsToCodebase codebase - . Slurp.filterUnisonFile sr - $ Slurp.originalFile sr - let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames + updatedProjectRootBranch <- + if Slurp.hasAddsOrUpdates sr + then do + -- First add the new definitions to the codebase + Cli.runTransaction + . Codebase.addDefsToCodebase codebase + . Slurp.filterUnisonFile sr + $ Slurp.originalFile sr + projectRootBranch <- Cli.getCurrentProjectRoot + -- take a look at the `updates` from the SlurpResult + -- and make a patch diff to record a replacement from the old to new references + projectRootBranch + & Branch.stepManyAtM + ( [ ( Path.unabsolute currentPathAbs, + pure . doSlurpUpdates typeEdits termEdits termDeprecations + ), + ( Path.unabsolute currentPathAbs, + pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr) + ) + ] + ++ case patchOps of + Nothing -> [] + Just (_, update, p) -> [(Path.unabsolute p, update)] + ) + & liftIO + else Cli.getCurrentProjectRoot + + projectRootBranchWithPropagatedPatch <- case patchOps of + Nothing -> pure updatedProjectRootBranch + Just (updatedPatch, _, _) -> do + -- Propagate the patch to the whole project. + let scopePath = Path.empty + propagatePatch updatedPatch scopePath updatedProjectRootBranch + let description = case patchPath of + Nothing -> "update.nopatch" + Just p -> + p + & Path.unsplit' + & Path.resolve @_ @_ @Path.Absolute currentPathAbs + & tShow + void $ Cli.updateAt description ppRoot (const projectRootBranchWithPropagatedPatch) + let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) (Branch.toNames $ Branch.head projectRootBranchWithPropagatedPatch) 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 getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult getSlurpResultForUpdate requestedNames slurpCheckNames = do @@ -646,10 +662,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/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 25f6de5709b..007103597a8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -50,6 +50,7 @@ import Unison.Codebase.Editor.Output (Output) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.Type (Codebase) import Unison.ConstructorReference (GConstructorReference (ConstructorReference)) import Unison.DataDeclaration (DataDeclaration, Decl) @@ -107,8 +108,8 @@ handleUpdate2 = do Cli.Env {codebase, writeSource} <- ask tuf <- Cli.expectLatestTypecheckedFile let termAndDeclNames = getTermAndDeclNames tuf - currentPath <- Cli.getCurrentPath - currentBranch0 <- Cli.getBranch0At currentPath + pp <- Cli.getCurrentProjectPath + currentBranch0 <- Cli.getCurrentBranch0 let namesIncludingLibdeps = Branch.toNames currentBranch0 let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment)) let ctorNames = forwardCtorNames namesExcludingLibdeps @@ -142,7 +143,7 @@ handleUpdate2 = do then pure tuf else do Cli.respond Output.UpdateStartTypechecking - parsingEnv <- makeParsingEnv currentPath namesIncludingLibdeps + parsingEnv <- makeParsingEnv pp namesIncludingLibdeps secondTuf <- prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do scratchFilePath <- fst <$> Cli.expectLatestFile @@ -186,7 +187,7 @@ prettyParseTypecheck2 prettyUf parsingEnv = do Result.Result _notes Nothing -> Left prettyUf -- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@. -makeParsingEnv :: Path.Absolute -> Names -> Cli (Parser.ParsingEnv Transaction) +makeParsingEnv :: ProjectPath -> Names -> Cli (Parser.ParsingEnv Transaction) makeParsingEnv path names = do Cli.Env {generateUniqueName} <- ask uniqueName <- liftIO generateUniqueName @@ -201,12 +202,12 @@ makeParsingEnv path names = do saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli () saveTuf getConstructors tuf = do Cli.Env {codebase} <- ask - currentPath <- Cli.getCurrentPath + pp <- Cli.getCurrentProjectPath branchUpdates <- Cli.runTransactionWithRollback \abort -> do Codebase.addDefsToCodebase codebase tuf typecheckedUnisonFileToBranchUpdates abort getConstructors tuf - Cli.stepAt "update" (Path.unabsolute currentPath, Branch.batchUpdates branchUpdates) + Cli.stepAt "update" (pp, 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/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 70e2475445d..454e530f173 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -12,8 +12,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 @@ -21,6 +19,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 (..)) import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch import Unison.Codebase.Editor.HandleInput.Update2 ( addDefinitionsToUnisonFile, @@ -35,6 +34,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 @@ -47,7 +47,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 @@ -67,21 +67,19 @@ 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 - let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace - let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld - let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld - let currentLocalNames = Branch.toNames (Branch.deleteLibdeps currentNamespace) + currentNamespace <- Cli.getCurrentProjectRoot + let currentNamespaceSansOld = currentNamespace & Branch.step (Branch.deleteLibdep oldName) + let currentNamespaceSansOld0 = Branch.head currentNamespaceSansOld + let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld0 + let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld0 + let currentLocalNames = Branch.toNames (Branch.deleteLibdeps $ Branch.head currentNamespace) let currentLocalConstructorNames = forwardCtorNames currentLocalNames - let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld + let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld0 - 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 @@ -89,7 +87,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 @@ -153,27 +151,24 @@ handleUpgrade oldName newName = do `PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents ) - parsingEnv <- makeParsingEnv projectPath currentDeepNamesSansOld + pp@(PP.ProjectPath project projectBranch _path) <- Cli.getCurrentProjectPath + parsingEnv <- makeParsingEnv pp 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) - temporaryBranchId <- - HandleInput.Branch.doCreateBranch - (HandleInput.Branch.CreateFrom'Branch projectAndBranch) - projectAndBranch.project - temporaryBranchName + let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName + (_temporaryBranchId, temporaryBranchName) <- + HandleInput.Branch.createBranch textualDescriptionOfUpgrade - let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId)) - Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld) + (CreateFrom'NamespaceWithParent projectBranch currentNamespaceSansOld) + project + 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 projectAndBranch.branch.name temporaryBranchName scratchFilePath oldName newName + Output.UpgradeFailure (projectBranch ^. #name) temporaryBranchName scratchFilePath oldName newName branchUpdates <- Cli.runTransactionWithRollback \abort -> do @@ -184,7 +179,7 @@ handleUpgrade oldName newName = do typecheckedUnisonFile Cli.stepAt textualDescriptionOfUpgrade - ( Path.unabsolute projectPath, + ( PP.toRoot pp, Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates ) Cli.respond (Output.UpgradeSuccess oldName newName) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c2ac1a407cb..959bc451ef9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -9,9 +9,11 @@ module Unison.Codebase.Editor.Input Event (..), OutputLocation (..), PatchPath, + BranchIdG (..), BranchId, + BranchId2, AbsBranchId, - LooseCodeOrProject, + UnresolvedProjectBranch, parseBranchId, parseBranchId2, parseShortCausalHash, @@ -31,10 +33,11 @@ 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 +import Unison.Codebase.ProjectPath (ProjectPath) import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -60,15 +63,26 @@ 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) --- | 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) +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 AbsBranchId = Either ShortCausalHash Path.Absolute +type BranchId = BranchIdG Path' + +type BranchId2 = Either ShortCausalHash BranchRelativePath + +type AbsBranchId = BranchIdG Path.Absolute + +-- | An unambiguous project branch name, use the current project name if not provided. +type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName type HashOrHQSplit' = Either ShortHash Path.HQSplit' @@ -79,8 +93,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 @@ -106,20 +120,15 @@ 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 - | DiffNamespaceI BranchId BranchId -- old new + MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode + | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) + | DiffNamespaceI BranchId2 BranchId2 -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput - | ResetRootI (Either ShortCausalHash Path') - | ResetI - ( These - (Either ShortCausalHash Path') - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - (Maybe LooseCodeOrProject) - | -- 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? + | ResetRootI BranchId + | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) + -- 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. @@ -182,7 +191,10 @@ data Input | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery | -- Show provided definitions. ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name)) - | ShowReflogI + | ShowRootReflogI {- Deprecated -} + | ShowGlobalReflogI + | ShowProjectReflogI (Maybe ProjectName) + | ShowProjectBranchReflogI (Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) | UpdateBuiltinsI | MergeBuiltinsI (Maybe Path) | MergeIOBuiltinsI (Maybe Path) @@ -239,8 +251,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'UnresolvedProjectBranch UnresolvedProjectBranch deriving stock (Eq, Show) -- | Pull source and target: either neither is specified, or only a source, or both. @@ -251,15 +263,14 @@ 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. 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 a85360dc4e3..d7a3b06e81a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Output TestReportStats (..), TodoOutput (..), todoOutputIsEmpty, + MoreEntriesThanShown (..), UndoFailureReason (..), ShareError (..), UpdateOrUpgrade (..), @@ -29,6 +30,7 @@ import U.Codebase.Branch.Diff (NameChanges) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import Unison.Auth.Types (CredentialFailure) import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget) import Unison.Cli.Share.Projects.Types qualified as Share @@ -43,10 +45,11 @@ import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path -import Unison.Codebase.PushBehavior (PushBehavior) +import Unison.Codebase.ProjectPath (Project, ProjectBranch, 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) @@ -100,25 +103,25 @@ 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) | 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)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterMergePreview - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - Path.Absolute + (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + ProjectPath PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann) @@ -151,8 +154,12 @@ 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. + | ShowProjectBranchReflog + (Maybe UTCTime {- current time, omitted in transcript tests to be more deterministic -}) + MoreEntriesThanShown + [ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash)] data TodoOutput = TodoOutput { defnsInLib :: !Bool, @@ -291,7 +298,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,14 +316,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 Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + | PreviewMergeAlreadyUpToDate ProjectPath ProjectPath | NotImplemented | NoBranchWithHash ShortCausalHash | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms @@ -328,10 +331,8 @@ data Output | BadName Text | CouldntLoadBranch CausalHash | HelpMessage Input.InputPattern - | NamespaceEmpty (NonEmpty AbsBranchId) + | NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath)) | 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. @@ -414,7 +415,6 @@ data Output | UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int) | UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment - | LooseCodePushDeprecated | MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName | MergeSuccess !MergeSourceAndTarget | MergeSuccessFastForward !MergeSourceAndTarget @@ -434,6 +434,9 @@ data Output | NoMergeInProgress | Output'DebugSynhashTerm !TermReference !Hash !Text +data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown + deriving (Eq, Show) + data UpdateOrUpgrade = UOUUpdate | UOUUpgrade -- | What did we create a project branch from? @@ -451,12 +454,10 @@ data CreatedProjectBranchFrom -- | A branch was empty. But how do we refer to that branch? data WhichBranchEmpty = WhichBranchEmptyHash ShortCausalHash - | WhichBranchEmptyPath Path' + | WhichBranchEmptyPath ProjectPath data ShareError - = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError - | ShareErrorDownloadEntities Share.DownloadEntitiesError - | ShareErrorFastForwardPush Sync.FastForwardPushError + = ShareErrorDownloadEntities Share.DownloadEntitiesError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError | ShareErrorPull Sync.PullError | ShareErrorTransport Sync.CodeserverTransportError @@ -589,7 +590,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 @@ -654,7 +654,6 @@ isFailure o = case o of ProjectHasNoReleases {} -> True UpgradeFailure {} -> True UpgradeSuccess {} -> False - LooseCodePushDeprecated -> True MergeFailure {} -> True MergeSuccess {} -> False MergeSuccessFastForward {} -> False @@ -697,3 +696,4 @@ isNumberedFailure = \case ListNamespaceDependencies {} -> False TestResults _ _ _ _ _ fails -> not (null fails) Output'Todo {} -> False + ShowProjectBranchReflog {} -> False diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index f1bf65962c4..58645170344 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,11 +81,12 @@ noEdits :: Edits v noEdits = Edits mempty mempty mempty mempty mempty mempty mempty propagateAndApply :: + Names -> Patch -> Branch0 IO -> Cli (Branch0 IO) -propagateAndApply patch branch = do - edits <- propagate patch branch +propagateAndApply rootNames patch branch = do + edits <- propagate rootNames patch branch let f = applyPropagate patch edits (pure . f . applyDeprecations patch) branch @@ -234,15 +234,13 @@ 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. diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index cf7a99a8f92..14e7412c4e9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,8 +1,7 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - writeRemoteNamespace, - writeRemoteNamespaceWith, parseReadShareLooseCode, + writeRemoteNamespace, ) where @@ -17,8 +16,6 @@ import Unison.Codebase.Editor.RemoteRepo ReadShareLooseCode (..), ShareCodeserver (DefaultCodeserver), ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), ) import Unison.Codebase.Path qualified as Path import Unison.NameSegment (NameSegment) @@ -53,25 +50,9 @@ parseReadShareLooseCode label 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 :: P (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)) + (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name) -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 988a1e55ca3..ab433d96fcb 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -29,11 +29,11 @@ import Data.Configurator qualified as Configurator import Data.Configurator.Types (Config) import Data.IORef import Data.List (isSubsequenceOf) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Text qualified as Text import Data.These (These (..)) import Data.UUID.V4 qualified as UUID -import Ki qualified import Network.HTTP.Client qualified as HTTP import System.Directory (doesFileExist) import System.Environment (lookupEnv) @@ -42,7 +42,6 @@ import System.IO qualified as IO import System.IO.Error (catchIOError) import Text.Megaparsec qualified as P 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 @@ -52,15 +51,13 @@ import Unison.Auth.Tokens qualified as AuthN 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 (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..)) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.UCMVersion (UCMVersion) -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.Runtime qualified as Runtime import Unison.Codebase.Verbosity (Verbosity, isSilent) import Unison.Codebase.Verbosity qualified as Verbosity @@ -69,10 +66,11 @@ import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser) import Unison.CommandLine.Welcome (asciiartUnison) +import Unison.Core.Project (ProjectBranchName, ProjectName (..)) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal -import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous), ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous)) import Unison.Runtime.Interface qualified as RTI import Unison.Server.Backend qualified as Backend import Unison.Server.CodebaseServer qualified as Server @@ -111,8 +109,7 @@ data UcmLine -- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>). data UcmContext - = UcmContextLooseCode Path.Absolute - | UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) + = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) data APIRequest = GetRequest Text @@ -136,9 +133,7 @@ instance Show UcmLine where UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt UcmComment txt -> "--" ++ Text.unpack txt where - showContext = \case - UcmContextLooseCode path -> show path - UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch) + showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch) instance Show Stanza where show s = (<> "\n") . Text.unpack . CMark.nodeToCommonmark [] Nothing $ stanzaToNode s @@ -194,19 +189,20 @@ type TranscriptRunner = withTranscriptRunner :: forall m r. (UnliftIO.MonadUnliftIO m) => + Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} -> Verbosity -> UCMVersion -> FilePath -> Maybe FilePath -> (TranscriptRunner -> m r) -> m r -withTranscriptRunner verbosity ucmVersion nrtp configFile action = do +withTranscriptRunner isTest verbosity ucmVersion nrtp configFile action = do withRuntimes nrtp \runtime sbRuntime nRuntime -> withConfig \config -> do action \transcriptName transcriptSrc (codebaseDir, codebase) -> do Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase \baseUrl -> do let parsed = parse transcriptName transcriptSrc result <- for parsed \stanzas -> do - liftIO $ run verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl) + liftIO $ run isTest verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl) pure $ join @(Either TranscriptError) result where withRuntimes :: @@ -231,6 +227,7 @@ withTranscriptRunner verbosity ucmVersion nrtp configFile action = do (\(config, _cancelConfig) -> action (Just config)) run :: + Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} -> Verbosity -> FilePath -> [Stanza] -> @@ -242,9 +239,13 @@ run :: UCMVersion -> Text -> IO (Either TranscriptError Text) -run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try $ Ki.scoped \scope -> do +run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try do httpManager <- HTTP.newManager HTTP.defaultManagerSettings - let initialPath = Path.absoluteEmpty + (initialPP, emptyCausalHashId) <- Codebase.runTransaction codebase do + (_, emptyCausalHashId) <- Codebase.emptyCausalHash + initialPP <- Codebase.expectCurrentProjectPath + pure (initialPP, emptyCausalHashId) + unless (isSilent verbosity) . putPrettyLn $ Pretty.lines [ asciiartUnison, @@ -252,11 +253,6 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion "Running the provided transcript file...", "" ] - initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash - rootVar <- newEmptyTMVarIO - void $ Ki.fork scope do - root <- Codebase.getRootBranch codebase - atomically $ putTMVar rootVar root mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey credMan <- AuthN.newCredentialManager let tokenProvider :: AuthN.TokenProvider @@ -340,15 +336,11 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion liftIO (output ("\n" <> show p)) awaitInput p@(UcmCommand context lineTxt) -> do - curPath <- Cli.getCurrentPath + curPath <- Cli.getCurrentProjectPath -- We're either going to run the command now (because we're in the right context), else we'll switch to -- the right context first, then run the command next. maybeSwitchCommand <- case context of - UcmContextLooseCode path -> - if curPath == path - then pure Nothing - else pure $ Just (SwitchBranchI (Path.absoluteToPath' path)) UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do Project {projectId, name = projectName} <- Q.loadProjectByName projectName @@ -363,12 +355,12 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion Nothing -> do branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom) let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName} - Q.insertProjectBranch projectBranch + Q.insertProjectBranch "Branch Created" emptyCausalHashId projectBranch pure projectBranch Just projBranch -> pure projBranch let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId pure - if curPath == ProjectUtils.projectBranchPath projectAndBranchIds + if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds then Nothing else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName))) case maybeSwitchCommand of @@ -381,7 +373,9 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion args -> do liftIO (output ("\n" <> show p <> "\n")) numberedArgs <- use #numberedArgs - liftIO (parseInput codebase curPath numberedArgs patternMap args) >>= \case + PP.ProjectAndBranch projId branchId <- PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack + let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId + liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args) >>= \case -- invalid command is treated as a failure Left msg -> do liftIO $ writeIORef hasErrors True @@ -549,7 +543,8 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion sandboxedRuntime = sbRuntime, nativeRuntime = nRuntime, serverBaseUrl = Nothing, - ucmVersion + ucmVersion, + isTranscriptTest = isTest } let loop :: Cli.LoopState -> IO Text @@ -571,7 +566,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion texts <- readIORef out pure $ Text.concat (Text.pack <$> toList (texts :: Seq String)) - loop (Cli.loopState0 initialRootCausalHash rootVar initialPath) + loop (Cli.loopState0 (PP.toIds initialPP)) transcriptFailure :: IORef (Seq String) -> Text -> IO b transcriptFailure out msg = do @@ -600,9 +595,8 @@ ucmLine = ucmCommand <|> ucmComment P.try do contextString <- P.takeWhile1P Nothing (/= '>') context <- - case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of - (Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch)) - (Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs) + case (tryFrom @Text contextString) of + (Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch)) _ -> fail "expected project/branch or absolute path" void $ lineToken $ word ">" pure context diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index b10dbd5aec0..168e2648945 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -12,6 +12,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) @@ -27,12 +28,11 @@ 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.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 @@ -42,7 +42,6 @@ import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as IPs 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) @@ -78,8 +77,9 @@ watchFileSystem q dir = do parseInput :: Codebase IO Symbol Ann -> - -- | Current path from root - Path.Absolute -> + -- | Current location + PP.ProjectPath -> + IO (Branch.Branch IO) -> -- | Numbered arguments NumberedArgs -> -- | Input Pattern Map @@ -89,10 +89,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 (InputPattern.Arguments, 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 "" @@ -101,7 +102,7 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let expandedNumbers :: InputPattern.Arguments expandedNumbers = foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) 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 @@ -169,8 +170,8 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) -fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do +fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) +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 @@ -191,7 +192,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch - options <- liftIO $ getOptions codebase projCtx currentBranch + 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/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index 7e0a0682aca..116dbb60e7b 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -2,9 +2,9 @@ module Unison.CommandLine.BranchRelativePath ( BranchRelativePath (..), parseBranchRelativePath, branchRelativePathParser, - ResolvedBranchRelativePath (..), parseIncrementalBranchRelativePath, IncrementalBranchRelativePath (..), + toText, ) where @@ -14,10 +14,9 @@ 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.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project qualified as Project @@ -25,8 +24,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: @@ -37,72 +39,56 @@ data BranchRelativePath -- Specifying only a project is not allowed. -- -- >>> parseBranchRelativePath "foo" --- Right (LoosePath foo) +-- Right (UnqualifiedPath foo) -- >>> parseBranchRelativePath "foo/bar:" --- Right (BranchRelative (This (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar")))) --- >>> parseBranchRelativePath "foo/bar:some.path" --- Right (BranchRelative (These (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar")) some.path)) --- >>> parseBranchRelativePath "/bar:some.path" --- Right (BranchRelative (These (Left (UnsafeProjectBranchName "bar")) some.path)) --- >>> parseBranchRelativePath ":some.path" --- Right (BranchRelative (That some.path)) +-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .) +-- >>> parseBranchRelativePath "foo/bar:.some.path" +-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .some.path) +-- >>> parseBranchRelativePath "/bar:.some.path" +-- Right (BranchPathInCurrentProject (UnsafeProjectBranchName "bar") .some.path) +-- >>> parseBranchRelativePath ":.some.path" +-- Right (UnqualifiedPath .some.path) +-- +-- >>> parseBranchRelativePath ".branch" +-- Right (UnqualifiedPath .branch) parseBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) BranchRelativePath parseBranchRelativePath str = case Megaparsec.parse branchRelativePathParser "" (Text.pack str) of 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.toText' $ Path.RelativePath' path) - ) - These eitherProj path -> - Text.Builder.run - ( Text.Builder.text (eitherProjToText eitherProj) - <> Text.Builder.char ':' - <> Text.Builder.text (Path.toText' $ Path.RelativePath' 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) - | PathRelativeToCurrentBranch Path.Relative + IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Absolute) + | PathRelativeToCurrentBranch Path.Absolute deriving stock (Show) -- | @@ -158,9 +144,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 = @@ -180,28 +166,29 @@ 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 pathRelativeToCurrentBranch = do _ <- Megaparsec.char ':' - p <- relPath + p <- absPath 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 = do + absPath :: Megaparsec.Parsec Void Text Path.Absolute + absPath = 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 + 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 @@ -234,16 +221,20 @@ 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.AbsolutePath' 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) + +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/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 39e1fd00a37..a317c004e5b 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 @@ -48,6 +47,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 +73,9 @@ haskelineTabComplete :: Map String IP.InputPattern -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> 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 +84,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. @@ -101,7 +101,7 @@ noCompletions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [System.Console.Haskeline.Completion.Completion] noCompletions _ _ _ _ = pure [] @@ -141,11 +141,11 @@ completeWithinNamespace :: NESet CompletionType -> -- | The portion of this are that the user has already typed. String -> - Path.Absolute -> + PP.ProjectPath -> 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 + b <- Codebase.getShallowBranchAtProjectPath queryProjectPath currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib @@ -168,8 +168,8 @@ completeWithinNamespace compTypes query currentPath = do queryPathPrefix :: Path.Path' querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) - absQueryPath :: Path.Absolute - absQueryPath = Path.resolve currentPath queryPathPrefix + queryProjectPath :: PP.ProjectPath + 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 [] @@ -274,35 +274,35 @@ parseLaxPath'Query txt = -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: String -> - Path.Absolute -> -- Current path + 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 -> - Path.Absolute -> -- Current path + 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 -> - Path.Absolute -> -- Current path + 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 -> - Path.Absolute -> -- Current path + PP.ProjectPath -> 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.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 a6f23f2dbf1..37fdff8b181 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.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 -> ProjectContext -> 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,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 ^. #project . #projectId) 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 f7d5547073c..cc628559e66 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -28,7 +28,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) -import Unison.Codebase.Path as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude import Unison.Util.ColorText qualified as CT @@ -87,7 +87,7 @@ data ArgumentType = ArgumentType String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPath -> m [Line.Completion], -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if -- available. @@ -166,14 +166,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 @@ -188,14 +188,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 1c8f5a99018..e17abc061ab 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -119,7 +119,10 @@ module Unison.CommandLine.InputPatterns upgradeCommitInputPattern, view, viewGlobal, - viewReflog, + deprecatedViewRootReflog, + branchReflog, + projectReflog, + globalReflog, -- * Misc formatStructuredArgument, @@ -136,7 +139,6 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens (preview, review) import Control.Lens.Cons qualified as Cons import Data.Bitraversable (bitraverse) import Data.List (intercalate) @@ -168,14 +170,13 @@ 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 -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, 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) @@ -185,6 +186,8 @@ import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH @@ -213,7 +216,6 @@ import Unison.Project Semver, branchWithOptionalProjectParser, ) -import Unison.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Referent qualified as Referent import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend @@ -249,8 +251,14 @@ 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 (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name) + BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' 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 = @@ -378,15 +386,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 - (\str -> maybe (Left $ expectedButActually' "a path or project branch" str) pure $ parseLooseCodeOrProject str) - \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 = @@ -481,8 +480,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' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg @@ -499,27 +498,35 @@ 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' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') 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' $ Path.prefixNameIfRel (Path.AbsolutePath' 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 :: +-- | TODO: Maybe remove? +_handleBranchIdOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) -handleBranchIdOrProjectArg = +_handleBranchIdOrProjectArg = either (\str -> maybe (Left $ expectedButActually' "a branch" str) pure $ branchIdOrProject str) \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' $ Path.prefixNameIfRel (Path.AbsolutePath' 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' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.ProjectBranch pb -> pure $ That pb otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType where branchIdOrProject :: @@ -540,19 +547,21 @@ handleBranchIdOrProjectArg = (Right bid, Left _) -> Just (This bid) (Right bid, Right pr) -> Just (These bid pr) -handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) Input.BranchId2 handleBranchId2Arg = either Input.parseBranchId2 \case SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash - SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path - SA.Name name -> pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' 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 @@ -560,13 +569,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.NameWithBranchPrefix (Right prefix) name -> - pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path + SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> + pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' 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' @@ -598,8 +609,8 @@ handleHashQualifiedSplit'Arg = \case SA.Name name -> pure $ Path.hqSplitFromName' name 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' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname SA.ShallowListEntry prefix entry -> pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -621,8 +632,8 @@ handleHashQualifiedSplitArg = pure $ Path.hqSplitFromName' name 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 $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry sr@(SA.SearchResult mpath result) -> @@ -644,8 +655,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' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname) SA.ShallowListEntry prefix entry -> pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -666,11 +677,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 $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name + SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name + SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' 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 . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname SA.ShallowListEntry prefix entry -> pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry @@ -694,11 +705,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 (\str -> maybe (Left $ expectedButActually' "a target to push to" str) pure $ parsePushTarget str) - $ 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 target to push to" otherNumArg @@ -708,11 +719,6 @@ handlePushSourceArg = either (\str -> maybe (Left $ expectedButActually' "a source to push from" str) pure $ parsePushSource str) \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' $ Path.prefixNameIfRel (Path.AbsolutePath' 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 @@ -1554,7 +1560,7 @@ deleteNamespaceForce = deleteNamespaceParser :: Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser insistence = \case [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> (Just <$> handleSplitArg p) args -> wrongArgsLength "exactly one argument" args renameBranch :: InputPattern @@ -1587,7 +1593,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) args -> wrongArgsLength "no more than one argument" args forkLocal :: InputPattern @@ -1663,8 +1669,8 @@ reset = ] ) \case - [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing - [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1) + [resetTo] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> pure Nothing + [resetTo, branchToReset] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> fmap pure (handleMaybeProjectBranchArg branchToReset) args -> wrongArgsLength "one or two arguments" args where config = @@ -2076,10 +2082,15 @@ mergeOldSquashInputPattern = <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", parse = \case + [src] -> + Input.MergeLocalBranchI + <$> handleBranchRelativePathArg src + <*> pure Nothing + <*> pure Branch.SquashMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.SquashMerge args -> wrongArgsLength "exactly two arguments" args } @@ -2112,25 +2123,19 @@ 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" ) ] ) ( \case [src] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> pure (This Path.relativeEmpty') + <$> handleBranchRelativePathArg src + <*> pure Nothing <*> pure Branch.RegularMerge [src, dest] -> Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest + <$> handleBranchRelativePathArg src + <*> (Just <$> handleBranchRelativePathArg dest) <*> pure Branch.RegularMerge args -> wrongArgsLength "one or two arguments" args ) @@ -2208,17 +2213,6 @@ mergeCommitInputPattern = args -> wrongArgsLength "no arguments" args } -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) - diffNamespace :: InputPattern diffNamespace = InputPattern @@ -2236,8 +2230,8 @@ diffNamespace = ] ) ( \case - [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after - [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) + [before, after] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> handleBranchId2Arg after + [before] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> pure (Right . UnqualifiedPath $ Path.currentPath) args -> wrongArgsLength "one or two arguments" args ) where @@ -2265,9 +2259,9 @@ mergeOldPreviewInputPattern = ] ) ( \case - [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty') + [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing [src, dest] -> - Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest + Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest) args -> wrongArgsLength "one or two arguments" args ) where @@ -2278,19 +2272,74 @@ mergeOldPreviewInputPattern = branchInclusion = AllBranches } -viewReflog :: InputPattern -viewReflog = +deprecatedViewRootReflog :: InputPattern +deprecatedViewRootReflog = InputPattern - "reflog" + "deprecated.root-reflog" [] I.Visible [] - "`reflog` lists the changes that have affected the root namespace" + ( "`deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of " + <> makeExample branchReflog [] + <> " which shows the reflog for the current project." + ) ( \case - [] -> pure Input.ShowReflogI + [] -> pure Input.ShowRootReflogI _ -> Left . P.string $ - I.patternName viewReflog ++ " doesn't take any arguments." + I.patternName deprecatedViewRootReflog ++ " doesn't take any arguments." + ) + +branchReflog :: InputPattern +branchReflog = + InputPattern + "branch.reflog" + ["reflog.branch", "reflog"] + I.Visible + [] + ( P.lines + [ "`branch.reflog` lists all the changes that have affected the current branch.", + "`branch.reflog /mybranch` lists all the changes that have affected /mybranch." + ] + ) + ( \case + [] -> pure $ Input.ShowProjectBranchReflogI Nothing + [branchRef] -> Input.ShowProjectBranchReflogI <$> (Just <$> handleMaybeProjectBranchArg branchRef) + _ -> Left (I.help branchReflog) + ) + +projectReflog :: InputPattern +projectReflog = + InputPattern + "project.reflog" + ["reflog.project"] + I.Visible + [] + ( P.lines + [ "`project.reflog` lists all the changes that have affected any branches in the current project.", + "`project.reflog myproject` lists all the changes that have affected any branches in myproject." + ] + ) + ( \case + [] -> pure $ Input.ShowProjectReflogI Nothing + [projectRef] -> Input.ShowProjectReflogI <$> (Just <$> handleProjectArg projectRef) + _ -> Left (I.help projectReflog) + ) + +globalReflog :: InputPattern +globalReflog = + InputPattern + "reflog.global" + [] + I.Visible + [] + ( P.lines + [ "`reflog.global` lists all recent changes across all projects and branches." + ] + ) + ( \case + [] -> pure $ Input.ShowGlobalReflogI + _ -> Left (I.help globalReflog) ) edit :: InputPattern @@ -3164,13 +3213,12 @@ 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 = \case [source0, name] -> - Input.BranchI . Input.BranchSourceI'LooseCodeOrProject - <$> handleLooseCodeOrProjectArg source0 + Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch + <$> handleMaybeProjectBranchArg source0 <*> handleMaybeProjectBranchArg name [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name args -> wrongArgsLength "one or two arguments" args @@ -3471,7 +3519,10 @@ validInputs = upgradeCommitInputPattern, view, viewGlobal, - viewReflog + deprecatedViewRootReflog, + branchReflog, + projectReflog, + globalReflog ] -- | A map of all command patterns by pattern name or alias. @@ -3553,7 +3604,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 pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp) in unionSuggestions [ projectAndOrBranchSuggestions config, namespaceSuggestions @@ -3579,8 +3630,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 } @@ -3639,14 +3690,14 @@ projectAndOrBranchSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + ProjectPath -> m [Line.Completion] -projectAndOrBranchSuggestions config inputStr codebase _httpClient path = 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 @@ -3667,12 +3718,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = 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 @@ -3680,16 +3731,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = 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 - (mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) - handleAmbiguousComplete :: (MonadIO m) => Text -> @@ -3699,14 +3746,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = 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 @@ -3780,28 +3823,28 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion] - handleBranchesComplete 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 pp = do + let projId = pp ^. #project . #projectId 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 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.toIds pp + projectToCompletion :: Sqlite.Project -> Completion projectToCompletion project = Completion @@ -3825,28 +3868,22 @@ handleBranchesComplete :: ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> - Path.Absolute -> + PP.ProjectPath -> m [Completion] -handleBranchesComplete config branchName codebase path = do +handleBranchesComplete config branchName codebase pp = 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 pp) do + Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (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.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] +filterBranches config pp 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 = pp ^. #branch . #branchId currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = @@ -3862,22 +3899,22 @@ branchRelativePathSuggestions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> -- Current path + PP.ProjectPath -> m [Line.Completion] -branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do +branchRelativePathSuggestions config inputStr codebase _httpClient pp = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of - BranchRelativePath.ProjectOrRelative _txt _path -> do - namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + BranchRelativePath.ProjectOrPath' _txt _path -> do + namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase pure (namespaceSuggestions ++ projectSuggestions) - BranchRelativePath.LooseCode _path -> - Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + BranchRelativePath.OnlyPath' _path -> + 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 currentPath + Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp Just projectName -> do branches <- Codebase.runTransaction codebase do @@ -3885,44 +3922,15 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config currentPath) do + fmap (filterBranches config pp) 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 (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath + BranchRelativePath.PathRelativeToCurrentBranch absPath -> Codebase.runTransaction codebase do + map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.AbsolutePath' absPath) pp 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 - currentProjectId <- MaybeT (pure mayCurrentProjectId) - 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 "" (Text.unpack . Path.toText' . Path.RelativePath') mpath) - branchPath + map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp where - (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of - LooseCodePath {} -> (Nothing, Nothing) - ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) - projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = Completion @@ -4047,12 +4055,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/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 451ec731ba7..914581664ba 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -6,10 +6,13 @@ 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 +import Data.List.NonEmpty qualified as NEL +import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Data.Text.IO qualified as Text import Ki qualified @@ -18,24 +21,21 @@ import System.Console.Haskeline qualified as Line 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.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 qualified as Branch +import Unison.Codebase.Branch (Branch) 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 import Unison.CommandLine.Completion (haskelineTabComplete) @@ -46,7 +46,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) @@ -60,10 +59,11 @@ import UnliftIO.STM getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> + IO (Branch IO) -> NumberedArgs -> IO Input -getUserInput codebase authHTTPClient currentPath numberedArgs = +getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = Line.runInputT settings (haskelineCtrlCHandling go) @@ -78,23 +78,7 @@ 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 promptString = P.prettyProjectPath pp let fullPrompt = P.toANSI 80 (promptString <> fromString prompt) line <- Line.getInputLine fullPrompt case line of @@ -102,7 +86,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 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. @@ -126,12 +110,20 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = historyFile = Just ".unisonHistory", autoAddHistory = False } - tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath + 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 -> Welcome.Welcome -> - Path.Absolute -> + PP.ProjectPathIds -> Config -> [Either Event Input] -> Runtime.Runtime Symbol -> @@ -140,38 +132,18 @@ main :: Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> UCMVersion -> - (CausalHash -> STM ()) -> - (Path.Absolute -> STM ()) -> + (PP.ProjectPathIds -> IO ()) -> ShouldWatchFiles -> IO () -main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do - rootVar <- newEmptyTMVarIO - initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash +main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion lspCheckForChanges shouldWatchFiles = Ki.scoped \scope -> do _ <- Ki.fork scope do - root <- Codebase.getRootBranch codebase - atomically do - -- Try putting the root, but if someone else as already written over the root, don't - -- overwrite it. - void $ tryPutTMVar rootVar root + -- Pre-load the project root in the background so it'll be ready when a command needs it. + projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch -- 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 initialRootCausalHash rootVar initialPath - Ki.fork_ scope do - let loop lastRoot = do - -- This doesn't necessarily notify on _every_ update, but the LSP only needs the - -- most recent version at any given time, so it's fine to skip some intermediate - -- versions. - currentRoot <- atomically do - currentRoot <- readTMVar rootVar - guard $ Just currentRoot /= lastRoot - notifyBranchChange (Branch.headHash currentRoot) - pure (Just currentRoot) - loop currentRoot - loop Nothing + let initialState = Cli.loopState0 ppIds eventQueue <- Q.newIO initialInputsRef <- newIORef $ Welcome.run welcome ++ initialInputs pageOutput <- newIORef True @@ -187,10 +159,14 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod getInput loopState = do currentEcho <- hGetEcho stdin liftIO $ restoreEcho currentEcho + let PP.ProjectAndBranch projId branchId = PP.toProjectAndBranch $ NonEmpty.head loopState.projectPathStack + let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId + pp <- loopStateProjectPath codebase loopState getUserInput codebase authHTTPClient - (loopState ^. #currentPath) + pp + getProjectRoot (loopState ^. #numberedArgs) let loadSourceFile :: Text -> IO Cli.LoadSourceResult loadSourceFile fname = @@ -258,7 +234,8 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod sandboxedRuntime = sbRuntime, nativeRuntime = nRuntime, serverBaseUrl, - ucmVersion + ucmVersion, + isTranscriptTest = False } (onInterrupt, waitForInterrupt) <- buildInterruptHandler @@ -267,6 +244,9 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod -- Handle inputs until @HaltRepl@, staying in the loop on Ctrl+C or synchronous exception. let loop0 :: Cli.LoopState -> IO () loop0 s0 = do + -- It's always possible the previous command changed the branch head, so tell the LSP to check if the current + -- path or project has changed. + lspCheckForChanges (NEL.head $ Cli.projectPathStack s0) let step = do input <- awaitInput s0 (!result, resultState) <- Cli.runCli env s0 (HandleInput.loop input) @@ -284,7 +264,6 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod 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) case result of Cli.Success () -> loop0 s1 Cli.Continue -> loop0 s1 diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d04a8aa4b34..9ff7158fed5 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -37,14 +37,15 @@ import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) +import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD import Unison.Cli.MergeTypes (MergeSourceAndTarget (..)) import Unison.Cli.Pretty -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ServantClientUtils qualified as ServantClientUtils import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) +import Unison.Codebase.Editor.Input (BranchIdG (..)) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output ( CreatedProjectBranchFrom (..), @@ -60,15 +61,12 @@ 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 import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) 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 +89,6 @@ import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..)) 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 @@ -173,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 -> @@ -227,12 +224,14 @@ notifyNumbered = \case <> "to run the tests." <> "Or you can use" <> IP.makeExample' IP.undo - <> " or" - <> IP.makeExample' IP.viewReflog - <> " to undo the results of this merge." + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog + <> " with " + <> IP.makeExample' IP.reset + <> " to reset to a previous state." ] ) - (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput) + (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput) ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput -> first ( \p -> @@ -254,12 +253,12 @@ notifyNumbered = \case <> "to run the tests." <> "Or you can use" <> IP.makeExample' IP.undo - <> " or" - <> IP.makeExample' IP.viewReflog + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog <> " 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 -> @@ -269,7 +268,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]) @@ -474,7 +473,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) @@ -514,10 +513,10 @@ 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') $ + ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyProjectPath path') $ List.intersperse spacer (externalDepsTable externalDependencies), numberedArgs ) @@ -558,16 +557,17 @@ notifyNumbered = \case & Set.toList & fmap (\name -> formatNum (getNameNumber name) <> prettyName name) & P.lines + ShowProjectBranchReflog now moreToShow entries -> displayProjectBranchReflogEntries now moreToShow entries where - absPathToBranchId = Right + absPathToBranchId = BranchAtPath undoTip :: P.Pretty P.ColorText undoTip = tip $ "You can use" <> IP.makeExample' IP.undo - <> "or" - <> IP.makeExample' IP.viewReflog + <> " or use a hash from " + <> IP.makeExample' IP.branchReflog <> "to undo this change." notifyUser :: FilePath -> Output -> IO Pretty @@ -603,13 +603,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 $ @@ -802,7 +802,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 @@ -820,9 +820,13 @@ notifyUser dir = \case DeleteEverythingConfirmation -> pure . P.warnCallout . P.lines $ [ "Are you sure you want to clear away everything?", - "You could use " - <> IP.makeExample' IP.projectCreate - <> " to switch to a new project instead." + P.wrap + ( "You could use " + <> IP.makeExample' IP.projectCreate + <> " to switch to a new project instead," + <> " or delete the current branch with " + <> IP.makeExample' IP.deleteBranch + ) ] DeleteBranchConfirmation _uniqueDeletions -> error "todo" -- let @@ -1330,9 +1334,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 $ @@ -1482,9 +1486,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 HelpMessage pat -> pure $ IP.showPatternHelp pat @@ -1539,11 +1543,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 @@ -1605,10 +1604,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 @@ -2084,16 +2080,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 temp -> pure $ P.lines $ @@ -2176,39 +2162,16 @@ notifyUser dir = \case <> "Synhash tokens: " <> P.text filename -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 @@ -2217,27 +2180,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 @@ -2251,21 +2193,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 @@ -2463,17 +2390,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)] -> @@ -3633,3 +3549,44 @@ listDependentsOrDependencies ppe labelStart label lds types terms = P.indentN 2 . P.numberedListFrom (length types) $ c . prettyHashQualified <$> terms ] c = P.syntaxToColor + +displayProjectBranchReflogEntries :: + Maybe UTCTime -> + E.MoreEntriesThanShown -> + [ProjectReflog.Entry Project ProjectBranch (CausalHash, ShortCausalHash)] -> + (Pretty, NumberedArgs) +displayProjectBranchReflogEntries _ _ [] = + (P.warnCallout "The reflog is empty", mempty) +displayProjectBranchReflogEntries mayNow _ entries = + let (entryRows, numberedArgs) = foldMap renderEntry entries + rendered = + P.lines + [ header, + "", + P.numberedColumnNHeader (["Branch"] <> Monoid.whenM (isJust mayNow) ["When"] <> ["Hash", "Description"]) entryRows + ] + in (rendered, numberedArgs) + where + header = + P.lines + [ P.wrap $ + "Below is a record of recent changes, you can use " + <> IP.makeExample IP.reset ["#abcdef"] + <> " to reset the current branch to a previous state.", + "", + tip $ "Use " <> IP.makeExample IP.diffNamespace ["1", "7"] <> " to compare between points in history." + ] + renderEntry :: ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash) -> ([[Pretty]], NumberedArgs) + renderEntry ProjectReflog.Entry {time, project, branch, toRootCausalHash = (toCH, toSCH), reason} = + ( [ [prettyProjectAndBranchName $ ProjectAndBranch project.name branch.name] + <> ( mayNow + & foldMap (\now -> [prettyHumanReadableTime now time]) + ) + <> [P.blue (prettySCH toSCH), P.text $ truncateReason reason] + ], + [SA.Namespace toCH] + ) + truncateReason :: Text -> Text + truncateReason txt = case Text.splitAt 60 txt of + (short, "") -> short + (short, _) -> short <> "..." diff --git a/unison-cli/src/Unison/LSP.hs b/unison-cli/src/Unison/LSP.hs index 867a08ed1ec..71638809565 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) @@ -47,6 +46,7 @@ import Unison.LSP.NotificationHandlers qualified as Notifications import Unison.LSP.Orphans () import Unison.LSP.Types import Unison.LSP.UCMWorker (ucmWorker) +import Unison.LSP.Util.Signal (Signal) import Unison.LSP.VFS qualified as VFS import Unison.Parser.Ann import Unison.Prelude @@ -61,8 +61,13 @@ 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 -> + Signal PP.ProjectPathIds -> + IO () +spawnLsp lspFormattingConfig codebase runtime signal = ifEnabled . TCP.withSocketsDo $ do lspPort <- getLspPort UnliftIO.handleIO (handleFailure lspPort) $ do @@ -82,7 +87,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 signal) where handleFailure :: String -> IOException -> IO () handleFailure lspPort ioerr = @@ -113,16 +118,15 @@ serverDefinition :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + Signal PP.ProjectPathIds -> ServerDefinition Config -serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath = +serverDefinition lspFormattingConfig vfsVar codebase runtime scope signal = 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 signal, staticHandlers = lspStaticHandlers lspFormattingConfig, interpretHandler = lspInterpretHandler, options = lspOptions @@ -134,12 +138,11 @@ lspDoInitialize :: Codebase IO Symbol Ann -> Runtime Symbol -> Ki.Scope -> - STM CausalHash -> - STM (Path.Absolute) -> + Signal PP.ProjectPathIds -> 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 signal lspContext _initMsg = do checkedFilesVar <- newTVarIO mempty dirtyFilesVar <- newTVarIO mempty ppedCacheVar <- newEmptyTMVarIO @@ -152,13 +155,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 signal) 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 ddd7fc477c6..9e7a5d632a0 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -78,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 @@ -91,7 +91,7 @@ checkFile doc = runMaybeT do let parsingEnv = Parser.ParsingEnv { uniqueNames = uniqueName, - uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath, + uniqueTypeGuid = Cli.loadUniqueTypeGuid pp, 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 48e46d80285..ebba4b1a81c 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 c5fe0e9a958..b368e915ef0 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 d404bc6d198..713ce207f60 100644 --- a/unison-cli/src/Unison/LSP/UCMWorker.hs +++ b/unison-cli/src/Unison/LSP/UCMWorker.hs @@ -1,19 +1,18 @@ module Unison.LSP.UCMWorker where -import Control.Monad (guard) -import Control.Monad.State (liftIO) -import Control.Monad.Reader.Class (ask) -import Data.Functor (void) -import U.Codebase.HashTags +import Control.Monad.Reader 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.Debug qualified as Debug +import Unison.Codebase.ProjectPath (ProjectPath) +import Unison.Codebase.ProjectPath qualified as PP import Unison.LSP.Completion import Unison.LSP.Types +import Unison.LSP.Util.Signal (Signal) +import Unison.LSP.Util.Signal qualified as Signal 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 @@ -27,42 +26,43 @@ ucmWorker :: TMVar PrettyPrintEnvDecl -> TMVar Names -> TMVar (NameSearch Sqlite.Transaction) -> - TMVar Path.Absolute -> - STM CausalHash -> - STM Path.Absolute -> + TMVar ProjectPath -> + Signal PP.ProjectPathIds -> Lsp () -ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = 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 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 currentNamesVar currentNames - writeTMVar ppedVar pped - writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames) - -- Re-check everything with the new names and ppe - VFS.markAllFilesDirty - atomically do - 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) - Debug.debugLogM Debug.LSP "LSP Change detected" - loop latest - (rootBranch, currentPath) <- atomically $ do - rootBranch <- getLatestRoot - currentPath <- getLatestPath - pure (rootBranch, currentPath) - loop (rootBranch, currentPath) +ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar changeSignal = do + signalChanges <- Signal.subscribe changeSignal + loop signalChanges Nothing where + loop :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp a + loop signalChanges currentBranch = do + Env {codebase, completionsVar} <- ask + getChanges signalChanges currentBranch >>= \case + (_newPP, Nothing) -> loop signalChanges currentBranch + (newPP, Just newBranch) -> do + let newBranch0 = Branch.head newBranch + let newNames = Branch.toNames newBranch0 + hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength + let pped = PPED.makePPED (PPE.hqNamer hl newNames) (PPE.suffixifyByHash newNames) + atomically $ do + writeTMVar currentPathVar newPP + writeTMVar currentNamesVar newNames + writeTMVar ppedVar pped + writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl newNames) + -- Re-check everything with the new names and ppe + VFS.markAllFilesDirty + atomically do + writeTMVar completionsVar (namesToCompletionTree newNames) + loop signalChanges (Just newBranch) + -- Waits for a possible change, then checks if there's actually any difference to the branches we care about. + -- If so, returns the new branch, otherwise Nothing. + getChanges :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp (ProjectPath, Maybe (Branch.Branch IO)) + getChanges signalChanges currentBranch = do + Env {codebase} <- ask + ppIds <- atomically signalChanges + pp <- liftIO . Codebase.runTransaction codebase $ Codebase.resolveProjectPathIds ppIds + atomically $ writeTMVar currentPathVar pp + newBranch <- fmap (fromMaybe Branch.empty) . liftIO $ Codebase.getBranchAtProjectPath codebase pp + pure $ (pp, if Just newBranch == currentBranch then Nothing else Just newBranch) -- This is added in stm-2.5.1, remove this if we upgrade. writeTMVar :: TMVar a -> a -> STM () writeTMVar var a = diff --git a/unison-cli/src/Unison/LSP/Util/Signal.hs b/unison-cli/src/Unison/LSP/Util/Signal.hs new file mode 100644 index 00000000000..e06dfca111e --- /dev/null +++ b/unison-cli/src/Unison/LSP/Util/Signal.hs @@ -0,0 +1,74 @@ +-- | A transactional signal type. +-- Similar to a broadcast channel, but with better memory characteristics when you only care about the latest value. +-- +-- Allows multiple consumers to detect the latest value of a signal, and to be notified when the signal changes. +module Unison.LSP.Util.Signal + ( newSignalIO, + writeSignal, + writeSignalIO, + subscribe, + Signal, + ) +where + +import Control.Monad.STM qualified as STM +import Unison.Prelude +import UnliftIO.STM + +newtype Signal a = Signal (TVar (Maybe a, Int)) + +-- | Create a new signal with an optional initial value. +newSignalIO :: (MonadIO m) => Maybe a -> m (Signal a) +newSignalIO a = do + tvar <- newTVarIO (a, 0) + pure (Signal tvar) + +-- | Update the value of a signal, notifying all subscribers (even if the value didn't change) +writeSignal :: Signal a -> a -> STM () +writeSignal (Signal signalVar) a = do + (_, n) <- readTVar signalVar + writeTVar signalVar (Just a, succ n) + +-- | Update the value of a signal, notifying all subscribers (even if the value didn't change) +writeSignalIO :: (MonadIO m) => Signal a -> a -> m () +writeSignalIO signal a = liftIO $ STM.atomically (writeSignal signal a) + +-- | Subscribe to a signal, returning an STM action which will read the latest NEW value, +-- after successfully reading a new value, subsequent reads will retry until there's a new value written to the signal. +-- +-- Each independent reader should have its own subscription. +-- +-- >>> signal <- newSignalIO (Just "initial") +-- >>> subscriber1 <- subscribe signal +-- >>> subscriber2 <- subscribe signal +-- >>> -- Should return the initial value +-- >>> atomically (optional subscriber1) +-- >>> -- Should retry, since the signal hasn't changed. +-- >>> atomically (optional subscriber1) +-- >>> writeSignalIO signal "new value" +-- >>> -- Each subscriber should return the newest value +-- >>> ("sub1",) <$> atomically (optional subscriber1) +-- >>> ("sub2",) <$> atomically (optional subscriber2) +-- >>> -- Both should now retry +-- >>> ("sub1",) <$> atomically (optional subscriber1) +-- >>> ("sub2",) <$> atomically (optional subscriber2) +-- Just "initial" +-- Nothing +-- ("sub1",Just "new value") +-- ("sub2",Just "new value") +-- ("sub1",Nothing) +-- ("sub2",Nothing) +subscribe :: (MonadIO m) => Signal a -> m (STM a) +subscribe (Signal signalVar) = do + (_, n) <- readTVarIO signalVar + -- Start with a different n, so the subscriber will trigger on its first read. + latestNVar <- newTVarIO (pred n) + pure $ do + (mayA, newN) <- readTVar signalVar + latestN <- readTVar latestNVar + guard (newN /= latestN) + writeTVar latestNVar newN + -- Retry until we have a value. + case mayA of + Nothing -> STM.retry + Just a -> pure a diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index f9b8e02c070..ca74688fd6c 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -25,7 +25,6 @@ import ArgParse ) import Compat (defaultInterruptHandler, withInterruptHandler) import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar) -import Control.Concurrent.STM import Control.Exception (displayException, evaluate) import Data.ByteString.Lazy qualified as BL import Data.Configurator.Types (Config) @@ -48,6 +47,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, @@ -60,8 +60,8 @@ import System.IO.CodePage (withCP65001) import System.IO.Error (catchIOError) 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 @@ -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 @@ -80,7 +81,9 @@ import Unison.CommandLine.Main qualified as CommandLine import Unison.CommandLine.Types qualified as CommandLine import Unison.CommandLine.Welcome (CodebaseInitStatus (..)) import Unison.CommandLine.Welcome qualified as Welcome +import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) import Unison.LSP qualified as LSP +import Unison.LSP.Util.Signal qualified as Signal import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal qualified as PT @@ -172,10 +175,9 @@ main version = do getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - let noOpRootNotifier _ = pure () - let noOpPathNotifier _ = pure () + let noOpCheckForChanges _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -186,10 +188,9 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes - noOpRootNotifier - noOpPathNotifier + noOpCheckForChanges CommandLine.ShouldNotWatchFiles Run (RunFromPipe mainName) args -> do e <- safeReadUtf8StdIn @@ -199,10 +200,9 @@ main version = do getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do let fileEvent = Input.UnisonFileChanged (Text.pack "") contents - let noOpRootNotifier _ = pure () - let noOpPathNotifier _ = pure () + let noOpCheckForChanges _ = pure () let serverUrl = Nothing - let startPath = Nothing + startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath launch version currentDir @@ -213,10 +213,9 @@ main version = do theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl - startPath + (PP.toIds startProjectPath) initRes - noOpRootNotifier - noOpPathNotifier + noOpCheckForChanges CommandLine.ShouldNotWatchFiles Run (RunCompiled file) args -> BL.readFile file >>= \bs -> @@ -287,33 +286,38 @@ 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 - segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace - pure (Path.Absolute (Path.fromList segments)) - Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath - rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash) - rootCausalHashVar <- newTVarIO rootCausalHash - pathVar <- newTVarIO startingPath - let notifyOnRootChanges :: CausalHash -> STM () - notifyOnRootChanges b = do - writeTVar rootCausalHashVar b - let notifyOnPathChanges :: Path.Absolute -> STM () - notifyOnPathChanges = writeTVar pathVar + 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 + currentPP <- Codebase.runTransaction theCodebase do + PP.toIds <$> Codebase.expectCurrentProjectPath + changeSignal <- Signal.newSignalIO (Just currentPP) + let lspCheckForChanges pp = Signal.writeSignalIO changeSignal pp -- 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 changeSignal Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do @@ -324,7 +328,7 @@ main version = do [ "I've started the Codebase API server at", P.text $ Server.urlFor Server.Api baseUrl, "and the Codebase UI at", - P.text $ Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl + P.text $ Server.urlFor (Server.ProjectBranchUI (ProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main")) Path.absoluteEmpty Nothing) baseUrl ] PT.putPrettyLn $ P.string "Running the codebase manager headless with " @@ -347,10 +351,9 @@ main version = do theCodebase [] (Just baseUrl) - (Just startingPath) + (PP.toIds startingProjectPath) initRes - notifyOnRootChanges - notifyOnPathChanges + lspCheckForChanges shouldWatchFiles Exit -> do Exit.exitSuccess where @@ -422,7 +425,8 @@ runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles configFilePath <- getConfigFilePath mcodepath -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do - TR.withTranscriptRunner Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do + let isTest = False + TR.withTranscriptRunner isTest Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do for markdownFiles $ \(MarkdownFile fileName) -> do transcriptSrc <- readUtf8 fileName result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase) @@ -513,9 +517,6 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba ) when (not completed) $ Exit.exitWith (Exit.ExitFailure 1) -defaultInitialPath :: Path.Absolute -defaultInitialPath = Path.absoluteEmpty - launch :: Version -> FilePath -> @@ -526,13 +527,12 @@ 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 ()) -> + (PP.ProjectPathIds -> IO ()) -> 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 lspCheckForChanges shouldWatchFiles = do showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist let isNewCodebase = case initResult of CreatedCodebase -> NewlyCreatedCodebase @@ -542,7 +542,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU in CommandLine.main dir welcome - (fromMaybe defaultInitialPath mayStartingPath) + startingPath config inputs runtime @@ -551,8 +551,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU codebase serverBaseUrl ucmVersion - notifyRootChange - notifyPathChange + lspCheckForChanges shouldWatchFiles newtype MarkdownFile = MarkdownFile FilePath @@ -572,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.init + result <- CodebaseInit.withOpenOrCreateCodebase cbInit "main" initOptions SC.DoLock migrationStrategy \case cbInit@(CreatedCodebase, dir, _) -> do pDir <- prettyDir dir PT.putPrettyLn' "" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 8df14b8f99a..6ccf8939efa 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 1d14c322071..a53d14acbbc 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-cli/tests/Unison/Test/ClearCache.hs b/unison-cli/tests/Unison/Test/ClearCache.hs index 655bd6d91a8..20f5090f2fa 100644 --- a/unison-cli/tests/Unison/Test/ClearCache.hs +++ b/unison-cli/tests/Unison/Test/ClearCache.hs @@ -23,7 +23,7 @@ test = scope "clearWatchCache" $ c [i| ```ucm - .> alias.term ##Nat.+ + + scratch/main> alias.term ##Nat.+ + ``` ```unison > 1 + 1 @@ -38,7 +38,7 @@ test = scope "clearWatchCache" $ c [i| ```ucm - .> debug.clear-cache + scratch/main> debug.clear-cache ``` |] diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 712b6c083bd..ba541e49f8f 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -36,12 +36,10 @@ dummyEnv = undefined dummyLoopState :: Cli.LoopState dummyLoopState = Cli.LoopState - { currentPathStack = undefined, - lastInput = Nothing, - lastRunResult = Nothing, - lastSavedRootHash = undefined, + { projectPathStack = undefined, latestFile = Nothing, latestTypecheckedFile = Nothing, + lastInput = Nothing, numberedArgs = [], - root = undefined + lastRunResult = Nothing } diff --git a/unison-cli/tests/Unison/Test/Ucm.hs b/unison-cli/tests/Unison/Test/Ucm.hs index 54655cfe29a..7fdca8710b1 100644 --- a/unison-cli/tests/Unison/Test/Ucm.hs +++ b/unison-cli/tests/Unison/Test/Ucm.hs @@ -66,7 +66,8 @@ runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do let err e = fail $ "Parse error: \n" <> show e cbInit = case fmt of CodebaseFormat2 -> SC.init - TR.withTranscriptRunner Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $ \runner -> do + let isTest = True + TR.withTranscriptRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $ \runner -> do result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase) let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 1a896f4baea..4c64958f0e6 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -8,11 +8,6 @@ import EasyTest import Text.Megaparsec qualified as P import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), - ShareCodeserver (..), - ShareUserHandle (..), - WriteRemoteNamespace (..), - WriteShareRemoteNamespace (..), - pattern ReadShareLooseCode, ) import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path qualified as Path @@ -27,8 +22,7 @@ test = [ parserTests "repoPath" (UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof) - [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), - ("project", branchR (This "project")), + [ ("project", branchR (This "project")), ("/branch", branchR (That "branch")), ("project/branch", branchR (These "project" "branch")) ] @@ -36,8 +30,7 @@ test = parserTests "writeRemoteNamespace" (UriParser.writeRemoteNamespace <* P.eof) - [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), - ("project", branchW (This "project")), + [ ("project", branchW (This "project")), ("/branch", branchW (That "branch")), ("project/branch", branchW (These "project" "branch")) ] @@ -48,14 +41,6 @@ test = mkPath :: [Text] -> Path.Path mkPath = Path.fromList . fmap NameSegment -looseR :: Text -> [Text] -> ReadRemoteNamespace void -looseR user path = - ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path)) - -looseW :: Text -> [Text] -> WriteRemoteNamespace void -looseW user path = - WriteRemoteNamespaceShare (WriteShareRemoteNamespace DefaultCodeserver (ShareUserHandle user) (mkPath path)) - branchR :: These Text Text -> ReadRemoteNamespace (These ProjectName ProjectBranchName) branchR = ReadShare'ProjectBranch . \case @@ -63,9 +48,9 @@ branchR = That branch -> That (UnsafeProjectBranchName branch) These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch) -branchW :: These Text Text -> WriteRemoteNamespace (These ProjectName ProjectBranchName) +branchW :: These Text Text -> (These ProjectName ProjectBranchName) branchW = - WriteRemoteProjectBranch . \case + \case This project -> This (UnsafeProjectName project) That branch -> That (UnsafeProjectBranchName branch) These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 56a3394086e..5810df590fc 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -47,7 +47,8 @@ testBuilder :: Test () testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do - withTranscriptRunner Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do + let isTest = True + withTranscriptRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do for files \filePath -> do transcriptSrc <- readUtf8 filePath out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index dc7b8f2b816..b5a29cc4832 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 @@ -83,6 +82,7 @@ library Unison.Codebase.Editor.HandleInput.ProjectSwitch Unison.Codebase.Editor.HandleInput.Pull Unison.Codebase.Editor.HandleInput.Push + Unison.Codebase.Editor.HandleInput.Reflogs Unison.Codebase.Editor.HandleInput.ReleaseDraft Unison.Codebase.Editor.HandleInput.Run Unison.Codebase.Editor.HandleInput.RuntimeUtils @@ -141,6 +141,7 @@ library Unison.LSP.Queries Unison.LSP.Types Unison.LSP.UCMWorker + Unison.LSP.Util.Signal Unison.LSP.VFS Unison.Main Unison.Share.Codeserver diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 77a96a448a0..73070e7a1da 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/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index fe54c93d155..b3535aeb231 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, @@ -58,7 +58,6 @@ module Unison.Server.Backend renderDocRefs, docsForDefinitionName, normaliseRootCausalHash, - causalHashForProjectBranchName, -- * Unused, could remove? resolveRootBranchHash, @@ -101,16 +100,12 @@ 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 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 @@ -148,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) @@ -370,12 +364,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 :: @@ -700,14 +694,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 = @@ -987,16 +979,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 <- @@ -1005,47 +993,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?) -- @@ -1271,15 +1246,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/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 7ceef3c0fe5..fbb09b23107 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -84,6 +84,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 @@ -117,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 @@ -142,11 +141,8 @@ type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi type UnisonAndDocsAPI = UnisonLocalAPI :<|> OpenApiJSON :<|> Raw -type LooseCodeAPI = CodebaseServerAPI - type UnisonLocalAPI = ("projects" :> ProjectsAPI) - :<|> ("non-project-code" :> LooseCodeAPI) :<|> ("ucm" :> UCMAPI) type CodebaseServerAPI = @@ -234,9 +230,8 @@ data DefinitionReference deriving stock (Show) data Service - = LooseCodeUI Path.Absolute (Maybe DefinitionReference) - | -- (Project branch names, perspective within project, definition reference) - ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference) + = -- (Project branch names, perspective within project, definition reference) + ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference) | Api deriving stock (Show) @@ -295,14 +290,12 @@ data URISegment 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) 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 @@ -560,18 +553,6 @@ serveOpenAPI = pure openAPI hoistWithAuth :: forall api. (HasServer api '[]) => Proxy api -> ByteString -> ServerT api Handler -> ServerT (Authed api) Handler hoistWithAuth api expectedToken server token = hoistServer @api @Handler @Handler api (\h -> handleAuth expectedToken token *> h) server -serveLooseCode :: - Codebase IO Symbol Ann -> - 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) - serveProjectsCodebaseServerAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> @@ -587,35 +568,39 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do :<|> serveTypeSummaryEndpoint where projectAndBranchName = ProjectAndBranch projectName branchName - namespaceListingEndpoint _rootParam rel name = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name - namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth - - serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff - - serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query - - serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - - serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot codebase projectAndBranchName - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - -resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash + namespaceListingEndpoint rel name = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name + namespaceDetailsEndpoint namespaceName renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth + + serveDefinitionsEndpoint relativePath rawHqns renderWidth suff = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff + + serveFuzzyFindEndpoint relativePath limit renderWidth query = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query + + serveTermSummaryEndpoint shortHash mayName relativeTo renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth + + serveTypeSummaryEndpoint shortHash mayName relativeTo renderWidth = do + root <- resolveProjectRootHash codebase projectAndBranchName + 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 - mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.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 @@ -638,7 +623,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) @@ -684,7 +669,7 @@ serveUnisonLocal :: Server UnisonLocalAPI serveUnisonLocal env codebase rt = hoistServer (Proxy @UnisonLocalAPI) (backendHandler env) $ - serveProjectsAPI codebase rt :<|> serveLooseCode codebase rt :<|> (setCacheControl <$> ucmServer codebase) + serveProjectsAPI codebase rt :<|> (setCacheControl <$> ucmServer codebase) backendHandler :: BackendEnv -> Backend IO a -> Handler a backendHandler env m = diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index b1f5b03d52b..9c014a965f2 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/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 15972297f12..7d082b8149d 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -7,17 +7,12 @@ 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) @@ -39,7 +34,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.path") ) ] @@ -51,31 +46,11 @@ instance ToJSON Current where "path" .= path ] -serveCurrent :: MonadIO m => Codebase m v a -> Backend m Current +serveCurrent :: (MonadIO m) => Codebase m v a -> Backend m Current serveCurrent = lift . getCurrentProjectBranch -getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current +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 + pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath + let (PP.ProjectPath projName branchName path) = PP.toNames pp + pure $ Current (Just projName) (Just branchName) path 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 3de04b50545..93e36486789 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs @@ -67,7 +67,6 @@ 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 :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TermSummary @@ -98,11 +97,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 +110,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 +125,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 +149,6 @@ 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 :> QueryParam "relativeTo" Path.Path :> QueryParam "renderWidth" Width :> APIGet TypeSummary @@ -181,7 +179,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 6b6cc031ca5..cb05dc5d50d 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -46,7 +46,6 @@ import Unison.Util.Pretty (Width) type FuzzyFindAPI = "find" - :> QueryParam "rootBranch" SCH.ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "limit" Int :> QueryParam "renderWidth" Width @@ -141,18 +140,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 49a67357ea4..86cb6288d61 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs @@ -44,7 +44,6 @@ import Unison.Util.Pretty (Width) type DefinitionsAPI = "getDefinition" - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParams "names" (HQ.HashQualified Name) :> QueryParam "renderWidth" Width @@ -96,16 +95,6 @@ instance ToParam (QueryParam "namespace" Path.Path) where ) Normal -instance ToParam (QueryParam "rootBranch" ShortCausalHash) where - toParam _ = - DocQueryParam - "rootBranch" - ["#abc123"] - ( "The hash or hash prefix of the namespace root. " - <> "If left absent, the most recent root will be used." - ) - Normal - instance ToParam (QueryParams "names" (HQ.HashQualified Name)) where toParam _ = DocQueryParam @@ -120,15 +109,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 1ea65e553b7..c0e2d94841a 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -32,7 +32,6 @@ import Unison.Util.Pretty (Width) type NamespaceDetailsAPI = "namespaces" :> Capture "namespace" Path.Path - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "renderWidth" Width :> APIGet NamespaceDetails @@ -46,23 +45,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 b683131f404..c60357548d5 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs @@ -46,7 +46,6 @@ import Unison.Var (Var) type NamespaceListingAPI = "list" - :> QueryParam "rootBranch" ShortCausalHash :> QueryParam "relativeTo" Path.Path :> QueryParam "namespace" Path.Path :> APIGet NamespaceListing @@ -191,12 +190,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 -- @@ -216,7 +215,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 6a3421709dc..50ff77ee08c 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] diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 754931f8b19..5cafebdfc3e 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 45da44748d6..9b84c00601a 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 (..), @@ -751,111 +746,9 @@ instance FromJSON HashMismatchForEntity where <*> 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) - 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] diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index 7287a7ddba6..7caf8f80e06 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -1,14 +1,14 @@ This transcript verifies that the pretty-printer produces code that can be successfully parsed, for a variety of examples. Terms or types that fail to round-trip can be added to either `reparses-with-same-hash.u` or `reparses.u` as regression tests. ```ucm:hide -.> builtins.mergeio +scratch/main> builtins.mergeio lib.builtins +scratch/a1> builtins.mergeio lib.builtins +scratch/a2> builtins.mergeio lib.builtins ``` ```ucm:hide -.> copy.namespace builtin a1.lib.builtin -.> copy.namespace builtin a2.lib.builtin -.> load unison-src/transcripts-round-trip/reparses-with-same-hash.u -.a1> add +scratch/a1> load unison-src/transcripts-round-trip/reparses-with-same-hash.u +scratch/a1> add ``` ```unison @@ -16,45 +16,40 @@ x = () ``` ```ucm:hide -.a1> find +scratch/a1> find ``` So we can see the pretty-printed output: ```ucm -.a1> edit 1-1000 +scratch/a1> edit 1-1000 ``` ```ucm:hide -.a1> delete.namespace.force lib.builtin +scratch/a1> delete.namespace.force lib.builtins ``` ```ucm:hide -.a2> load +scratch/a2> load ``` ```ucm:hide -.a2> add -.a2> delete.namespace.force lib.builtin +scratch/a2> add +scratch/a2> delete.namespace.force lib.builtins ``` This diff should be empty if the two namespaces are equivalent. If it's nonempty, the diff will show us the hashes that differ. ```ucm:error -.> diff.namespace a1 a2 -``` - -```ucm:hide -.> undo -.> undo +scratch/main> diff.namespace /a1:. /a2:. ``` Now check that definitions in 'reparses.u' at least parse on round trip: ```ucm:hide -.a3> copy.namespace .builtin lib.builtin -.a3> load unison-src/transcripts-round-trip/reparses.u -.a3> add +scratch/a3> builtins.mergeio lib.builtins +scratch/a3> load unison-src/transcripts-round-trip/reparses.u +scratch/a3> add ``` This just makes 'roundtrip.u' the latest scratch file. @@ -64,37 +59,35 @@ x = () ``` ```ucm:hide -.a3> find +scratch/a3> find ``` ```ucm -.a3> edit 1-5000 +scratch/a3> edit 1-5000 ``` ```ucm:hide -.> move.namespace a3 a3_old -.a3> copy.namespace .builtin lib.builtin -.a3> load -.a3> add -.a3> delete.namespace.force lib.builtin -.a3_old> delete.namespace.force lib.builtin +scratch/a3_new> builtins.mergeio lib.builtins +scratch/a3_new> load +scratch/a3_new> add +scratch/a3> delete.namespace.force lib.builtins +scratch/a3_new> delete.namespace.force lib.builtins ``` These are currently all expected to have different hashes on round trip. ```ucm -.> diff.namespace a3 a3_old +scratch/main> diff.namespace /a3_new:. /a3:. ``` ## Other regression tests not covered by above -### Comment out builtins in the edit command +### Builtins should appear commented out in the edit command Regression test for https://github.com/unisonweb/unison/pull/3548 -```ucm:hide -.> alias.term ##Nat.+ plus -.> edit plus -.> load -.> undo +```ucm +scratch/regressions> alias.term ##Nat.+ plus +scratch/regressions> edit plus +scratch/regressions> load ``` diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 5230f3495fb..18b455b3048 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -20,7 +20,7 @@ x = () So we can see the pretty-printed output: ``` ucm -.a1> edit 1-1000 +scratch/a1> edit 1-1000 ☝️ @@ -771,7 +771,7 @@ a |> f = f a This diff should be empty if the two namespaces are equivalent. If it's nonempty, the diff will show us the hashes that differ. ``` ucm -.> diff.namespace a1 a2 +scratch/main> diff.namespace /a1:. /a2:. The namespaces are identical. @@ -785,7 +785,7 @@ x = () ``` ``` ucm -.a3> edit 1-5000 +scratch/a3> edit 1-5000 ☝️ @@ -820,7 +820,7 @@ sloppyDocEval = These are currently all expected to have different hashes on round trip. ``` ucm -.> diff.namespace a3 a3_old +scratch/main> diff.namespace /a3_new:. /a3:. Updates: @@ -831,7 +831,32 @@ These are currently all expected to have different hashes on round trip. ``` ## Other regression tests not covered by above -### Comment out builtins in the edit command +### Builtins should appear commented out in the edit command Regression test for https://github.com/unisonweb/unison/pull/3548 +``` ucm +scratch/regressions> alias.term ##Nat.+ plus + + Done. + +scratch/regressions> edit plus + + ☝️ + + I added 1 definitions to the top of scratch.u + + You can edit them there, then run `update` to replace the + definitions currently in this namespace. + +scratch/regressions> load + + Loading changes detected in scratch.u. + + I loaded scratch.u and didn't find anything. + +``` +``` unison:added-by-ucm scratch.u +-- builtin plus : ##Nat -> ##Nat -> ##Nat +``` + diff --git a/unison-src/transcripts-using-base/fix5129.md b/unison-src/transcripts-using-base/fix5129.md index ccdd8bee41e..a1e8ad3450d 100644 --- a/unison-src/transcripts-using-base/fix5129.md +++ b/unison-src/transcripts-using-base/fix5129.md @@ -1,5 +1,5 @@ ```ucm:hide -.> builtins.mergeio +scratch/main> builtins.mergeio lib.builtins ``` Checks for some bad type checking behavior. Some ability subtyping was diff --git a/unison-src/transcripts/add-run.md b/unison-src/transcripts/add-run.md index 3eeea7c0311..07fe99216db 100644 --- a/unison-src/transcripts/add-run.md +++ b/unison-src/transcripts/add-run.md @@ -123,7 +123,7 @@ main = '5 ``` ```ucm -.> run main -.> add.run .an.absolute.name -.> view .an.absolute.name +scratch/main> run main +scratch/main> add.run .an.absolute.name +scratch/main> view .an.absolute.name ``` diff --git a/unison-src/transcripts/add-run.output.md b/unison-src/transcripts/add-run.output.md index acf50c24d8f..76e52470c42 100644 --- a/unison-src/transcripts/add-run.output.md +++ b/unison-src/transcripts/add-run.output.md @@ -293,17 +293,17 @@ main = '5 ``` ``` ucm -.> run main +scratch/main> run main 5 -.> add.run .an.absolute.name +scratch/main> add.run .an.absolute.name ⍟ I've added these definitions: .an.absolute.name : Nat -.> view .an.absolute.name +scratch/main> view .an.absolute.name .an.absolute.name : Nat .an.absolute.name = 5 diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 4a20a354c2b..96b43c63a46 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -37,7 +37,8 @@ scratch/main> alias.many List.adjacentPairs List.all List.any List.chunk List.ch 14. List.tail : [a] -> Optional [a] 15. List.takeWhile : (a ->{𝕖} Boolean) -> [a] ->{𝕖} [a] - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. scratch/main> find-in mylib diff --git a/unison-src/transcripts/branch-relative-path.md b/unison-src/transcripts/branch-relative-path.md index 74298f4b2b3..49bd4863b3a 100644 --- a/unison-src/transcripts/branch-relative-path.md +++ b/unison-src/transcripts/branch-relative-path.md @@ -1,9 +1,3 @@ -```ucm:hide -scratch/main> builtins.merge -scratch/main> project.create-empty p0 -scratch/main> project.create-empty p1 -``` - ```unison foo = 5 foo.bar = 1 @@ -20,11 +14,11 @@ donk.bonk = 1 ```ucm p1/main> add -p1/main> fork p0/main: zzz +p1/main> fork p0/main:. zzz p1/main> find zzz -p1/main> fork p0/main:foo yyy +p1/main> fork p0/main:.foo yyy p1/main> find yyy -p0/main> fork p1/main: p0/main:p1 +p0/main> fork p1/main:. p0/main:.p1 p0/main> ls p1 p0/main> ls p1.zzz p0/main> ls p1.yyy diff --git a/unison-src/transcripts/branch-relative-path.output.md b/unison-src/transcripts/branch-relative-path.output.md index e9e33b5ad93..35592794af3 100644 --- a/unison-src/transcripts/branch-relative-path.output.md +++ b/unison-src/transcripts/branch-relative-path.output.md @@ -55,7 +55,7 @@ p1/main> add bonk : ##Nat donk.bonk : ##Nat -p1/main> fork p0/main: zzz +p1/main> fork p0/main:. zzz Done. @@ -65,7 +65,7 @@ p1/main> find zzz 2. zzz.foo.bar : ##Nat -p1/main> fork p0/main:foo yyy +p1/main> fork p0/main:.foo yyy Done. @@ -74,7 +74,7 @@ p1/main> find yyy 1. yyy.bar : ##Nat -p0/main> fork p1/main: p0/main:p1 +p0/main> fork p1/main:. p0/main:.p1 Done. diff --git a/unison-src/transcripts/bug-strange-closure.md b/unison-src/transcripts/bug-strange-closure.md index f2f805d682a..75c4064db3a 100644 --- a/unison-src/transcripts/bug-strange-closure.md +++ b/unison-src/transcripts/bug-strange-closure.md @@ -1,15 +1,15 @@ ```ucm:hide -.> builtins.mergeio -.> load unison-src/transcripts-using-base/doc.md.files/syntax.u +scratch/main> builtins.mergeio lib.builtins +scratch/main> load unison-src/transcripts-using-base/doc.md.files/syntax.u ``` We can display the guide before and after adding it to the codebase: ```ucm -.> display doc.guide -.> add -.> display doc.guide +scratch/main> display doc.guide +scratch/main> add +scratch/main> display doc.guide ``` But we can't display this due to a decompilation problem. @@ -19,10 +19,10 @@ rendered = Pretty.get (docFormatConsole doc.guide) ``` ```ucm -.> display rendered -.> add -.> display rendered -.> undo +scratch/main> display rendered +scratch/main> add +scratch/main> display rendered +scratch/main> undo ``` And then this sometimes generates a GHC crash "strange closure error" but doesn't seem deterministic. diff --git a/unison-src/transcripts/bug-strange-closure.output.md b/unison-src/transcripts/bug-strange-closure.output.md index ebd96be4a58..bad237d05fd 100644 --- a/unison-src/transcripts/bug-strange-closure.output.md +++ b/unison-src/transcripts/bug-strange-closure.output.md @@ -1,7 +1,7 @@ We can display the guide before and after adding it to the codebase: ``` ucm -.> display doc.guide +scratch/main> display doc.guide # Unison computable documentation @@ -199,7 +199,7 @@ We can display the guide before and after adding it to the codebase: rendered table. Some text More text Zounds! -.> add +scratch/main> add ⍟ I've added these definitions: @@ -212,7 +212,7 @@ We can display the guide before and after adding it to the codebase: otherElements : Doc2 sqr : Nat -> Nat -.> display doc.guide +scratch/main> display doc.guide # Unison computable documentation @@ -431,7 +431,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) ``` ``` ucm -.> display rendered +scratch/main> display rendered # Unison computable documentation @@ -629,13 +629,13 @@ rendered = Pretty.get (docFormatConsole doc.guide) rendered table. Some text More text Zounds! -.> add +scratch/main> add ⍟ I've added these definitions: rendered : Annotated () (Either SpecialForm ConsoleText) -.> display rendered +scratch/main> display rendered # Unison computable documentation @@ -833,7 +833,7 @@ rendered = Pretty.get (docFormatConsole doc.guide) rendered table. Some text More text Zounds! -.> undo +scratch/main> undo Here are the changes I undid diff --git a/unison-src/transcripts/cycle-update-5.md b/unison-src/transcripts/cycle-update-5.md deleted file mode 100644 index 60d283d55a6..00000000000 --- a/unison-src/transcripts/cycle-update-5.md +++ /dev/null @@ -1,34 +0,0 @@ -Not yet working: properly updating nameless implicit terms. - -```ucm:hide -scratch/main> builtins.merge -``` - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 1 - -pong : 'Nat -pong _ = !inner.ping + 2 -``` - -```ucm -scratch/main> add -``` - -Here we queue up an update by saving in a namespace where `inner.ping` and `pong` both have names, but then apply the -update in a namespace where only `ping` has a name. - -```unison -inner.ping : 'Nat -inner.ping _ = !pong + 3 -``` - -```ucm -.inner> update.old -scratch/main> view inner.ping -``` - -The bug here is that `inner.ping` still refers to `pong` by name. But if we properly identified the nameless (in the -context that the update was applied) `pong` as an implicit term to include in the new `ping`'s cycle, then `ping` would -be left referring to a nameless thing (namely, `pong`, but updated to refer to the new `ping`). diff --git a/unison-src/transcripts/cycle-update-5.output.md b/unison-src/transcripts/cycle-update-5.output.md deleted file mode 100644 index 64f50af5779..00000000000 --- a/unison-src/transcripts/cycle-update-5.output.md +++ /dev/null @@ -1,76 +0,0 @@ -Not yet working: properly updating nameless implicit terms. - -``` unison -inner.ping : 'Nat -inner.ping _ = !pong + 1 - -pong : 'Nat -pong _ = !inner.ping + 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`: - - inner.ping : 'Nat - pong : 'Nat - -``` -``` ucm -scratch/main> add - - ⍟ I've added these definitions: - - inner.ping : 'Nat - pong : 'Nat - -``` -Here we queue up an update by saving in a namespace where `inner.ping` and `pong` both have names, but then apply the -update in a namespace where only `ping` has a name. - -``` unison -inner.ping : 'Nat -inner.ping _ = !pong + 3 -``` - -``` 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: - - inner.ping : 'Nat - -``` -``` ucm - ☝️ The namespace .inner is empty. - -.inner> update.old - - ⍟ I've added these definitions: - - inner.ping : '##Nat - -scratch/main> view inner.ping - - inner.ping : 'Nat - inner.ping _ = - use Nat + - pong() + 1 - -``` -The bug here is that `inner.ping` still refers to `pong` by name. But if we properly identified the nameless (in the -context that the update was applied) `pong` as an implicit term to include in the new `ping`'s cycle, then `ping` would -be left referring to a nameless thing (namely, `pong`, but updated to refer to the new `ping`). - diff --git a/unison-src/transcripts/debug-name-diffs.output.md b/unison-src/transcripts/debug-name-diffs.output.md index beed0b4cc75..9033106895a 100644 --- a/unison-src/transcripts/debug-name-diffs.output.md +++ b/unison-src/transcripts/debug-name-diffs.output.md @@ -45,7 +45,8 @@ scratch/main> delete.term.verbose a.b.one 1. a.b.one : ##Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. scratch/main> alias.term a.two a.newtwo diff --git a/unison-src/transcripts/delete-namespace.output.md b/unison-src/transcripts/delete-namespace.output.md index 288160895ce..ef7c2a53074 100644 --- a/unison-src/transcripts/delete-namespace.output.md +++ b/unison-src/transcripts/delete-namespace.output.md @@ -78,7 +78,8 @@ scratch/main> delete.namespace . ⚠️ Are you sure you want to clear away everything? - You could use `project.create` to switch to a new project instead. + You could use `project.create` to switch to a new project + instead, or delete the current branch with `delete.branch` scratch/main> delete.namespace . @@ -89,7 +90,12 @@ scratch/main> delete.namespace . -- Should have an empty history scratch/main> history . - ☝️ The namespace . is empty. + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) ``` Deleting the root namespace shouldn't require confirmation if forced. @@ -104,6 +110,11 @@ scratch/main> delete.namespace.force . -- Should have an empty history scratch/main> history . - ☝️ The namespace . is empty. + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) ``` diff --git a/unison-src/transcripts/delete-project-branch.md b/unison-src/transcripts/delete-project-branch.md index 091e9fa71c8..923df54ba15 100644 --- a/unison-src/transcripts/delete-project-branch.md +++ b/unison-src/transcripts/delete-project-branch.md @@ -25,3 +25,18 @@ You can delete the only branch in a project. ```ucm foo/main> delete.branch /main ``` + +You can delete the last branch in the project, a new one will be created. + +```ucm +scratch/main> delete.branch scratch/main +scratch/main> branches +``` + +If the the last branch isn't /main, then /main will be created. + +```ucm +scratch/main2> delete.branch /main +scratch/main2> delete.branch /main2 +scratch/other> branches +``` diff --git a/unison-src/transcripts/delete-project-branch.output.md b/unison-src/transcripts/delete-project-branch.output.md index 755d5f0c70e..9423a7ed2cb 100644 --- a/unison-src/transcripts/delete-project-branch.output.md +++ b/unison-src/transcripts/delete-project-branch.output.md @@ -44,3 +44,29 @@ You can delete the only branch in a project. foo/main> delete.branch /main ``` +You can delete the last branch in the project, a new one will be created. + +``` ucm +scratch/main> delete.branch scratch/main + +scratch/main> branches + + Branch Remote branch + 1. main + 2. main2 + +``` +If the the last branch isn't /main, then /main will be created. + +``` ucm +scratch/main2> delete.branch /main + +scratch/main2> delete.branch /main2 + +scratch/other> branches + + Branch Remote branch + 1. main + 2. other + +``` diff --git a/unison-src/transcripts/delete-project.md b/unison-src/transcripts/delete-project.md index b317a9f31e0..35774b7e817 100644 --- a/unison-src/transcripts/delete-project.md +++ b/unison-src/transcripts/delete-project.md @@ -3,7 +3,17 @@ ```ucm scratch/main> project.create-empty foo scratch/main> project.create-empty bar -scratch/main> projects +-- I can delete the project I'm currently on +scratch/main> delete.project scratch +foo/main> projects +-- I can delete a different project +foo/main> delete.project bar +foo/main> projects +-- I can delete the last project, a new scratch project will be created foo/main> delete.project foo -scratch/main> projects +project/main> projects +-- If the last project is scratch, a scratch2 project will be created. +scratch/main> delete.project project +scratch/main> delete.project scratch +project/main> projects ``` diff --git a/unison-src/transcripts/delete-project.output.md b/unison-src/transcripts/delete-project.output.md index 2ee362e5030..37d8b2e3508 100644 --- a/unison-src/transcripts/delete-project.output.md +++ b/unison-src/transcripts/delete-project.output.md @@ -33,17 +33,37 @@ scratch/main> project.create-empty bar 🎉 🥳 Happy coding! -scratch/main> projects +-- I can delete the project I'm currently on +scratch/main> delete.project scratch + +foo/main> projects 1. bar 2. foo - 3. scratch +-- I can delete a different project +foo/main> delete.project bar + +foo/main> projects + + 1. foo + +-- I can delete the last project, a new scratch project will be created foo/main> delete.project foo -scratch/main> projects +project/main> projects - 1. bar + 1. project 2. scratch +-- If the last project is scratch, a scratch2 project will be created. +scratch/main> delete.project project + +scratch/main> delete.project scratch + +project/main> projects + + 1. project + 2. scratch2 + ``` diff --git a/unison-src/transcripts/delete.md b/unison-src/transcripts/delete.md index aadb7a602ff..9c1b8efd1a3 100644 --- a/unison-src/transcripts/delete.md +++ b/unison-src/transcripts/delete.md @@ -1,7 +1,7 @@ # Delete ```ucm:hide -.> builtins.merge +scratch/main> builtins.merge lib.builtins ``` The delete command can delete both terms and types. @@ -10,7 +10,7 @@ First, let's make sure it complains when we try to delete a name that doesn't exist. ```ucm:error -.> delete.verbose foo +scratch/main> delete.verbose foo ``` Now for some easy cases. Deleting an unambiguous term, then deleting an @@ -22,43 +22,43 @@ structural type Foo = Foo () ``` ```ucm -.> add -.> delete.verbose foo -.> delete.verbose Foo -.> delete.verbose Foo.Foo +scratch/main> add +scratch/main> delete.verbose foo +scratch/main> delete.verbose Foo +scratch/main> delete.verbose Foo.Foo ``` How about an ambiguous term? ```unison:hide -foo = 1 -bar = 2 +a.foo = 1 +a.bar = 2 ``` ```ucm -.a> add -.a> debug.alias.term.force bar foo +scratch/main> add +scratch/main> debug.alias.term.force a.bar a.foo ``` A delete should remove both versions of the term. ```ucm -.> delete.verbose a.foo -.a> ls +scratch/main> delete.verbose a.foo +scratch/main> ls a ``` Let's repeat all that on a type, for completeness. ```unison:hide -structural type Foo = Foo () -structural type Bar = Bar +structural type a.Foo = Foo () +structural type a.Bar = Bar ``` ```ucm -.a> add -.a> debug.alias.type.force Bar Foo -.> delete.verbose a.Foo -.> delete.verbose a.Foo.Foo +scratch/main> add +scratch/main> debug.alias.type.force a.Bar a.Foo +scratch/main> delete.verbose a.Foo +scratch/main> delete.verbose a.Foo.Foo ``` Finally, let's try to delete a term and a type with the same name. @@ -69,8 +69,8 @@ structural type foo = Foo () ``` ```ucm -.> add -.> delete.verbose foo +scratch/main> add +scratch/main> delete.verbose foo ``` We want to be able to delete multiple terms at once @@ -82,8 +82,8 @@ c = "c" ``` ```ucm -.> add -.> delete.verbose a b c +scratch/main> add +scratch/main> delete.verbose a b c ``` We can delete terms and types in the same invocation of delete @@ -96,9 +96,9 @@ c = "c" ``` ```ucm -.> add -.> delete.verbose a b c Foo -.> delete.verbose Foo.Foo +scratch/main> add +scratch/main> delete.verbose a b c Foo +scratch/main> delete.verbose Foo.Foo ``` We can delete a type and its constructors @@ -108,8 +108,8 @@ structural type Foo = Foo () ``` ```ucm -.> add -.> delete.verbose Foo Foo.Foo +scratch/main> add +scratch/main> delete.verbose Foo Foo.Foo ``` You should not be able to delete terms which are referenced by other terms @@ -122,8 +122,8 @@ d = a + b + c ``` ```ucm:error -.> add -.> delete.verbose a b c +scratch/main> add +scratch/main> delete.verbose a b c ``` But you should be able to delete all terms which reference each other in a single command @@ -136,8 +136,8 @@ h = e + f + g ``` ```ucm -.> add -.> delete.verbose e f g h +scratch/main> add +scratch/main> delete.verbose e f g h ``` You should be able to delete a type and all the functions that reference it in a single command @@ -151,8 +151,8 @@ incrementFoo = cases ``` ```ucm -.> add -.> delete.verbose Foo Foo.Foo incrementFoo +scratch/main> add +scratch/main> delete.verbose Foo Foo.Foo incrementFoo ``` If you mess up on one of the names of your command, delete short circuits @@ -165,8 +165,8 @@ h = e + f + g ``` ```ucm:error -.> add -.> delete.verbose e f gg +scratch/main> add +scratch/main> delete.verbose e f gg ``` Cyclical terms which are guarded by a lambda are allowed to be deleted @@ -177,7 +177,7 @@ pong _ = 4 Nat.+ !ping ``` ```ucm -.> add -.> delete.verbose ping -.> view pong +scratch/main> add +scratch/main> delete.verbose ping +scratch/main> view pong ``` diff --git a/unison-src/transcripts/delete.output.md b/unison-src/transcripts/delete.output.md index 178e92797db..0fceae62a61 100644 --- a/unison-src/transcripts/delete.output.md +++ b/unison-src/transcripts/delete.output.md @@ -6,7 +6,7 @@ First, let's make sure it complains when we try to delete a name that doesn't exist. ``` ucm -.> delete.verbose foo +scratch/main> delete.verbose foo ⚠️ @@ -23,56 +23,57 @@ structural type Foo = Foo () ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: structural type Foo foo : Nat -.> delete.verbose foo +scratch/main> delete.verbose foo Removed definitions: 1. foo : Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> delete.verbose Foo +scratch/main> delete.verbose Foo Removed definitions: 1. structural type Foo - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> delete.verbose Foo.Foo +scratch/main> delete.verbose Foo.Foo Removed definitions: 1. Foo.Foo : '#089vmor9c5 - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` How about an ambiguous term? ``` unison -foo = 1 -bar = 2 +a.foo = 1 +a.bar = 2 ``` ``` ucm - ☝️ The namespace .a is empty. - -.a> add +scratch/main> add ⍟ I've added these definitions: - bar : ##Nat - foo : ##Nat + a.bar : Nat + a.foo : Nat -.a> debug.alias.term.force bar foo +scratch/main> debug.alias.term.force a.bar a.foo Done. @@ -80,7 +81,7 @@ bar = 2 A delete should remove both versions of the term. ``` ucm -.> delete.verbose a.foo +scratch/main> delete.verbose a.foo Removed definitions: @@ -92,33 +93,35 @@ A delete should remove both versions of the term. 2. a.bar ┐ 3. a.foo#dcgdua2lj6 (removed) 4. a.foo#dcgdua2lj6 ┘ - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.a> ls +scratch/main> ls a - 1. bar (##Nat) + 1. bar (Nat) ``` Let's repeat all that on a type, for completeness. ``` unison -structural type Foo = Foo () -structural type Bar = Bar +structural type a.Foo = Foo () +structural type a.Bar = Bar ``` ``` ucm -.a> add +scratch/main> add ⍟ I've added these definitions: - structural type Bar - structural type Foo + structural type a.Bar + (also named lib.builtins.Unit) + structural type a.Foo -.a> debug.alias.type.force Bar Foo +scratch/main> debug.alias.type.force a.Bar a.Foo Done. -.> delete.verbose a.Foo +scratch/main> delete.verbose a.Foo Removed definitions: @@ -126,20 +129,22 @@ structural type Bar = Bar Name changes: - Original Changes - 2. a.Bar ┐ 3. a.Foo#00nv2kob8f (removed) - 4. builtin.Unit │ - 5. a.Foo#00nv2kob8f ┘ + Original Changes + 2. a.Bar ┐ 3. a.Foo#00nv2kob8f (removed) + 4. lib.builtins.Unit │ + 5. a.Foo#00nv2kob8f ┘ - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> delete.verbose a.Foo.Foo +scratch/main> delete.verbose a.Foo.Foo Removed definitions: 1. a.Foo.Foo : '#089vmor9c5 - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` Finally, let's try to delete a term and a type with the same name. @@ -150,21 +155,22 @@ structural type foo = Foo () ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: structural type foo foo : Nat -.> delete.verbose foo +scratch/main> delete.verbose foo Removed definitions: 1. structural type foo 2. foo : Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` We want to be able to delete multiple terms at once @@ -176,7 +182,7 @@ c = "c" ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -184,7 +190,7 @@ c = "c" b : Text c : Text -.> delete.verbose a b c +scratch/main> delete.verbose a b c Removed definitions: @@ -192,7 +198,8 @@ c = "c" 2. b : Text 3. c : Text - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` We can delete terms and types in the same invocation of delete @@ -205,7 +212,7 @@ c = "c" ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -214,7 +221,7 @@ c = "c" b : Text c : Text -.> delete.verbose a b c Foo +scratch/main> delete.verbose a b c Foo Removed definitions: @@ -223,9 +230,10 @@ c = "c" 3. b : Text 4. c : Text - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> delete.verbose Foo.Foo +scratch/main> delete.verbose Foo.Foo Name changes: @@ -233,7 +241,8 @@ c = "c" 1. Foo.Foo ┐ 2. Foo.Foo (removed) 3. foo.Foo ┘ - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` We can delete a type and its constructors @@ -243,13 +252,13 @@ structural type Foo = Foo () ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: structural type Foo -.> delete.verbose Foo Foo.Foo +scratch/main> delete.verbose Foo Foo.Foo Removed definitions: @@ -261,7 +270,8 @@ structural type Foo = Foo () 2. Foo.Foo ┐ 3. Foo.Foo (removed) 4. foo.Foo ┘ - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` You should not be able to delete terms which are referenced by other terms @@ -274,7 +284,7 @@ d = a + b + c ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -284,7 +294,7 @@ d = a + b + c c : Nat d : Nat -.> delete.verbose a b c +scratch/main> delete.verbose a b c ⚠️ @@ -307,7 +317,7 @@ h = e + f + g ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -316,7 +326,7 @@ h = e + f + g g : Nat h : Nat -.> delete.verbose e f g h +scratch/main> delete.verbose e f g h Removed definitions: @@ -325,7 +335,8 @@ h = e + f + g 3. g : Nat 4. h : Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` You should be able to delete a type and all the functions that reference it in a single command @@ -339,14 +350,14 @@ incrementFoo = cases ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: structural type Foo incrementFoo : Foo -> Nat -.> delete.verbose Foo Foo.Foo incrementFoo +scratch/main> delete.verbose Foo Foo.Foo incrementFoo Removed definitions: @@ -354,7 +365,8 @@ incrementFoo = cases 2. Foo.Foo : Nat -> #68k40ra7l7 3. incrementFoo : #68k40ra7l7 -> Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. ``` If you mess up on one of the names of your command, delete short circuits @@ -367,7 +379,7 @@ h = e + f + g ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -376,7 +388,7 @@ h = e + f + g g : Nat h : Nat -.> delete.verbose e f gg +scratch/main> delete.verbose e f gg ⚠️ @@ -392,22 +404,23 @@ pong _ = 4 Nat.+ !ping ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: ping : 'Nat pong : 'Nat -.> delete.verbose ping +scratch/main> delete.verbose ping Removed definitions: 1. ping : 'Nat - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> view pong +scratch/main> view pong pong : 'Nat pong _ = diff --git a/unison-src/transcripts/diff-namespace.md b/unison-src/transcripts/diff-namespace.md index 4d04dda7919..ecb0b129d03 100644 --- a/unison-src/transcripts/diff-namespace.md +++ b/unison-src/transcripts/diff-namespace.md @@ -1,23 +1,32 @@ ```ucm:hide -.> builtins.merge +scratch/b1> builtins.merge lib.builtins +scratch/b2> builtins.merge lib.builtins +scratch/nsx> builtins.merge lib.builtins +scratch/main> builtins.merge lib.builtins ``` ```unison:hide -b1.x = 23 -b1.fslkdjflskdjflksjdf = 663 -b2.x = 23 -b2.fslkdjflskdjflksjdf = 23 -b2.abc = 23 +x = 23 +fslkdjflskdjflksjdf = 663 ``` ```ucm -.> add -.> debug.alias.term.force b1.x b1.fslkdjflskdjflksjdf +scratch/b1> add +``` + +```unison:hide +x = 23 +fslkdjflskdjflksjdf = 23 +abc = 23 ``` ```ucm -.> diff.namespace b1 b2 -.b2> diff.namespace .b1 +scratch/b2> add +scratch/b1> debug.alias.term.force .x .fslkdjflskdjflksjdf +``` + +```ucm +scratch/main> diff.namespace /b1: /b2: ``` Things we want to test: @@ -42,20 +51,20 @@ structural ability X a1 a2 where x : () ``` ```ucm -.ns1> add -.ns1> alias.term fromJust fromJust' -.ns1> alias.term helloWorld helloWorld2 -.ns1> fork .ns1 .ns2 +scratch/ns1> add +scratch/ns1> alias.term fromJust fromJust' +scratch/ns1> alias.term helloWorld helloWorld2 +scratch/ns1> branch /ns2 ``` Here's what we've done so far: ```ucm:error -.> diff.namespace nothing ns1 +scratch/main> diff.namespace .nothing /ns1: ``` ```ucm:error -.> diff.namespace ns1 ns2 +scratch/main> diff.namespace /ns1: /ns2: ``` ```unison:hide @@ -63,9 +72,9 @@ junk = "asldkfjasldkfj" ``` ```ucm -.ns1> add -.ns1> debug.alias.term.force junk fromJust -.ns1> delete.term junk +scratch/ns1> add +scratch/ns1> debug.alias.term.force junk fromJust +scratch/ns1> delete.term junk ``` ```unison:hide @@ -78,25 +87,25 @@ unique type Y a b = Y a b ``` ```ucm -.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 +scratch/ns2> update.old +scratch/main> diff.namespace /ns1: /ns2: +scratch/ns2> alias.term d d' +scratch/ns2> alias.type A A' +scratch/ns2> alias.type X X' +scratch/main> diff.namespace /ns1: /ns2: +scratch/ns1> alias.type X X2 +scratch/ns2> alias.type A' A'' +scratch/ns2> branch /ns3 +scratch/ns2> alias.term fromJust' yoohoo +scratch/ns2> delete.term.verbose fromJust' +scratch/main> diff.namespace /ns3: /ns2: ``` ```unison:hide bdependent = "banana" ``` ```ucm -.ns3> update.old -.> diff.namespace ns2 ns3 +scratch/ns3> update.old +scratch/main> diff.namespace /ns2: /ns3: ``` @@ -108,12 +117,14 @@ shown, only their also-conflicted dependency is shown. ```unison:hide a = 333 b = a + 1 + +forconflicts = 777 ``` ```ucm -.nsx> add -.> fork nsx nsy -.> fork nsx nsz +scratch/nsx> add +scratch/nsx> branch /nsy +scratch/nsx> branch /nsz ``` ```unison:hide @@ -121,7 +132,7 @@ a = 444 ``` ```ucm -.nsy> update.old +scratch/nsy> update.old ``` ```unison:hide @@ -129,15 +140,16 @@ a = 555 ``` ```ucm -.nsz> update.old -.> fork nsy nsw -.> debug.alias.term.force nsz.a nsw.a -.> debug.alias.term.force nsz.b nsw.b +scratch/nsz> update.old +scratch/nsy> branch /nsw +scratch/nsw> debug.alias.term.force .forconflicts .a +scratch/nsw> debug.alias.term.force .forconflicts .b ``` ```ucm -.> diff.namespace nsx nsw -.nsw> view a b +scratch/main> diff.namespace /nsx: /nsw: +scratch/nsw> view a +scratch/nsw> view b ``` ## Should be able to diff a namespace hash from history. @@ -147,7 +159,7 @@ x = 1 ``` ```ucm -.hashdiff> add +scratch/hashdiff> add ``` ```unison @@ -155,9 +167,9 @@ y = 2 ``` ```ucm -.hashdiff> add -.hashdiff> history -.hashdiff> diff.namespace 2 1 +scratch/hashdiff> add +scratch/hashdiff> history +scratch/hashdiff> diff.namespace 2 1 ``` ## diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index 32cfbb27ba0..5121aa90826 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -1,29 +1,39 @@ ``` unison -b1.x = 23 -b1.fslkdjflskdjflksjdf = 663 -b2.x = 23 -b2.fslkdjflskdjflksjdf = 23 -b2.abc = 23 +x = 23 +fslkdjflskdjflksjdf = 663 ``` ``` ucm -.> add +scratch/b1> add ⍟ I've added these definitions: - b1.fslkdjflskdjflksjdf : Nat - b1.x : Nat - b2.abc : Nat - b2.fslkdjflskdjflksjdf : Nat - b2.x : Nat + fslkdjflskdjflksjdf : Nat + x : Nat -.> debug.alias.term.force b1.x b1.fslkdjflskdjflksjdf +``` +``` unison +x = 23 +fslkdjflskdjflksjdf = 23 +abc = 23 +``` + +``` ucm +scratch/b2> add + + ⍟ I've added these definitions: + + abc : Nat + fslkdjflskdjflksjdf : Nat + x : Nat + +scratch/b1> debug.alias.term.force .x .fslkdjflskdjflksjdf Done. ``` ``` ucm -.> diff.namespace b1 b2 +scratch/main> diff.namespace /b1: /b2: Resolved name conflicts: @@ -39,22 +49,6 @@ b2.abc = 23 6. fslkdjflskdjflksjdf#u520d1t9kc ┘ 7. fslkdjflskdjflksjdf (added) 8. fslkdjflskdjflksjdf#u520d1t9kc (removed) -.b2> diff.namespace .b1 - - Resolved name conflicts: - - 1. ┌ fslkdjflskdjflksjdf#sekb3fdsvb : ##Nat - 2. └ fslkdjflskdjflksjdf#u520d1t9kc : ##Nat - ↓ - 3. fslkdjflskdjflksjdf#u520d1t9kc : ##Nat - - Name changes: - - Original Changes - 4. x ┐ 5. abc (added) - 6. fslkdjflskdjflksjdf#u520d1t9kc ┘ 7. fslkdjflskdjflksjdf (added) - 8. fslkdjflskdjflksjdf#u520d1t9kc (removed) - ``` Things we want to test: @@ -79,9 +73,7 @@ structural ability X a1 a2 where x : () ``` ``` ucm - ☝️ The namespace .ns1 is empty. - -.ns1> add +scratch/ns1> add ⍟ I've added these definitions: @@ -93,31 +85,34 @@ structural ability X a1 a2 where x : () fromJust : ##Nat helloWorld : ##Text -.ns1> alias.term fromJust fromJust' +scratch/ns1> alias.term fromJust fromJust' Done. -.ns1> alias.term helloWorld helloWorld2 +scratch/ns1> alias.term helloWorld helloWorld2 Done. -.ns1> fork .ns1 .ns2 +scratch/ns1> branch /ns2 - Done. + Done. I've created the ns2 branch based off of ns1. + + Tip: To merge your work back into the ns1 branch, first + `switch /ns1` then `merge /ns2`. ``` Here's what we've done so far: ``` ucm -.> diff.namespace nothing ns1 +scratch/main> diff.namespace .nothing /ns1: ⚠️ - The namespace .nothing is empty. Was there a typo? + The namespace scratch/main:.nothing is empty. Was there a typo? ``` ``` ucm -.> diff.namespace ns1 ns2 +scratch/main> diff.namespace /ns1: /ns2: The namespaces are identical. @@ -127,17 +122,17 @@ junk = "asldkfjasldkfj" ``` ``` ucm -.ns1> add +scratch/ns1> add ⍟ I've added these definitions: junk : ##Text -.ns1> debug.alias.term.force junk fromJust +scratch/ns1> debug.alias.term.force junk fromJust Done. -.ns1> delete.term junk +scratch/ns1> delete.term junk Done. @@ -152,7 +147,7 @@ unique type Y a b = Y a b ``` ``` ucm -.ns2> update.old +scratch/ns2> update.old ⍟ I've added these definitions: @@ -167,7 +162,7 @@ unique type Y a b = Y a b fromJust : ##Nat (The old definition was also named fromJust'.) -.> diff.namespace ns1 ns2 +scratch/main> diff.namespace /ns1: /ns2: Resolved name conflicts: @@ -189,26 +184,26 @@ unique type Y a b = Y a b Added definitions: 8. type Y a b - 9. Y.Y : a -> b -> Y a b + 9. Y.Y : a -> b -> #md85ksgqel a b 10. d : Nat 11. e : Nat 12. f : Nat 13. patch patch (added 2 updates) -.> alias.term ns2.d ns2.d' +scratch/ns2> alias.term d d' Done. -.> alias.type ns2.A ns2.A' +scratch/ns2> alias.type A A' Done. -.> alias.type ns2.X ns2.X' +scratch/ns2> alias.type X X' Done. -.> diff.namespace ns1 ns2 +scratch/main> diff.namespace /ns1: /ns2: Resolved name conflicts: @@ -230,7 +225,7 @@ unique type Y a b = Y a b Added definitions: 8. type Y a b - 9. Y.Y : a -> b -> Y a b + 9. Y.Y : a -> b -> #md85ksgqel a b 10. ┌ d : Nat 11. └ d' : Nat 12. e : Nat @@ -245,36 +240,38 @@ unique type Y a b = Y a b 17. X 18. X' (added) -.> alias.type ns1.X ns1.X2 +scratch/ns1> alias.type X X2 Done. -.> alias.type ns2.A' ns2.A'' +scratch/ns2> alias.type A' A'' Done. -.> fork ns2 ns3 +scratch/ns2> branch /ns3 - Done. + Done. I've created the ns3 branch based off of ns2. + + Tip: To merge your work back into the ns2 branch, first + `switch /ns2` then `merge /ns3`. -.> alias.term ns2.fromJust' ns2.yoohoo +scratch/ns2> alias.term fromJust' yoohoo Done. -.> delete.term.verbose ns2.fromJust' +scratch/ns2> delete.term.verbose fromJust' Name changes: - Original Changes - 1. ns2.fromJust ┐ 2. ns2.fromJust' (removed) - 3. ns2.fromJust' │ - 4. ns2.yoohoo │ - 5. ns3.fromJust │ - 6. ns3.fromJust' ┘ + Original Changes + 1. fromJust ┐ 2. fromJust' (removed) + 3. fromJust' │ + 4. yoohoo ┘ - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. -.> diff.namespace ns3 ns2 +scratch/main> diff.namespace /ns3: /ns2: Name changes: @@ -288,13 +285,13 @@ bdependent = "banana" ``` ``` ucm -.ns3> update.old +scratch/ns3> update.old ⍟ I've updated these names to your new definition: bdependent : ##Text -.> diff.namespace ns2 ns3 +scratch/main> diff.namespace /ns2: /ns3: Updates: @@ -319,25 +316,32 @@ shown, only their also-conflicted dependency is shown. ``` unison a = 333 b = a + 1 + +forconflicts = 777 ``` ``` ucm - ☝️ The namespace .nsx is empty. - -.nsx> add +scratch/nsx> add ⍟ I've added these definitions: - a : ##Nat - b : ##Nat + a : Nat + b : Nat + forconflicts : Nat -.> fork nsx nsy +scratch/nsx> branch /nsy - Done. + Done. I've created the nsy branch based off of nsx. + + Tip: To merge your work back into the nsx branch, first + `switch /nsx` then `merge /nsy`. -.> fork nsx nsz +scratch/nsx> branch /nsz - Done. + Done. I've created the nsz branch based off of nsx. + + Tip: To merge your work back into the nsx branch, first + `switch /nsx` then `merge /nsz`. ``` ``` unison @@ -345,11 +349,11 @@ a = 444 ``` ``` ucm -.nsy> update.old +scratch/nsy> update.old ⍟ I've updated these names to your new definition: - a : ##Nat + a : Nat ``` ``` unison @@ -357,57 +361,70 @@ a = 555 ``` ``` ucm -.nsz> update.old +scratch/nsz> update.old ⍟ I've updated these names to your new definition: - a : ##Nat + a : Nat -.> fork nsy nsw +scratch/nsy> branch /nsw - Done. + Done. I've created the nsw branch based off of nsy. + + Tip: To merge your work back into the nsy branch, first + `switch /nsy` then `merge /nsw`. -.> debug.alias.term.force nsz.a nsw.a +scratch/nsw> debug.alias.term.force .forconflicts .a Done. -.> debug.alias.term.force nsz.b nsw.b +scratch/nsw> debug.alias.term.force .forconflicts .b Done. ``` ``` ucm -.> diff.namespace nsx nsw +scratch/main> diff.namespace /nsx: /nsw: New name conflicts: - 1. a#uiiiv8a86s : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat + 1. a#uiiiv8a86s : Nat + ↓ + 2. ┌ a#mdl4vqtu00 : Nat + 3. └ a#r3msrbpp1v : Nat - 4. b#lhigeb1let : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat + 4. b#lhigeb1let : Nat + ↓ + 5. ┌ b#r3msrbpp1v : Nat + 6. └ b#unkqhuu66p : Nat Added definitions: - 7. patch patch (added 1 updates) + 7. patch patch (added 1 updates) + + Name changes: + + Original Changes + 8. forconflicts 9. a#r3msrbpp1v (added) + 10. b#r3msrbpp1v (added) -.nsw> view a b +scratch/nsw> view a - a#mdl4vqtu00 : ##Nat + a#mdl4vqtu00 : Nat a#mdl4vqtu00 = 444 - a#vrs8gtkl2t : ##Nat - a#vrs8gtkl2t = 555 - - b#aapqletas7 : ##Nat - b#aapqletas7 = ##Nat.+ a#vrs8gtkl2t 1 + a#r3msrbpp1v : Nat + a#r3msrbpp1v = 777 + +scratch/nsw> view b + + b#r3msrbpp1v : Nat + b#r3msrbpp1v = 777 - b#unkqhuu66p : ##Nat - b#unkqhuu66p = ##Nat.+ a#mdl4vqtu00 1 + b#unkqhuu66p : Nat + b#unkqhuu66p = + use Nat + + a#mdl4vqtu00 + 1 ``` ## Should be able to diff a namespace hash from history. @@ -426,13 +443,11 @@ x = 1 ⍟ These new definitions are ok to `add`: - x : ##Nat + x : Nat ``` ``` ucm - ☝️ The namespace .hashdiff is empty. - -.hashdiff> add +scratch/hashdiff> add ⍟ I've added these definitions: @@ -457,13 +472,13 @@ y = 2 ``` ``` ucm -.hashdiff> add +scratch/hashdiff> add ⍟ I've added these definitions: y : ##Nat -.hashdiff> history +scratch/hashdiff> history Note: The most recent namespace hash is immediately below this message. @@ -476,7 +491,7 @@ y = 2 □ 2. #i52j9fd57b (start of history) -.hashdiff> diff.namespace 2 1 +scratch/hashdiff> diff.namespace 2 1 Added definitions: diff --git a/unison-src/transcripts/empty-namespaces.output.md b/unison-src/transcripts/empty-namespaces.output.md index 409dfcd51c0..1b598b6dd40 100644 --- a/unison-src/transcripts/empty-namespaces.output.md +++ b/unison-src/transcripts/empty-namespaces.output.md @@ -53,7 +53,12 @@ The history of the namespace should be empty. ``` ucm scratch/main> history mynamespace - ☝️ The namespace mynamespace is empty. + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) ``` Add and then delete a term to add some history to a deleted namespace. diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md index 0c60b4dc73d..17ea6012c7c 100644 --- a/unison-src/transcripts/fix2254.output.md +++ b/unison-src/transcripts/fix2254.output.md @@ -85,30 +85,33 @@ scratch/a2> view A NeedsA f f2 f3 g = NeedsA (A a b Nat Nat) | Zoink Text - f : A Nat Nat Nat Nat -> Nat + f : #re3rf9cedk Nat Nat Nat Nat -> Nat f = cases - A n -> n - _ -> 42 + #re3rf9cedk#1 n -> n + _ -> 42 - f2 : A Nat Nat Nat Nat -> Nat + f2 : #re3rf9cedk Nat Nat Nat Nat -> Nat f2 a = use Nat + n = f a n + 1 - f3 : NeedsA Nat Nat -> Nat + f3 : #oftm6ao9vp Nat Nat -> Nat f3 = cases - NeedsA a -> f a Nat.+ 20 - _ -> 0 + #oftm6ao9vp#0 a -> f a Nat.+ 20 + _ -> 0 - g : A Nat Nat Nat Nat -> Nat + g : #re3rf9cedk Nat Nat Nat Nat -> Nat g = cases - D n -> n - _ -> 43 + #re3rf9cedk#0 n -> n + _ -> 43 scratch/a2> todo - You have no pending todo items. Good work! ✅ + These types do not have any names in the current namespace: + + 1. #oftm6ao9vp + 2. #re3rf9cedk ``` ## Record updates diff --git a/unison-src/transcripts/help.output.md b/unison-src/transcripts/help.output.md index 019bc309296..b8d12061e4d 100644 --- a/unison-src/transcripts/help.output.md +++ b/unison-src/transcripts/help.output.md @@ -40,12 +40,14 @@ scratch/main> help 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.empty (or branch.create-empty, create.empty-branch) Create a new empty branch. + branch.reflog (or reflog.branch, reflog) + `branch.reflog` lists all the changes that have affected the current branch. + `branch.reflog /mybranch` lists all the changes that have affected /mybranch. + branch.rename (or rename.branch) `branch.rename foo` renames the current branch to `foo` @@ -178,6 +180,9 @@ scratch/main> help that `fzf` can be found within your PATH. + deprecated.root-reflog + `deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of `branch.reflog` which shows the reflog for the current project. + diff.namespace `diff.namespace before after` shows how the namespace `after` differs from the namespace @@ -538,6 +543,10 @@ scratch/main> help `project.create` creates a project with a random name `project.create foo` creates a project named `foo` + project.reflog (or reflog.project) + `project.reflog` lists all the changes that have affected any branches in the current project. + `project.reflog myproject` lists all the changes that have affected any branches in myproject. + project.rename (or rename.project) `project.rename foo` renames the current project to `foo` @@ -666,8 +675,8 @@ scratch/main> help quit (or exit, :q) Exits the Unison command line interface. - reflog - `reflog` lists the changes that have affected the root namespace + reflog.global + `reflog.global` lists all recent changes across all projects and branches. release.draft (or draft.release) Draft a release. diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index 4a84996f4dc..1d28320c84b 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -464,7 +464,7 @@ project/main> merge /topic ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ## Merge failure: someone deleted something @@ -962,7 +962,7 @@ project/alice> merge bob ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ## `merge.commit` example (success) @@ -971,7 +971,6 @@ After merge conflicts are resolved, you can use `merge.commit` rather than `swit "commit" your changes. ```ucm:hide -.> project.create-empty project project/main> builtins.mergeio lib.builtins ``` @@ -1028,7 +1027,7 @@ project/alice> branches ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ## `merge.commit` example (failure) @@ -1036,7 +1035,6 @@ project/alice> branches `merge.commit` can only be run on a "merge branch". ```ucm:hide -.> project.create-empty project project/main> builtins.mergeio lib.builtins ``` @@ -1049,7 +1047,7 @@ project/topic> merge.commit ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` @@ -1527,7 +1525,7 @@ project/main> view Foo ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ### Dependent that doesn't need to be in the file @@ -1592,7 +1590,7 @@ project/alice> merge /bob But `bar` was put into the scratch file instead. ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ### Merge loop test @@ -1647,7 +1645,7 @@ project/carol> history ``` ```ucm:hide -.> project.delete project +scratch/main> project.delete project ``` ### Variables named `_` @@ -1703,7 +1701,3 @@ scratch/alice> update ```ucm scratch/alice> merge /bob ``` - -```ucm:hide -.> project.delete scratch -``` diff --git a/unison-src/transcripts/move-namespace.md b/unison-src/transcripts/move-namespace.md index 0d1c7ba3e5a..e547fdfa218 100644 --- a/unison-src/transcripts/move-namespace.md +++ b/unison-src/transcripts/move-namespace.md @@ -10,34 +10,34 @@ foo = 1 ``` ```ucm -.> add +scratch/main> add -- Should request confirmation -.> move.namespace . .root.at.path -.> move.namespace . .root.at.path -.> ls -.> history +scratch/main> move.namespace . .root.at.path +scratch/main> move.namespace . .root.at.path +scratch/main> ls +scratch/main> history ``` ```ucm -.> ls .root.at.path -.> history .root.at.path +scratch/main> ls .root.at.path +scratch/main> history .root.at.path ``` I should be able to move a sub namespace _over_ the root. ```ucm -- Should request confirmation -.> move.namespace .root.at.path . -.> move.namespace .root.at.path . -.> ls -.> history +scratch/main> move.namespace .root.at.path . +scratch/main> move.namespace .root.at.path . +scratch/main> ls +scratch/main> history ``` ```ucm:error -- should be empty -.> ls .root.at.path -.> history .root.at.path +scratch/main> ls .root.at.path +scratch/main> history .root.at.path ``` ```ucm:hide diff --git a/unison-src/transcripts/move-namespace.output.md b/unison-src/transcripts/move-namespace.output.md index 627edf4a950..a93618b0de0 100644 --- a/unison-src/transcripts/move-namespace.output.md +++ b/unison-src/transcripts/move-namespace.output.md @@ -9,29 +9,29 @@ foo = 1 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: foo : ##Nat -- Should request confirmation -.> move.namespace . .root.at.path +scratch/main> move.namespace . .root.at.path ⚠️ Moves which affect the root branch cannot be undone, are you sure? Re-run the same command to proceed. -.> move.namespace . .root.at.path +scratch/main> move.namespace . .root.at.path Done. -.> ls +scratch/main> ls 1. root/ (1 term) -.> history +scratch/main> history Note: The most recent namespace hash is immediately below this message. @@ -42,11 +42,11 @@ foo = 1 ``` ``` ucm -.> ls .root.at.path +scratch/main> ls .root.at.path 1. foo (##Nat) -.> history .root.at.path +scratch/main> history .root.at.path Note: The most recent namespace hash is immediately below this message. @@ -60,22 +60,22 @@ I should be able to move a sub namespace *over* the root. ``` ucm -- Should request confirmation -.> move.namespace .root.at.path . +scratch/main> move.namespace .root.at.path . ⚠️ Moves which affect the root branch cannot be undone, are you sure? Re-run the same command to proceed. -.> move.namespace .root.at.path . +scratch/main> move.namespace .root.at.path . Done. -.> ls +scratch/main> ls 1. foo (##Nat) -.> history +scratch/main> history Note: The most recent namespace hash is immediately below this message. @@ -87,13 +87,18 @@ I should be able to move a sub namespace *over* the root. ``` ``` ucm -- should be empty -.> ls .root.at.path +scratch/main> ls .root.at.path nothing to show -.> history .root.at.path +scratch/main> history .root.at.path - ☝️ The namespace .root.at.path is empty. + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) ``` ## Happy path @@ -279,7 +284,12 @@ scratch/history> history b -- Should be empty scratch/history> history a - ☝️ The namespace a is empty. + Note: The most recent namespace hash is immediately below this + message. + + + + □ 1. #sg60bvjo91 (start of history) ``` ## Moving over an existing branch @@ -348,7 +358,8 @@ scratch/existing> move.namespace a b A branch existed at the destination: b so I over-wrote it. - Tip: You can use `undo` or `reflog` to undo this change. + Tip: You can use `undo` or use a hash from `branch.reflog` to + undo this change. Done. diff --git a/unison-src/transcripts/name-selection.md b/unison-src/transcripts/name-selection.md index cff6c15d4f7..5443349c0d8 100644 --- a/unison-src/transcripts/name-selection.md +++ b/unison-src/transcripts/name-selection.md @@ -5,10 +5,8 @@ This transcript shows how the pretty-printer picks names for a hash when multipl 3. Otherwise if there are multiple names with a minimal number of segments, compare the names alphabetically. ```ucm:hide -.a> builtins.merge -.a2> builtins.merge -.a3> builtins.merge -.biasing> builtins.merge +scratch/main> builtins.merge lib.builtins +scratch/biasing> builtins.merge lib.builtins ``` ```unison:hide @@ -20,8 +18,8 @@ a.aaa.but.more.segments = 0 + 1 Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment length alias), and show that it isn't used when viewing `a`: ```ucm -.> add -.a> view a +scratch/main> add +scratch/main> view a.a ``` Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: @@ -43,9 +41,9 @@ a3.long.name.but.shortest.suffixification = 1 ``` ```ucm -.> add -.> debug.alias.term.force a2.c a3.c -.> debug.alias.term.force a2.d a3.d +scratch/main> add +scratch/main> debug.alias.term.force a2.c a3.c +scratch/main> debug.alias.term.force a2.d a3.d ``` At this point, `a3` is conflicted for symbols `c` and `d`, so those are deprioritized. @@ -53,7 +51,7 @@ The original `a2` namespace has an unconflicted definition for `c` and `d`, but `a2.c` is chosen because although the suffixified version has fewer segments, its fully-qualified name has the fewest segments. ```ucm -.> view a b c d +scratch/main> view a b c d ``` ## Name biasing @@ -68,11 +66,11 @@ a = 10 ``` ```ucm -.biasing> add +scratch/biasing> add -- Despite being saved with name `a`, -- the pretty printer should prefer the suffixified 'deeply.nested.num name' over the shallow 'a'. -- It's closer to the term being printed. -.biasing> view deeply.nested.term +scratch/biasing> view deeply.nested.term ``` Add another term with `num` suffix to force longer suffixification of `deeply.nested.num` @@ -82,8 +80,8 @@ other.num = 20 ``` ```ucm -.biasing> add +scratch/biasing> add -- nested.num should be preferred over the shorter name `a` due to biasing -- because `deeply.nested.num` is nearby to the term being viewed. -.biasing> view deeply.nested.term +scratch/biasing> view deeply.nested.term ``` diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index f76c6796f54..10bb357c981 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -13,7 +13,7 @@ a.aaa.but.more.segments = 0 + 1 Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment length alias), and show that it isn't used when viewing `a`: ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -21,10 +21,10 @@ Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment a.aaa.but.more.segments : Nat a.b : Nat -.a> view a +scratch/main> view a.a - a : Nat - a = + a.a : Nat + a.a = use Nat + b + 1 @@ -48,7 +48,7 @@ a3.long.name.but.shortest.suffixification = 1 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -71,11 +71,11 @@ a3.long.name.but.shortest.suffixification = 1 a3.d : Nat a3.long.name.but.shortest.suffixification : Nat -.> debug.alias.term.force a2.c a3.c +scratch/main> debug.alias.term.force a2.c a3.c Done. -.> debug.alias.term.force a2.d a3.d +scratch/main> debug.alias.term.force a2.d a3.d Done. @@ -85,7 +85,7 @@ The original `a2` namespace has an unconflicted definition for `c` and `d`, but `a2.c` is chosen because although the suffixified version has fewer segments, its fully-qualified name has the fewest segments. ``` ucm -.> view a b c d +scratch/main> view a b c d a.a : Nat a.a = @@ -141,7 +141,7 @@ a = 10 ``` ``` ucm -.biasing> add +scratch/biasing> add ⍟ I've added these definitions: @@ -152,7 +152,7 @@ a = 10 -- Despite being saved with name `a`, -- the pretty printer should prefer the suffixified 'deeply.nested.num name' over the shallow 'a'. -- It's closer to the term being printed. -.biasing> view deeply.nested.term +scratch/biasing> view deeply.nested.term deeply.nested.term : Nat deeply.nested.term = @@ -180,7 +180,7 @@ other.num = 20 ``` ``` ucm -.biasing> add +scratch/biasing> add ⍟ I've added these definitions: @@ -188,7 +188,7 @@ other.num = 20 -- nested.num should be preferred over the shorter name `a` due to biasing -- because `deeply.nested.num` is nearby to the term being viewed. -.biasing> view deeply.nested.term +scratch/biasing> view deeply.nested.term deeply.nested.term : Nat deeply.nested.term = diff --git a/unison-src/transcripts/names.md b/unison-src/transcripts/names.md index 6d395266c43..7780292f423 100644 --- a/unison-src/transcripts/names.md +++ b/unison-src/transcripts/names.md @@ -1,5 +1,9 @@ # `names` command +```ucm +scratch/main> builtins.merge lib.builtins +``` + Example uses of the `names` command and output ```unison @@ -13,7 +17,7 @@ somewhere.y = 2 ``` ```ucm -.> add +scratch/main> add ``` @@ -21,22 +25,23 @@ somewhere.y = 2 ```ucm -- We can search by suffix and find all definitions named 'x', and each of their aliases respectively. --- But we don't see somewhere.z which is has the same value but is out of our namespace -.some> names x +scratch/main> names x -- We can search by hash, and see all aliases of that hash -.some> names #gjmq673r1v --- If the query is absolute, treat it as a `names.global` -.some> names .some.place.x +scratch/main> names #gjmq673r1v +-- Works with absolute names too +scratch/main> names .some.place.x ``` `names.global` searches from the root, and absolutely qualifies results -```ucm --- We can search by suffix and find all definitions in the codebase named 'x', and each of their aliases respectively. -.some> names.global x +TODO: swap this back to a 'ucm' block when names.global is re-implemented + +``` +-- We can search from a different branch and find all names in the codebase named 'x', and each of their aliases respectively. +scratch/other> names.global x -- We can search by hash, and see all aliases of that hash in the codebase -.some> names.global #gjmq673r1v +scratch/other> names.global #gjmq673r1v -- We can search using an absolute name -.some> names.global .some.place.x +scratch/other> names.global .some.place.x ``` diff --git a/unison-src/transcripts/names.output.md b/unison-src/transcripts/names.output.md index 287782fa2aa..c9b3389ecd7 100644 --- a/unison-src/transcripts/names.output.md +++ b/unison-src/transcripts/names.output.md @@ -1,5 +1,11 @@ # `names` command +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +``` Example uses of the `names` command and output ``` unison @@ -22,85 +28,67 @@ somewhere.y = 2 ⍟ These new definitions are ok to `add`: - some.otherplace.x : ##Nat - some.otherplace.y : ##Nat - some.place.x : ##Nat - somewhere.y : ##Nat - somewhere.z : ##Nat + some.otherplace.x : Nat + some.otherplace.y : Nat + some.place.x : Nat + somewhere.y : Nat + somewhere.z : Nat ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: - some.otherplace.x : ##Nat - some.otherplace.y : ##Nat - some.place.x : ##Nat - somewhere.y : ##Nat - somewhere.z : ##Nat + some.otherplace.x : Nat + some.otherplace.y : Nat + some.place.x : Nat + somewhere.y : Nat + somewhere.z : Nat ``` `names` searches relative to the current path. ``` ucm -- We can search by suffix and find all definitions named 'x', and each of their aliases respectively. --- But we don't see somewhere.z which is has the same value but is out of our namespace -.some> names x +scratch/main> names x Terms Hash: #gjmq673r1v - Names: otherplace.y place.x + Names: some.otherplace.y some.place.x somewhere.z Hash: #pi25gcdv0o - Names: otherplace.x + Names: some.otherplace.x Tip: Use `names.global` to see more results. -- We can search by hash, and see all aliases of that hash -.some> names #gjmq673r1v +scratch/main> names #gjmq673r1v Term Hash: #gjmq673r1v - Names: otherplace.y place.x + Names: some.otherplace.y some.place.x somewhere.z Tip: Use `names.global` to see more results. --- If the query is absolute, treat it as a `names.global` -.some> names .some.place.x +-- Works with absolute names too +scratch/main> names .some.place.x Term Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z + Names: some.otherplace.y some.place.x somewhere.z Tip: Use `names.global` to see more results. ``` `names.global` searches from the root, and absolutely qualifies results -``` ucm --- We can search by suffix and find all definitions in the codebase named 'x', and each of their aliases respectively. -.some> names.global x - - Terms - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - - Hash: #pi25gcdv0o - Names: .some.otherplace.x - --- We can search by hash, and see all aliases of that hash in the codebase -.some> names.global #gjmq673r1v - - Term - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z +TODO: swap this back to a 'ucm' block when names.global is re-implemented --- We can search using an absolute name -.some> names.global .some.place.x + -- We can search from a different branch and find all names in the codebase named 'x', and each of their aliases respectively. + scratch/other> names.global x + -- We can search by hash, and see all aliases of that hash in the codebase + scratch/other> names.global #gjmq673r1v + -- We can search using an absolute name + scratch/other> names.global .some.place.x - Term - Hash: #gjmq673r1v - Names: .some.otherplace.y .some.place.x .somewhere.z - -``` diff --git a/unison-src/transcripts/namespace-dependencies.md b/unison-src/transcripts/namespace-dependencies.md index 0e8223a6cc7..d60f7893675 100644 --- a/unison-src/transcripts/namespace-dependencies.md +++ b/unison-src/transcripts/namespace-dependencies.md @@ -1,5 +1,9 @@ # namespace.dependencies command +```ucm +scratch/main> builtins.merge lib.builtins +``` + ```unison:hide const a b = a external.mynat = 1 @@ -7,6 +11,6 @@ mynamespace.dependsOnText = const external.mynat 10 ``` ```ucm -.> add -.mynamespace> namespace.dependencies +scratch/main> add +scratch/main> namespace.dependencies mynamespace ``` diff --git a/unison-src/transcripts/namespace-dependencies.output.md b/unison-src/transcripts/namespace-dependencies.output.md index 80ea30e391f..f263473bf67 100644 --- a/unison-src/transcripts/namespace-dependencies.output.md +++ b/unison-src/transcripts/namespace-dependencies.output.md @@ -1,5 +1,11 @@ # namespace.dependencies command +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +``` ``` unison const a b = a external.mynat = 1 @@ -7,21 +13,21 @@ mynamespace.dependsOnText = const external.mynat 10 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: const : a -> b -> a - external.mynat : ##Nat - mynamespace.dependsOnText : ##Nat + external.mynat : Nat + mynamespace.dependsOnText : Nat -.mynamespace> namespace.dependencies +scratch/main> namespace.dependencies mynamespace - External dependency Dependents in .mynamespace - ##Nat 1. dependsOnText + External dependency Dependents in scratch/main:.mynamespace + lib.builtins.Nat 1. dependsOnText - .const 1. dependsOnText + const 1. dependsOnText - .external.mynat 1. dependsOnText + external.mynat 1. dependsOnText ``` diff --git a/unison-src/transcripts/propagate.md b/unison-src/transcripts/propagate.md index b5eaf3ede2b..19576d8bb80 100644 --- a/unison-src/transcripts/propagate.md +++ b/unison-src/transcripts/propagate.md @@ -78,47 +78,3 @@ type of `otherTerm` should remain the same. scratch/main> view preserve.someTerm scratch/main> view preserve.otherTerm ``` - -### Propagation only applies to the local branch - -Cleaning up a bit... - -```ucm -.subpath.lib> builtins.merge -``` - -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 -``` - -We'll make two copies of this namespace. - -```ucm -.subpath> add -.subpath> fork one two -``` - -Now let's edit one of the terms... - -```unison -someTerm : Optional x -> Optional x -someTerm _ = None -``` - -... in one of the namespaces... - -```ucm -.subpath.one> update.old -``` - -The other namespace should be left alone. - -```ucm -.subpath> view two.someTerm -``` diff --git a/unison-src/transcripts/propagate.output.md b/unison-src/transcripts/propagate.output.md index 14da5ae23ee..d438a96b370 100644 --- a/unison-src/transcripts/propagate.output.md +++ b/unison-src/transcripts/propagate.output.md @@ -175,93 +175,3 @@ scratch/main> view preserve.otherTerm preserve.otherTerm y = someTerm y ``` -### Propagation only applies to the local branch - -Cleaning up a bit... - -``` ucm - ☝️ The namespace .subpath.lib is empty. - -.subpath.lib> builtins.merge - - 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/reflog.md b/unison-src/transcripts/reflog.md index 202dc50820f..0bbb4f57df6 100644 --- a/unison-src/transcripts/reflog.md +++ b/unison-src/transcripts/reflog.md @@ -1,31 +1,41 @@ ```ucm:hide -.> builtins.merge +scratch/main> builtins.merge lib.builtins ``` -First we make two changes to the codebase, so that there's more than one line -for the `reflog` command to display: +First we make some changes to the codebase so there's data in the reflog. ```unison x = 1 ``` ```ucm -.> add +scratch/main> add ``` ```unison y = 2 ``` ```ucm -.> add -.> view y +scratch/main> add +scratch/main> branch /other +scratch/other> alias.term y z +newproject/main> builtins.merge lib.builtins +newproject/main> alias.type lib.builtins.Nat MyNat ``` + +Should see reflog entries from the current branch + ```ucm -.> reflog +scratch/main> reflog ``` -If we `reset-root` to its previous value, `y` disappears. +Should see reflog entries from the current project + ```ucm -.> reset-root 2 +scratch/main> project.reflog ``` -```ucm:error -.> view y + + +Should see reflog entries from all projects + +```ucm +scratch/main> reflog.global ``` diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index c78f00a839b..d0c001dcfd8 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -1,5 +1,4 @@ -First we make two changes to the codebase, so that there's more than one line -for the `reflog` command to display: +First we make some changes to the codebase so there's data in the reflog. ``` unison x = 1 @@ -19,7 +18,7 @@ x = 1 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -44,56 +43,93 @@ y = 2 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: y : Nat -.> view y +scratch/main> branch /other - y : Nat - y = 2 + Done. I've created the other branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /other`. + +scratch/other> alias.term y z + + Done. + +newproject/main> builtins.merge lib.builtins + + Done. + +newproject/main> alias.type lib.builtins.Nat MyNat + + Done. ``` +Should see reflog entries from the current branch + ``` ucm -.> reflog +scratch/main> reflog - Here is a log of the root namespace hashes, starting with the - most recent, along with the command that got us there. Try: + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. - `fork 2 .old` - `fork #p611n6o5ve .old` to make an old namespace - accessible again, - - `reset-root #p611n6o5ve` to reset the root namespace and - its history to that of the - specified namespace. + Tip: Use `diff.namespace 1 7` to compare between points in + history. - When Root Hash Action - 1. now #rmu2vgm86a add - 2. now #p611n6o5ve add - 3. now #4bigcpnl7t builtins.merge - 4. #sg60bvjo91 history starts here - - Tip: Use `diff.namespace 1 7` to compare namespaces between - two points in history. + Branch Hash Description + 1. scratch/main #6mdl5gruh5 add + 2. scratch/main #3rqf1hbev7 add + 3. scratch/main #ms9lggs2rg builtins.merge scratch/main:.lib.builtins + 4. scratch/main #sg60bvjo91 Project Created ``` -If we `reset-root` to its previous value, `y` disappears. +Should see reflog entries from the current project ``` ucm -.> reset-root 2 +scratch/main> project.reflog - Done. + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. scratch/other #148flqs4b1 alias.term scratch/other:..y scratch/other:.z + 2. scratch/other #6mdl5gruh5 Branch created from scratch/main + 3. scratch/main #6mdl5gruh5 add + 4. scratch/main #3rqf1hbev7 add + 5. scratch/main #ms9lggs2rg builtins.merge scratch/main:.lib.builtins + 6. scratch/main #sg60bvjo91 Project Created ``` +Should see reflog entries from all projects + ``` ucm -.> view y +scratch/main> reflog.global - ⚠️ + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. + + Tip: Use `diff.namespace 1 7` to compare between points in + history. - The following names were not found in the codebase. Check your spelling. - y + Branch Hash Description + 1. newproject/main #2rjhs2vq43 alias.term newproject/main:.lib.builtins.Nat newproject/main... + 2. newproject/main #ms9lggs2rg builtins.merge newproject/main:.lib.builtins + 3. newproject/main #sg60bvjo91 Branch Created + 4. scratch/other #148flqs4b1 alias.term scratch/other:..y scratch/other:.z + 5. scratch/other #6mdl5gruh5 Branch created from scratch/main + 6. scratch/main #6mdl5gruh5 add + 7. scratch/main #3rqf1hbev7 add + 8. scratch/main #ms9lggs2rg builtins.merge scratch/main:.lib.builtins + 9. scratch/main #sg60bvjo91 Project Created ``` diff --git a/unison-src/transcripts/reset.md b/unison-src/transcripts/reset.md index f8d18e7822a..2cd19597dec 100644 --- a/unison-src/transcripts/reset.md +++ b/unison-src/transcripts/reset.md @@ -2,28 +2,36 @@ scratch/main> builtins.merge ``` -# reset loose code ```unison -a = 5 +def = "first value" +``` + +```ucm:hide +scratch/main> update ``` +```unison:hide +def = "second value" +``` + +Can reset to a value from history by number. + ```ucm -scratch/main> add +scratch/main> update scratch/main> history scratch/main> reset 2 +scratch/main> view def scratch/main> history ``` -```unison -foo.a = 5 -``` +Can reset to a value from reflog by number. ```ucm -scratch/main> add -scratch/main> ls foo +scratch/main> reflog +-- Reset the current branch to the first history element +scratch/main> reset 2 +scratch/main> view def scratch/main> history -scratch/main> reset 1 foo -scratch/main> ls foo.foo ``` # reset branch @@ -32,47 +40,24 @@ scratch/main> ls foo.foo foo/main> history ``` -```unison +```unison:hide a = 5 ``` -```ucm -foo/main> add -foo/main> branch topic -foo/main> history -``` - -```unison -a = 3 -``` - ```ucm foo/main> update -foo/main> reset /topic -foo/main> history +foo/empty> reset /main:. +foo/empty> view a +foo/empty> history ``` -# ambiguous reset - -## ambiguous target -```unison +## second argument is always interpreted as a branch +```unison:hide main.a = 3 ``` -```ucm:error -foo/main> add +```ucm +foo/main> update foo/main> history foo/main> reset 2 main ``` - -## ambiguous hash - -```unison -main.a = 3 -``` - -```ucm:error -foo/main> switch /topic -foo/topic> add -foo/topic> reset main -``` diff --git a/unison-src/transcripts/reset.output.md b/unison-src/transcripts/reset.output.md index 8fa6362a9ab..26c2ad4e27c 100644 --- a/unison-src/transcripts/reset.output.md +++ b/unison-src/transcripts/reset.output.md @@ -1,7 +1,5 @@ -# reset loose code - ``` unison -a = 5 +def = "first value" ``` ``` ucm @@ -14,132 +12,117 @@ a = 5 ⍟ These new definitions are ok to `add`: - a : Nat + def : Text ``` +``` unison +def = "second value" +``` + +Can reset to a value from history by number. + ``` ucm -scratch/main> add +scratch/main> update - ⍟ I've added these definitions: - - a : Nat + Okay, I'm searching the branch for code that needs to be + updated... + + Done. scratch/main> history Note: The most recent namespace hash is immediately below this message. - ⊙ 1. #d079vet1oj + ⊙ 1. #5vq851j3hg + Adds / updates: - a + def - □ 2. #4bigcpnl7t (start of history) + ⊙ 2. #ujvq6e87kp + + + Adds / updates: + + def + + □ 3. #4bigcpnl7t (start of history) scratch/main> reset 2 Done. +scratch/main> view def + + def : Text + def = "first value" + scratch/main> history Note: The most recent namespace hash is immediately below this message. + ⊙ 1. #ujvq6e87kp + + Adds / updates: + + def - □ 1. #4bigcpnl7t (start of history) + □ 2. #4bigcpnl7t (start of history) ``` -``` unison -foo.a = 5 -``` +Can reset to a value from reflog by number. ``` ucm +scratch/main> reflog - 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: + Below is a record of recent changes, you can use + `reset #abcdef` to reset the current branch to a previous + state. - ⍟ These new definitions are ok to `add`: - - foo.a : Nat + Tip: Use `diff.namespace 1 7` to compare between points in + history. + + Branch Hash Description + 1. scratch/main #ujvq6e87kp reset ujvq6e87kp4288eq3al9v5luctic0ocd7ug1fu0go5bicrr2vfnrb0... + 2. scratch/main #5vq851j3hg update + 3. scratch/main #ujvq6e87kp update + 4. scratch/main #4bigcpnl7t builtins.merge + 5. scratch/main #sg60bvjo91 Project Created -``` -``` ucm -scratch/main> add +-- Reset the current branch to the first history element +scratch/main> reset 2 - ⍟ I've added these definitions: - - foo.a : Nat + Done. -scratch/main> ls foo +scratch/main> view def - 1. a (Nat) + def : Text + def = "second value" scratch/main> history Note: The most recent namespace hash is immediately below this message. - ⊙ 1. #tfg7r9359n + ⊙ 1. #5vq851j3hg + Adds / updates: - foo.a + def - □ 2. #4bigcpnl7t (start of history) - -scratch/main> reset 1 foo - - Done. - -scratch/main> ls foo.foo - - 1. a (Nat) - -``` -# reset branch - -``` ucm -foo/main> history - - ☝️ The namespace is empty. - -``` -``` unison -a = 5 -``` - -``` 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: + ⊙ 2. #ujvq6e87kp - ⍟ These new definitions are ok to `add`: + + Adds / updates: - a : ##Nat - -``` -``` ucm -foo/main> add - - ⍟ I've added these definitions: + def - a : ##Nat + □ 3. #4bigcpnl7t (start of history) -foo/main> branch topic - - Done. I've created the topic branch based off of main. - - Tip: To merge your work back into the main branch, first - `switch /main` then `merge /topic`. +``` +# reset branch +``` ucm foo/main> history Note: The most recent namespace hash is immediately below this @@ -147,27 +130,13 @@ foo/main> history - □ 1. #5l94rduvel (start of history) + □ 1. #sg60bvjo91 (start of history) ``` ``` unison -a = 3 +a = 5 ``` -``` 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: - - a : ##Nat - -``` ``` ucm foo/main> update @@ -176,11 +145,16 @@ foo/main> update Done. -foo/main> reset /topic +foo/empty> reset /main:. Done. -foo/main> history +foo/empty> view a + + a : ##Nat + a = 5 + +foo/empty> history Note: The most recent namespace hash is immediately below this message. @@ -190,33 +164,19 @@ foo/main> history □ 1. #5l94rduvel (start of history) ``` -# ambiguous reset - -## ambiguous target +## second argument is always interpreted as a branch ``` unison main.a = 3 ``` ``` ucm +foo/main> update - 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`: - - main.a : ##Nat - -``` -``` ucm -foo/main> add + Okay, I'm searching the branch for code that needs to be + updated... - ⍟ I've added these definitions: - - main.a : ##Nat + Done. foo/main> history @@ -233,49 +193,6 @@ foo/main> history foo/main> reset 2 main - I'm not sure if you wanted to reset the branch foo/main or the - namespace main in the current branch. Could you be more - specific? - - 1. /main (the branch main in the current project) - 2. main (the relative path main in the current branch) - - Tip: use `reset 1` or `reset 2` to - pick one of these. - -``` -## ambiguous hash - -``` unison -main.a = 3 -``` - -``` ucm - - Loading changes detected in scratch.u. - - I found and typechecked the definitions in scratch.u. This - file has been previously added to the codebase. - -``` -``` ucm -foo/main> switch /topic - -foo/topic> add - - ⍟ I've added these definitions: - - main.a : ##Nat - -foo/topic> reset main - - I'm not sure if you wanted to reset to the branch foo/main or - to the namespace main in the current branch. Could you be more - specific? - - 1. /main (the branch main in the current project) - 2. main (the relative path main in the current branch) - - Tip: use `reset 1` or `reset 2` to pick one of these. + Done. ``` diff --git a/unison-src/transcripts/resolution-failures.md b/unison-src/transcripts/resolution-failures.md index eff751b4a41..b9b97c999e7 100644 --- a/unison-src/transcripts/resolution-failures.md +++ b/unison-src/transcripts/resolution-failures.md @@ -4,6 +4,10 @@ This transcript tests the errors printed to the user when a name cannot be resol ## Codebase Setup +```ucm +scratch/main> builtins.merge lib.builtins +``` + First we define differing types with the same name in different namespaces: ```unison diff --git a/unison-src/transcripts/resolution-failures.output.md b/unison-src/transcripts/resolution-failures.output.md index d30deb42403..c4aaf989066 100644 --- a/unison-src/transcripts/resolution-failures.output.md +++ b/unison-src/transcripts/resolution-failures.output.md @@ -4,6 +4,12 @@ This transcript tests the errors printed to the user when a name cannot be resol ## Codebase Setup +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +``` First we define differing types with the same name in different namespaces: ``` unison @@ -26,8 +32,8 @@ two.ambiguousTerm = "term two" type one.AmbiguousType type two.AmbiguousType - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text + one.ambiguousTerm : Text + two.ambiguousTerm : Text ``` ``` ucm @@ -37,8 +43,8 @@ scratch/main> add type one.AmbiguousType type two.AmbiguousType - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text + one.ambiguousTerm : Text + two.ambiguousTerm : Text ``` ## Tests @@ -114,7 +120,7 @@ useAmbiguousTerm = ambiguousTerm I found some terms in scope that have matching names and types. Maybe you meant one of these: - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text + one.ambiguousTerm : Text + two.ambiguousTerm : Text ``` diff --git a/unison-src/transcripts/tab-completion.md b/unison-src/transcripts/tab-completion.md index c270308fa76..e7b7e8b76c4 100644 --- a/unison-src/transcripts/tab-completion.md +++ b/unison-src/transcripts/tab-completion.md @@ -43,9 +43,9 @@ absolute.term = "absolute" ``` ```ucm -.> add +scratch/main> add -- Should tab complete absolute names -.> debug.tab-complete view .absolute.te +scratch/main> debug.tab-complete view .absolute.te ``` ## Tab complete namespaces diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 98c26e77f33..2c0103bb957 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -94,14 +94,14 @@ absolute.term = "absolute" ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: absolute.term : ##Text -- Should tab complete absolute names -.> debug.tab-complete view .absolute.te +scratch/main> debug.tab-complete view .absolute.te * .absolute.term diff --git a/unison-src/transcripts/transcript-parser-commands.md b/unison-src/transcripts/transcript-parser-commands.md index e39fd10885f..afd90011ead 100644 --- a/unison-src/transcripts/transcript-parser-commands.md +++ b/unison-src/transcripts/transcript-parser-commands.md @@ -1,7 +1,7 @@ ### Transcript parser operations ```ucm:hide -.> builtins.merge +scratch/main> builtins.merge ``` The transcript parser is meant to parse `ucm` and `unison` blocks. @@ -11,7 +11,7 @@ x = 1 ``` ```ucm -.> add +scratch/main> add ``` ```unison:hide:error:scratch.u @@ -19,11 +19,11 @@ z ``` ```ucm:error -.> delete foo +scratch/main> delete foo ``` ```ucm :error -.> delete lineToken.call +scratch/main> delete lineToken.call ``` However handling of blocks of other languages should be supported. diff --git a/unison-src/transcripts/transcript-parser-commands.output.md b/unison-src/transcripts/transcript-parser-commands.output.md index f6971c59e2b..af7d730d15c 100644 --- a/unison-src/transcripts/transcript-parser-commands.output.md +++ b/unison-src/transcripts/transcript-parser-commands.output.md @@ -20,7 +20,7 @@ x = 1 ``` ``` ucm -.> add +scratch/main> add ⍟ I've added these definitions: @@ -36,7 +36,7 @@ z ``` ``` ucm -.> delete foo +scratch/main> delete foo ⚠️ @@ -45,7 +45,7 @@ z ``` ``` ucm -.> delete lineToken.call +scratch/main> delete lineToken.call ⚠️ diff --git a/unison-src/transcripts/undo.md b/unison-src/transcripts/undo.md new file mode 100644 index 00000000000..112fc30eb3c --- /dev/null +++ b/unison-src/transcripts/undo.md @@ -0,0 +1,51 @@ +# Undo + +Undo should pop a node off of the history of the current branch. + +```unison:hide +x = 1 +``` + +```ucm +scratch/main> builtins.merge lib.builtins +scratch/main> add +scratch/main> ls +scratch/main> alias.term x y +scratch/main> ls +scratch/main> history +scratch/main> undo +scratch/main> ls +scratch/main> history +``` + +--- + +It should not be affected by changes on other branches. + +```unison:hide +x = 1 +``` + +```ucm +scratch/branch1> builtins.merge lib.builtins +scratch/branch1> add +scratch/branch1> ls +scratch/branch1> alias.term x y +scratch/branch1> ls +scratch/branch1> history +-- Make some changes on an unrelated branch +scratch/branch2> builtins.merge lib.builtins +scratch/branch2> delete.namespace lib +scratch/branch1> undo +scratch/branch1> ls +scratch/branch1> history +``` + +--- + +Undo should be a no-op on a newly created branch + +```ucm:error +scratch/main> branch.create-empty new +scratch/new> undo +``` diff --git a/unison-src/transcripts/undo.output.md b/unison-src/transcripts/undo.output.md new file mode 100644 index 00000000000..32933a2fb96 --- /dev/null +++ b/unison-src/transcripts/undo.output.md @@ -0,0 +1,199 @@ +# Undo + +Undo should pop a node off of the history of the current branch. + +``` unison +x = 1 +``` + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. + +scratch/main> add + + ⍟ I've added these definitions: + + x : Nat + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> alias.term x y + + Done. + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + 3. y (Nat) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #nmem6r6no1 + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + ⊙ 2. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 3. #ms9lggs2rg (start of history) + +scratch/main> undo + + Here are the changes I undid + + Name changes: + + Original Changes + 1. x 2. y (added) + +scratch/main> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 2. #ms9lggs2rg (start of history) + +``` +----- + +It should not be affected by changes on other branches. + +``` unison +x = 1 +``` + +``` ucm +scratch/branch1> builtins.merge lib.builtins + + Done. + +scratch/branch1> add + + ⍟ I've added these definitions: + + x : Nat + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/branch1> alias.term x y + + Done. + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + 3. y (Nat) + +scratch/branch1> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #nmem6r6no1 + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + ⊙ 2. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 3. #ms9lggs2rg (start of history) + +-- Make some changes on an unrelated branch +scratch/branch2> builtins.merge lib.builtins + + Done. + +scratch/branch2> delete.namespace lib + + Done. + +scratch/branch1> undo + + Here are the changes I undid + + Name changes: + + Original Changes + 1. x 2. y (added) + +scratch/branch1> ls + + 1. lib/ (469 terms, 74 types) + 2. x (Nat) + +scratch/branch1> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #3rqf1hbev7 + + + Adds / updates: + + x + + □ 2. #ms9lggs2rg (start of history) + +``` +----- + +Undo should be a no-op on a newly created branch + +``` ucm +scratch/main> branch.create-empty new + + Done. I've created an empty branch scratch/new. + + Tip: Use `merge /somebranch` to initialize this branch. + +scratch/new> undo + + ⚠️ + + Nothing more to undo. + +``` diff --git a/unison-src/transcripts/view.md b/unison-src/transcripts/view.md index 89b81cf51f0..f281cf3eca1 100644 --- a/unison-src/transcripts/view.md +++ b/unison-src/transcripts/view.md @@ -1,7 +1,7 @@ # View commands ```ucm:hide -.> builtins.merge +scratch/main> builtins.merge ``` ```unison:hide @@ -10,16 +10,22 @@ b.thing = "b" ``` ```ucm:hide -.> add +scratch/main> add ``` ```ucm -- Should suffix-search and find values in sub-namespaces -.> view thing --- Should be local to namespace -.a> view thing +scratch/main> view thing +-- Should support absolute paths +scratch/main> view .b.thing +``` + + +TODO: swap this back to a 'ucm' block when view.global is re-implemented + +``` -- view.global should search globally and be absolutely qualified -.a> view.global thing --- Should support absolute paths outside of current namespace -.a> view .b.thing +scratch/other> view.global thing +-- Should support branch relative paths +scratch/other> view /main:.a.thing ``` diff --git a/unison-src/transcripts/view.output.md b/unison-src/transcripts/view.output.md index b5cc5149d1c..6a8613378e4 100644 --- a/unison-src/transcripts/view.output.md +++ b/unison-src/transcripts/view.output.md @@ -7,7 +7,7 @@ b.thing = "b" ``` ucm -- Should suffix-search and find values in sub-namespaces -.> view thing +scratch/main> view thing a.thing : Text a.thing = "a" @@ -15,25 +15,17 @@ b.thing = "b" b.thing : Text b.thing = "b" --- Should be local to namespace -.a> view thing +-- Should support absolute paths +scratch/main> view .b.thing - thing : ##Text - thing = "a" - --- view.global should search globally and be absolutely qualified -.a> view.global thing - - .a.thing : Text - .a.thing = "a" - .b.thing : Text .b.thing = "b" --- Should support absolute paths outside of current namespace -.a> view .b.thing +``` +TODO: swap this back to a 'ucm' block when view.global is re-implemented - .b.thing : Text - .b.thing = "b" + -- view.global should search globally and be absolutely qualified + scratch/other> view.global thing + -- Should support branch relative paths + scratch/other> view /main:.a.thing -```