Merge remote-tracking branch 'origin/trunk' into merged-ghc-upgrade-try-2

.github/workflows/ci.md

@@ -9,7 +9,7 @@ At a high level, the CI process is:
 Some version numbers that are used during CI:
 - `ormolu_version: "0.5.0.1"`
 - `racket_version: "8.7"`
-- `jit_version: "@unison/internal/releases/0.0.17"`
+- `jit_version: "@unison/internal/releases/0.0.18"`
 
 Some cached directories:
   - `ucm_local_bin` a temp path for caching a built `ucm`

.github/workflows/ci.yaml

@@ -14,7 +14,7 @@ on:
 env:
   ormolu_version: 0.5.2.0
   ucm_local_bin: ucm-local-bin
-  jit_version: "@unison/internal/releases/0.0.17"
+  jit_version: "@unison/internal/releases/0.0.18"
   jit_src_scheme: unison-jit-src/scheme-libs/racket
   jit_dist: unison-jit-dist
   jit_generator_os: ubuntu-20.04

.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
 

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

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)

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 {..}

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,
@@ -287,6 +289,7 @@ module U.Codebase.Sqlite.Queries
     -- * Types
     NamespaceText,
     TextPathSegments,
+    JsonParseFailure(..),
   )
 where
 
@@ -315,6 +318,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 +371,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 +404,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 +420,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 +434,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 +473,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 +1341,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,16 +3474,8 @@ loadNamespaceStatsByHashId bhId = do
       WHERE namespace_hash_id = :bhId
     |]
 
-appendReflog :: Reflog.Entry CausalHashId Text -> Transaction ()
-appendReflog entry =
-  execute
-    [sql|
-      INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason)
-      VALUES (@entry, @, @, @)
-    |]
-
-getReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
-getReflog numEntries =
+getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
+getDeprecatedRootReflog numEntries =
   queryListRow
     [sql|
       SELECT time, from_root_causal_id, to_root_causal_id, reason
@@ -3514,6 +3484,49 @@ getReflog numEntries =
       LIMIT :numEntries
     |]
 
+appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
+appendProjectBranchReflog entry =
+  execute
+    [sql|
+      INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason)
+      VALUES (@entry, @, @, @, @, @)
+    |]
+
+-- | 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 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
+    |]
+
 -- | Does a project exist with this id?
 projectExists :: ProjectId -> Transaction Bool
 projectExists projectId =
@@ -3803,12 +3816,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 +3832,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 +3890,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 +3914,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 +4430,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.

codebase2/codebase-sqlite/package.yaml

@@ -27,10 +27,12 @@ dependencies:
   - nonempty-containers
   - safe
   - text
+  - time
   - transformers
   - unison-codebase
   - unison-codebase-sync
   - unison-core
+  - unison-core1
   - unison-core-orphans-sqlite
   - unison-hash
   - unison-hash-orphans-sqlite
@@ -39,7 +41,6 @@ dependencies:
   - unison-util-base32hex
   - unison-util-cache
   - unison-util-file-embed
-  - unison-util-nametree
   - unison-util-serialization
   - unison-util-term
   - unliftio

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;

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
+);
+
+

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;

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,11 +125,13 @@ library
     , nonempty-containers
     , safe
     , text
+    , time
     , transformers
     , unison-codebase
     , unison-codebase-sync
     , unison-core
     , unison-core-orphans-sqlite
+    , unison-core1
     , unison-hash
     , unison-hash-orphans-sqlite
     , unison-prelude
@@ -133,7 +139,6 @@ library
     , unison-util-base32hex
     , unison-util-cache
     , unison-util-file-embed
-    , unison-util-nametree
     , unison-util-serialization
     , unison-util-term
     , unliftio

contrib/cabal.project

@@ -24,7 +24,6 @@ packages:
   lib/unison-util-relation
   lib/unison-util-rope
   lib/unison-util-file-embed
-  lib/unison-util-nametree
 
   parser-typechecker
   unison-core

lib/unison-prelude/src/Unison/Debug.hs

@@ -147,7 +147,7 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb
 debug :: (Show a) => DebugFlag -> String -> a -> a
 debug flag msg a =
   if shouldDebug flag
-    then (pTrace (msg <> ":\n" <> into @String (pShow a)) a)
+    then (trace (msg <> ":\n" <> into @String (pShow a)) a)
     else a
 
 -- | Use for selective debug logging in monadic contexts.

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 _tempNameCounter)) 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 _tempNameCoun
 
 -- 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) ->

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
       }

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

lib/unison-util-nametree/package.yaml

@@ -1,56 +0,0 @@
-name: unison-util-nametree
-github: unisonweb/unison
-copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
-
-ghc-options: -Wall
-
-dependencies:
-  - base
-  - containers
-  - lens
-  - semialign
-  - semigroups
-  - these
-  - unison-core
-  - unison-core1
-  - unison-prelude
-  - unison-util-relation
-
-library:
-  source-dirs: src
-  when:
-    - condition: false
-      other-modules: Paths_unison_util_nametree
-
-default-extensions:
-  - BangPatterns
-  - BlockArguments
-  - DeriveAnyClass
-  - DeriveFoldable
-  - DeriveFunctor
-  - DeriveGeneric
-  - DeriveTraversable
-  - DerivingStrategies
-  - DerivingVia
-  - DoAndIfThenElse
-  - DuplicateRecordFields
-  - FlexibleContexts
-  - FlexibleInstances
-  - GADTs
-  - GeneralizedNewtypeDeriving
-  - ImportQualifiedPost
-  - InstanceSigs
-  - LambdaCase
-  - MultiParamTypeClasses
-  - MultiWayIf
-  - NamedFieldPuns
-  - NumericUnderscores
-  - OverloadedLabels
-  - OverloadedRecordDot
-  - OverloadedStrings
-  - PatternSynonyms
-  - RankNTypes
-  - ScopedTypeVariables
-  - TupleSections
-  - TypeApplications
-  - ViewPatterns

lib/unison-util-nametree/unison-util-nametree.cabal

@@ -1,68 +0,0 @@
-cabal-version: 1.12
-
--- This file has been generated from package.yaml by hpack version 0.36.0.
---
--- see: https://github.com/sol/hpack
-
-name:           unison-util-nametree
-version:        0.0.0
-homepage:       https://github.com/unisonweb/unison#readme
-bug-reports:    https://github.com/unisonweb/unison/issues
-copyright:      Copyright (C) 2013-2018 Unison Computing, PBC and contributors
-build-type:     Simple
-
-source-repository head
-  type: git
-  location: https://github.com/unisonweb/unison
-
-library
-  exposed-modules:
-      Unison.Util.Defns
-      Unison.Util.Nametree
-  hs-source-dirs:
-      src
-  default-extensions:
-      BangPatterns
-      BlockArguments
-      DeriveAnyClass
-      DeriveFoldable
-      DeriveFunctor
-      DeriveGeneric
-      DeriveTraversable
-      DerivingStrategies
-      DerivingVia
-      DoAndIfThenElse
-      DuplicateRecordFields
-      FlexibleContexts
-      FlexibleInstances
-      GADTs
-      GeneralizedNewtypeDeriving
-      ImportQualifiedPost
-      InstanceSigs
-      LambdaCase
-      MultiParamTypeClasses
-      MultiWayIf
-      NamedFieldPuns
-      NumericUnderscores
-      OverloadedLabels
-      OverloadedRecordDot
-      OverloadedStrings
-      PatternSynonyms
-      RankNTypes
-      ScopedTypeVariables
-      TupleSections
-      TypeApplications
-      ViewPatterns
-  ghc-options: -Wall
-  build-depends:
-      base
-    , containers
-    , lens
-    , semialign
-    , semigroups
-    , these
-    , unison-core
-    , unison-core1
-    , unison-prelude
-    , unison-util-relation
-  default-language: Haskell2010

lib/unison-util-relation/src/Unison/Util/BiMultimap.hs

@@ -178,6 +178,7 @@ invertDomain =
     g x acc y =
       Map.insert y x acc
 
+-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements.
 fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
 fromRange m =
   BiMultimap (Map.foldlWithKey' f Map.empty m) m

parser-typechecker/package.yaml

@@ -126,7 +126,6 @@ dependencies:
   - unison-util-base32hex
   - unison-util-bytes
   - unison-util-cache
-  - unison-util-nametree
   - unison-util-relation
   - unison-util-rope
   - unison-util-serialization

parser-typechecker/src/Unison/Builtin/Decls.hs

@@ -776,8 +776,8 @@ tupleTerm = foldr tupleConsTerm (unitTerm mempty)
 forceTerm :: (Var v) => a -> a -> Term v a -> Term v a
 forceTerm a au e = Term.app a e (unitTerm au)
 
-delayTerm :: (Var v) => a -> Term v a -> Term v a
-delayTerm a = Term.lam a $ Var.typed Var.Delay
+delayTerm :: (Var v) => a -> a -> Term v a -> Term v a
+delayTerm spanAnn argAnn = Term.lam spanAnn (argAnn, Var.typed Var.Delay)
 
 unTupleTerm ::
   Term.Term2 vt at ap v a ->

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
 
--- | 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.
+getShallowBranchAtProjectPath ::
+  PP.ProjectPath ->
+  Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
+getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp
+
+-- | 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
+  preloadBranch codebase ch

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -139,6 +139,7 @@ import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude hiding (empty)
 import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
+import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.Util.List qualified as List
@@ -148,7 +149,6 @@ import Unison.Util.Set qualified as Set
 import Unison.Util.Star2 qualified as Star2
 import Witherable (FilterableWithIndex (imapMaybe))
 import Prelude hiding (head, read, subtract)
-import qualified Unison.Reference as Reference
 
 instance AsEmpty (Branch m) where
   _Empty = prism' (const empty) matchEmpty
@@ -215,7 +215,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
 deepTypeReferenceIds =
   Set.mapMaybe Reference.toId . deepTypeReferences
 
-
 namespaceStats :: Branch0 m -> NamespaceStats
 namespaceStats b =
   NamespaceStats

parser-typechecker/src/Unison/Codebase/BranchUtil.hs

@@ -25,6 +25,7 @@ import Unison.Codebase.Branch (Branch, Branch0)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
+import Unison.NameSegment (NameSegment)
 import Unison.HashQualifiedPrime (HashQualified (HashQualified, NameOnly))
 import Unison.Names (Names)
 import Unison.Names qualified as Names
@@ -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)

parser-typechecker/src/Unison/Codebase/Causal.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Unison.Codebase.Causal
-  ( Causal (currentHash, head, tail, tails),
+  ( Causal (currentHash, valueHash, head, tail, tails),
     pattern One,
     pattern Cons,
     pattern Merge,
@@ -40,7 +40,8 @@ import Unison.Codebase.Causal.Type
         currentHash,
         head,
         tail,
-        tails
+        tails,
+        valueHash
       ),
     before,
     lca,

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)

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} ()")

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)

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.Absolute path)) =
+    into @Text (ProjectAndBranch proj branch) <> ":" <> Path.toText path
+
+instance From (ProjectPathG () ProjectBranchName) Text where
+  from (ProjectPath () branch (Path.Absolute path)) =
+    "/" <> into @Text branch <> ":" <> Path.toText 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

parser-typechecker/src/Unison/Codebase/RootBranchCache.hs

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

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

parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs

@@ -18,12 +18,9 @@ import Data.Either.Extra ()
 import Data.IORef
 import Data.Map qualified as Map
 import Data.Set qualified as Set
-import Data.Time (getCurrentTime)
 import System.Console.ANSI qualified as ANSI
 import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
 import U.Codebase.HashTags (CausalHash, PatchHash (..))
-import U.Codebase.Reflog qualified as Reflog
-import U.Codebase.Sqlite.Operations qualified as Ops
 import U.Codebase.Sqlite.Queries qualified as Q
 import U.Codebase.Sqlite.Sync22 qualified as Sync22
 import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
@@ -37,10 +34,8 @@ import Unison.Codebase.Init qualified as Codebase
 import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1
 import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
 import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1
-import Unison.Codebase.RootBranchCache
 import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
 import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
-import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
 import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations
 import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
 import Unison.Codebase.SqliteCodebase.Paths
@@ -59,9 +54,12 @@ import Unison.Sqlite qualified as Sqlite
 import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
+import Unison.Util.Cache qualified as Cache
 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,17 @@ 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
+  -- The branchLoadCache ephemerally caches branches in memory, but doesn't prevent them from being GC'd.
+  -- This is very useful when loading root branches because the cache shouldn't be limited in size.
+  -- But this cache will automatically clean itself up and remove entries that are no longer reachable.
+  -- If you load another branch, which shares namespaces with another branch that's in memory (and therefor in the cache)
+  -- then those shared namespaces will be loaded from the cache and will be shared in memory.
+  branchLoadCache <- newBranchCache
+  -- The rootBranchCache is a semispace cache which keeps the most recent branch roots (e.g. project roots) alive in memory.
+  -- Unlike the branchLoadCache, this cache is bounded in size and will evict older branches when it reaches its limit.
+  -- The two work in tandem, so the rootBranchCache keeps relevant branches alive, and the branchLoadCache
+  -- stores ALL the subnamespaces of those branches, deduping them when loading from the DB.
+  rootBranchCache <- Cache.semispaceCache 10
   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,47 +244,28 @@ 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))
-            getBranchForHash h =
-              fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h)
+            getBranchForHash =
+              Cache.applyDefined rootBranchCache \h -> do
+                fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchLoadCache getDeclType h)
 
             putBranch :: Branch m -> m ()
             putBranch branch =
               withRunInIO \runInIO ->
-                runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)))
+                runInIO $ do
+                  Cache.insert rootBranchCache (Branch.headHash branch) branch
+                  runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))
+
+            preloadBranch :: CausalHash -> m ()
+            preloadBranch h = do
+              void . UnliftIO.forkIO $ void $ do
+                getBranchForHash h >>= \case
+                  Nothing -> pure ()
+                  Just b -> do
+                    UnliftIO.evaluate b
+                    pure ()
 
             syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m ()
             syncFromDirectory srcRoot b =
@@ -334,8 +321,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
                   putTypeDeclaration,
                   putTypeDeclarationComponent,
                   getTermComponentWithTypes,
-                  getRootBranch,
-                  putRootBranch,
                   getBranchForHash,
                   putBranch,
                   syncFromDirectory,
@@ -347,7 +332,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
                   filterTermsByReferentIdHavingTypeImpl,
                   termReferentsByPrefix = referentsByPrefix,
                   withConnection = withConn,
-                  withConnectionIO = withConnection debugName root
+                  withConnectionIO = withConnection debugName root,
+                  preloadBranch
                 }
         Right <$> action codebase
   where

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 <enter> 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.")

parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs

@@ -0,0 +1,269 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where
+
+import Control.Lens
+import Data.Aeson qualified as Aeson
+import Data.Map qualified as Map
+import Data.Text qualified as Text
+import Data.Text.Encoding 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
+
+  -- Try to set the recent project branch to what it was, default back to scratch if it doesn't exist or the user is in
+  -- loose code.
+  mayRecentProjectBranch <- runMaybeT $ do
+    (projectId, branchId) <- MaybeT getMostRecentProjectBranchIds
+    -- Make sure the project-branch still exists.
+    _projBranch <- MaybeT $ Q.loadProjectBranch projectId branchId
+    pure (projectId, branchId)
+
+  Debug.debugLogM Debug.Migration "Adding current project path table"
+  Q.addCurrentProjectPathTable
+  Debug.debugLogM Debug.Migration "Setting current project path to scratch project"
+
+  case mayRecentProjectBranch of
+    Just (projectId, branchId) ->
+      Q.setCurrentProjectPath projectId branchId []
+    Nothing -> 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)
+    |]
+  -- Delete any project branch rows that don't have a matching branch in the current root.
+  Sqlite.execute
+    [Sqlite.sql|
+    DELETE FROM most_recent_branch AS mrb
+      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = mrb.project_id AND npb.branch_id = mrb.branch_id)
+    |]
+
+  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"
+
+expectMostRecentNamespace :: Sqlite.Transaction [NameSegment]
+expectMostRecentNamespace =
+  Sqlite.queryOneColCheck
+    [Sqlite.sql|
+      SELECT namespace
+      FROM most_recent_namespace
+    |]
+    check
+  where
+    check :: Text -> Either Q.JsonParseFailure [NameSegment]
+    check bytes =
+      case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
+        Left failure -> Left (Q.JsonParseFailure {bytes, failure = Text.pack failure})
+        Right namespace -> Right (map NameSegment namespace)
+
+getMostRecentProjectBranchIds :: Sqlite.Transaction (Maybe (ProjectId, ProjectBranchId))
+getMostRecentProjectBranchIds = do
+  nameSegments <- expectMostRecentNamespace
+  case nameSegments of
+    (proj : UUIDNameSegment projectId : branches : UUIDNameSegment branchId : _)
+      | proj == projectsNameSegment && branches == branchesNameSegment ->
+          pure . Just $ (ProjectId projectId, ProjectBranchId branchId)
+    _ -> pure Nothing

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

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}

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

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)

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.
+    preloadBranch :: CausalHash -> m ()
   }
 
 -- | Whether a codebase is local or remote.

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 =

parser-typechecker/src/Unison/Project/Util.hs

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

parser-typechecker/src/Unison/Runtime/ANF.hs

@@ -169,7 +169,7 @@ expandSimple keep (v, bnd) = (v, apps' (var a v) evs)
     evs = map (var a) . Set.toList $ Set.difference fvs keep
 
 abstract :: (Var v) => Set v -> Term v a -> Term v a
-abstract keep bnd = lam' a evs bnd
+abstract keep bnd = lamWithoutBindingAnns a evs bnd
   where
     a = ABT.annotation bnd
     fvs = ABT.freeVars bnd
@@ -205,7 +205,7 @@ enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) =
     annotate tm
       | Ann' _ ty <- b = ann a tm ty
       | otherwise = tm
-    lamb = lam' a evs (annotate $ lam' a vs lbody)
+    lamb = lamWithoutBindingAnns a evs (annotate $ lamWithoutBindingAnns a vs lbody)
 enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
   Just $ if null evs then lamb else apps' lamb $ map (var a) evs
   where
@@ -218,7 +218,7 @@ enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
     annotate tm
       | Just ty <- mty = ann a tm ty
       | otherwise = tm
-    lamb = lam' a (evs ++ vs0) . annotate . lam' a vs1 $ lbody
+    lamb = lamWithoutBindingAnns a (evs ++ vs0) . annotate . lamWithoutBindingAnns a vs1 $ lbody
 enclose keep rec t@(Handle' h body)
   | isStructured body =
       Just . handle (ABT.annotation t) (rec keep h) $ apps' lamb args
@@ -232,8 +232,8 @@ enclose keep rec t@(Handle' h body)
       | null evs = [constructor a (ConstructorReference Ty.unitRef 0)]
       | otherwise = var a <$> evs
     lamb
-      | null evs = lam' a [fv] lbody
-      | otherwise = lam' a evs lbody
+      | null evs = lamWithoutBindingAnns a [fv] lbody
+      | otherwise = lamWithoutBindingAnns a evs lbody
 enclose keep rec t@(Match' s0 cs0) = Just $ match a s cs
   where
     a = ABT.annotation t
@@ -331,7 +331,7 @@ beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
       vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of
         LamsNamed' vs b
           | Just n <- Map.lookup v m ->
-              lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
+              lamWithoutBindingAnns (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
         -- shouldn't happen
         b -> dropPrefixes m b
 
@@ -340,7 +340,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
   | n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e)
   | otherwise = Nothing
   where
-    lamb = lam' al (drop n vs) (bd)
+    lamb = lamWithoutBindingAnns al (drop n vs) (bd)
     al = ABT.annotation l
     -- Calculate a maximum number of arguments to drop.
     -- Enclosing doesn't create let-bound lambdas, so we
@@ -353,7 +353,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
 beta rec (Apps' l@(LamsNamed' vs body) as)
   | n <- matchVars 0 vs as,
     n > 0 =
-      Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as)
+      Just $ apps' (lamWithoutBindingAnns al (drop n vs) (rec body)) (drop n as)
   | otherwise = Nothing
   where
     al = ABT.annotation l
@@ -422,7 +422,7 @@ groupFloater rec vbs = do
   where
     rec' b
       | Just (vs0, mty, vs1, bd) <- unLamsAnnot b =
-          lam' a vs0 . maybe id (flip $ ann a) mty . lam' a vs1 <$> rec bd
+          lamWithoutBindingAnns a vs0 . maybe id (flip $ ann a) mty . lamWithoutBindingAnns a vs1 <$> rec bd
       where
         a = ABT.annotation b
     rec' b = rec b
@@ -453,12 +453,12 @@ lamFloater closed tm mv a vs bd =
       let v = ABT.freshIn cvs $ fromMaybe (typed Var.Float) mv
        in ( v,
             ( Set.insert v cvs,
-              ctx <> [(v, lam' a vs bd)],
+              ctx <> [(v, lamWithoutBindingAnns a vs bd)],
               floatDecomp closed v tm dcmp
             )
           )
   where
-    tgt = unannotate (lam' a vs bd)
+    tgt = unannotate (lamWithoutBindingAnns a vs bd)
     p (_, flam) = unannotate flam == tgt
 
 floatDecomp ::
@@ -479,7 +479,7 @@ floater top rec tm0@(Ann' tm ty) =
 floater top rec (LetRecNamed' vbs e) =
   Just $
     letFloater rec vbs e >>= \case
-      lm@(LamsNamed' vs bd) | top -> lam' a vs <$> rec bd
+      lm@(LamsNamed' vs bd) | top -> lamWithoutBindingAnns a vs <$> rec bd
         where
           a = ABT.annotation lm
       tm -> rec tm
@@ -492,7 +492,7 @@ floater _ rec (Let1Named' v b e)
   where
     a = ABT.annotation b
 floater top rec tm@(LamsNamed' vs bd)
-  | top = Just $ lam' a vs <$> rec bd
+  | top = Just $ lamWithoutBindingAnns a vs <$> rec bd
   | otherwise = Just $ do
       bd <- rec bd
       lv <- lamFloater True tm Nothing a vs bd
@@ -627,7 +627,7 @@ saturate dat = ABT.visitPure $ \case
         | m < n,
           vs <- snd $ mapAccumL frsh fvs [1 .. n - m],
           nargs <- var mempty <$> vs ->
-            Just . lam' mempty vs . apps' f $ args' ++ nargs
+            Just . lamWithoutBindingAnns mempty vs . apps' f $ args' ++ nargs
         | m > n,
           (sargs, eargs) <- splitAt n args',
           sv <- Var.freshIn fvs $ typed Var.Eta ->

parser-typechecker/src/Unison/Runtime/Decompile.hs

@@ -230,7 +230,11 @@ decompileForeign backref topTerms f
   | Just s <- unwrapSeq f =
       list' () <$> traverse (decompile backref topTerms) s
 decompileForeign _ _ (Wrap r _) =
-  err (BadForeign r) $ bug "<Foreign>"
+  err (BadForeign r) $ bug text
+  where
+    text
+      | Builtin name <- r = "<" <> name <> ">"
+      | otherwise = "<Foreign>"
 
 decompileBytes :: (Var v) => By.Bytes -> Term v ()
 decompileBytes =

parser-typechecker/src/Unison/Runtime/Machine.hs

@@ -384,7 +384,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 DBTX i)
       ustk <- bump ustk
       bstk <- case tracer env False clo of
         NoTrace -> bstk <$ poke ustk 0
-        MsgTrace _ tx _ -> do
+        MsgTrace _ _ tx -> do
           poke ustk 1
           bstk <- bump bstk
           bstk <$ pokeBi bstk (Util.Text.pack tx)

parser-typechecker/src/Unison/Syntax/TermParser.hs

@@ -38,8 +38,8 @@ import Unison.NameSegment qualified as NameSegment
 import Unison.Names (Names)
 import Unison.Names qualified as Names
 import Unison.NamesWithHistory qualified as Names
-import Unison.Parser.Ann qualified as Ann
 import Unison.Parser.Ann (Ann)
+import Unison.Parser.Ann qualified as Ann
 import Unison.Pattern (Pattern)
 import Unison.Pattern qualified as Pattern
 import Unison.Prelude
@@ -348,7 +348,9 @@ parsePattern = label "pattern" root
 lam :: (Var v) => TermP v m -> TermP v m
 lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved "->") <*> p
   where
-    mkLam vs b = Term.lam' (ann (head vs) <> ann b) (map L.payload vs) b
+    mkLam vs b =
+      let annotatedArgs = vs <&> \v -> (ann v, L.payload v)
+       in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
 
 letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
 letBlock = label "let" $ (snd <$> block "let")
@@ -383,7 +385,8 @@ lamCase = do
         es -> DD.tupleTerm es
       anns = ann start <> ann (NonEmpty.last cases)
       matchTerm = Term.match anns lamvarTerm (toList cases)
-  pure $ Term.lam' anns vars matchTerm
+  let annotatedVars = (Ann.GeneratedFrom $ ann start,) <$> vars
+  pure $ Term.lam' anns annotatedVars matchTerm
 
 ifthen = label "if" do
   start <- peekAny
@@ -412,7 +415,7 @@ hashQualifiedPrefixTerm = resolveHashQualified =<< hqPrefixId
 hashQualifiedInfixTerm :: (Monad m, Var v) => TermP v m
 hashQualifiedInfixTerm = resolveHashQualified =<< hqInfixId
 
-quasikeyword :: Ord v => Text -> P v m (L.Token ())
+quasikeyword :: (Ord v) => Text -> P v m (L.Token ())
 quasikeyword kw = queryToken \case
   L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just ()
   _ -> Nothing
@@ -595,11 +598,12 @@ doc2Block = do
           "syntax.docExample" -> do
             trm <- term
             endTok <- closeBlock
-            pure . (ann startTok <> ann endTok,) $ case trm of
+            let spanAnn = ann startTok <> ann endTok
+            pure . (spanAnn,) $ case trm of
               tm@(Term.Apps' _ xs) ->
                 let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs
                     n = Term.nat (ann tm) (fromIntegral (length fvs))
-                    lam = addDelay $ Term.lam' (ann tm) fvs tm
+                    lam = addDelay $ Term.lam' (ann tm) ((Ann.GeneratedFrom spanAnn,) <$> fvs) tm
                  in Term.apps' f [n, lam]
               tm -> Term.apps' f [Term.nat (ann tm) 0, addDelay tm]
           "syntax.docTransclude" -> evalLike id
@@ -980,12 +984,13 @@ delayQuote :: (Monad m, Var v) => TermP v m
 delayQuote = P.label "quote" do
   start <- reserved "'"
   e <- termLeaf
-  pure $ DD.delayTerm (ann start <> ann e) e
+  pure $ DD.delayTerm (ann start <> ann e) (ann start) e
 
 delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
 delayBlock = P.label "do" do
   (spanAnn, b) <- block "do"
-  pure $ (spanAnn, DD.delayTerm (ann b) b)
+  let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
+  pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
 
 bang :: (Monad m, Var v) => TermP v m
 bang = P.label "bang" do
@@ -993,10 +998,10 @@ bang = P.label "bang" do
   e <- termLeaf
   pure $ DD.forceTerm (ann start <> ann e) (ann start) e
 
-force :: forall m v . (Monad m, Var v) => TermP v m
+force :: forall m v. (Monad m, Var v) => TermP v m
 force = P.label "force" $ P.try do
   -- `forkAt pool() blah` parses as `forkAt (pool ()) blah`
-  -- That is, empty parens immediately (no space) following a symbol 
+  -- That is, empty parens immediately (no space) following a symbol
   -- is treated as high precedence function application of `Unit`
   fn <- hashQualifiedPrefixTerm
   tok <- ann <$> openBlockWith "("
@@ -1008,10 +1013,10 @@ seqOp :: (Ord v) => P v m Pattern.SeqOp
 seqOp =
   Pattern.Snoc
     <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment)))
-    <|> Pattern.Cons
-      <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
-    <|> Pattern.Concat
-      <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
+      <|> Pattern.Cons
+    <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
+      <|> Pattern.Concat
+    <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
 
 term4 :: (Monad m, Var v) => TermP v m
 term4 = f <$> some termLeaf
@@ -1134,7 +1139,8 @@ binding = label "binding" do
     mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann
     mkBinding _lhsLoc [] body = body
     mkBinding lhsLoc args body =
-      (Term.lam' (lhsLoc <> ann body) (L.payload <$> args) body)
+      let annotatedArgs = args <&> \arg -> (ann arg, L.payload arg)
+       in Term.lam' (lhsLoc <> ann body) annotatedArgs body
 
 customFailure :: (P.MonadParsec e s m) => e -> m a
 customFailure = P.customFailure

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -490,7 +490,7 @@ pretty0
               (App' x (Constructor' (ConstructorReference DD.UnitRef 0)), _) | isLeaf x -> do
                 px <- pretty0 (ac (if isBlock x then 0 else 9) Normal im doc) x
                 pure . paren (p >= 11 || isBlock x && p >= 3) $
-                  px <> fmt S.DelayForceChar (l "()")
+                  px <> fmt S.Unit (l "()")
               (Apps' f (unsnoc -> Just (args, lastArg)), _)
                 | isSoftHangable lastArg -> do
                     fun <- goNormal 9 f
@@ -1958,7 +1958,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)])
   | nameEndsWith ppe suffix r,
     ABT.freeVars l == mempty,
     ok tm =
-      Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
+      Just (lamWithoutBindingAnns (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
   where
     ok (Apps' f _) = ABT.freeVars f == mempty
     ok tm = ABT.freeVars tm == mempty

parser-typechecker/src/Unison/Typechecker/Components.hs

@@ -78,7 +78,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
                       blockAnn
                       [(annotatedVar hdv, hdb)]
                       e
-                | otherwise = Term.singleLet isTop blockAnn (hdv, hdb) e
+                | otherwise = Term.singleLet isTop blockAnn (annotationFor hdv) (hdv, hdb) e
               mklet cycle@((_, _) : _) e =
                 Term.letRec
                   isTop
@@ -86,10 +86,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
                   (first annotatedVar <$> cycle)
                   e
               mklet [] e = e
-           in -- The outer annotation is going to be meaningful, so we make
-              -- sure to preserve it, whereas the annotations at intermediate Abs
-              -- nodes aren't necessarily meaningful
-              Right . Just . ABT.annotate blockAnn . foldr mklet e $ cs
+           in Right . Just . foldr mklet e $ cs
 minimize _ = Right Nothing
 
 minimize' ::

parser-typechecker/tests/Unison/Test/Term.hs

@@ -57,7 +57,7 @@ test =
               ref = R.Id h 0
               v1 = Var.unnamedRef @Symbol ref
               -- input component: `ref = \v1 -> ref`
-              component = Map.singleton ref (Term.lam () v1 (Term.refId () ref))
+              component = Map.singleton ref (Term.lam () ((), v1) (Term.refId () ref))
               component' = Term.unhashComponent component
               -- expected unhashed component: `v2 = \v1 -> v2`, where `v2 /= v1`,
               -- i.e. `v2` cannot be just `ref` converted to a ref-named variable,

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
@@ -131,7 +132,6 @@ library
       Unison.PrettyPrintEnvDecl.Names
       Unison.PrettyPrintEnvDecl.Sqlite
       Unison.PrintError
-      Unison.Project.Util
       Unison.Result
       Unison.Runtime.ANF
       Unison.Runtime.ANF.Rehash
@@ -332,7 +332,6 @@ library
     , unison-util-base32hex
     , unison-util-bytes
     , unison-util-cache
-    , unison-util-nametree
     , unison-util-relation
     , unison-util-rope
     , unison-util-serialization
@@ -533,7 +532,6 @@ test-suite parser-typechecker-tests
     , unison-util-base32hex
     , unison-util-bytes
     , unison-util-cache
-    , unison-util-nametree
     , unison-util-relation
     , unison-util-rope
     , unison-util-serialization

scheme-libs/racket/unison/arithmetic.rkt

@@ -1,70 +1,103 @@
 #!racket/base
 
 (provide
-  (prefix-out
-    builtin-
-    (combine-out
-      Nat.toFloat
-      Nat.increment
-      Nat.+
-      Nat.drop
-      Float.*
-      Float.fromRepresentation
-      Float.toRepresentation
-      Float.ceiling
-      Int.+
-      Int.-
-      Int./
-      Int.increment
-      Int.negate
-      Int.fromRepresentation
-      Int.toRepresentation
-      Int.signum
-      )))
+  builtin-Nat.+
+  builtin-Nat.+:termlink
+  builtin-Nat.toFloat
+  builtin-Nat.toFloat:termlink
+  builtin-Nat.increment
+  builtin-Nat.increment:termlink
+  builtin-Nat.drop
+  builtin-Nat.drop:termlink
+  builtin-Float.*
+  builtin-Float.*:termlink
+  builtin-Float.fromRepresentation
+  builtin-Float.fromRepresentation:termlink
+  builtin-Float.toRepresentation
+  builtin-Float.toRepresentation:termlink
+  builtin-Float.ceiling
+  builtin-Float.ceiling:termlink
+  builtin-Int.+
+  builtin-Int.+:termlink
+  builtin-Int.-
+  builtin-Int.-:termlink
+  builtin-Int./
+  builtin-Int./:termlink
+  builtin-Int.increment
+  builtin-Int.increment:termlink
+  builtin-Int.negate
+  builtin-Int.negate:termlink
+  builtin-Int.fromRepresentation
+  builtin-Int.fromRepresentation:termlink
+  builtin-Int.toRepresentation
+  builtin-Int.toRepresentation:termlink
+  builtin-Int.signum
+  builtin-Int.signum:termlink)
 
 (require racket
          racket/fixnum
          racket/flonum
          racket/performance-hint
+         unison/data
          unison/boot)
 
 (begin-encourage-inline
-  (define-unison (Nat.+ m n) (clamp-natural (+ m n)))
-  (define-unison (Nat.drop m n) (max 0 (- m n)))
+  (define-unison-builtin
+    (builtin-Nat.+ m n)
+    (clamp-natural (+ m n)))
 
-  (define-unison (Nat.increment n) (clamp-natural (add1 n)))
-  (define-unison (Int.increment i) (clamp-integer (add1 i)))
-  (define-unison (Int.negate i) (if (> i nbit63) (- i) i))
-  (define-unison (Int.+ i j) (clamp-integer (+ i j)))
-  (define-unison (Int.- i j) (clamp-integer (- i j)))
-  (define-unison (Int./ i j) (floor (/ i j)))
-  (define-unison (Int.signum i) (sgn i))
-  (define-unison (Float.* x y) (fl* x y))
+  (define-unison-builtin
+    (builtin-Nat.drop m n)
+    (max 0 (- m n)))
 
-  (define-unison (Nat.toFloat n) (->fl n))
+  (define-unison-builtin
+    (builtin-Nat.increment n)
+    (clamp-natural (add1 n)))
+  (define-unison-builtin
+    (builtin-Int.increment i) (clamp-integer (add1 i)))
+  (define-unison-builtin
+    (builtin-Int.negate i) (if (> i nbit63) (- i) i))
+  (define-unison-builtin
+    (builtin-Int.+ i j) (clamp-integer (+ i j)))
+  (define-unison-builtin
+    (builtin-Int.- i j) (clamp-integer (- i j)))
+  (define-unison-builtin
+    (builtin-Int./ i j) (floor (/ i j)))
+  (define-unison-builtin
+    (builtin-Int.signum i) (sgn i))
+  (define-unison-builtin
+    (builtin-Float.* x y) (fl* x y))
 
-  (define-unison (Float.ceiling f)
+  (define-unison-builtin
+    (builtin-Nat.toFloat n) (->fl n))
+
+  (define-unison-builtin
+    (builtin-Float.ceiling f)
     (clamp-integer (fl->exact-integer (ceiling f))))
 
   ; If someone can suggest a better mechanism for these,
   ; that would be appreciated.
-  (define-unison (Float.toRepresentation fl)
+  (define-unison-builtin
+    (builtin-Float.toRepresentation fl)
     (integer-bytes->integer
       (real->floating-point-bytes fl 8 #t) ; big endian
       #f ; unsigned
       #t)) ; big endian
 
-  (define-unison (Float.fromRepresentation n)
+  (define-unison-builtin
+    (builtin-Float.fromRepresentation n)
     (floating-point-bytes->real
       (integer->integer-bytes n 8 #f #t) ; unsigned, big endian
       #t)) ; big endian
 
-  (define-unison (Int.toRepresentation i)
+  (define-unison-builtin
+    (builtin-Int.toRepresentation i)
     (integer-bytes->integer
       (integer->integer-bytes i 8 #t #t) ; signed, big endian
       #f #t)) ; unsigned, big endian
 
-  (define-unison (Int.fromRepresentation n)
+  (define-unison-builtin
+    (builtin-Int.fromRepresentation n)
     (integer-bytes->integer
       (integer->integer-bytes n 8 #f #t) ; unsigned, big endian
       #t #t)) ; signed, big endian

scheme-libs/racket/unison/boot.ss

@@ -55,6 +55,7 @@
   bytes
   control
   define-unison
+  define-unison-builtin
   handle
   name
   data
@@ -116,14 +117,16 @@
 (require
   (for-syntax
     racket/set
-    (only-in racket partition flatten))
+    (only-in racket partition flatten split-at)
+    (only-in racket/string string-prefix?)
+    (only-in racket/syntax format-id))
   (rename-in
     (except-in racket false true unit any)
     [make-continuation-prompt-tag make-prompt])
   ; (for (only (compatibility mlist) mlist->list list->mlist) expand)
   ; (for (only (racket base) quasisyntax/loc) expand)
   ; (for-syntax (only-in unison/core syntax->list))
-  (only-in racket/control prompt0-at control0-at)
+  (only-in racket/control control0-at)
   racket/performance-hint
   unison/core
   unison/data
@@ -151,115 +154,301 @@
   (syntax-rules ()
     [(with-name name e) (let ([name e]) name)]))
 
-; function definition with slow/fast path. Slow path allows for
-; under/overapplication. Fast path is exact application.
+; Our definition macro needs to generate multiple entry points for the
+; defined procedures, so this is a function for making up names for
+; those based on the original.
+(define-for-syntax (adjust-symbol name post)
+  (string->symbol
+    (string-append
+      (symbol->string name)
+      ":"
+      post)))
+
+(define-for-syntax (adjust-name name post)
+  (datum->syntax name (adjust-symbol (syntax->datum name) post) name))
+
+; Helper function. Turns a list of syntax objects into a
+; list-syntax object.
+(define-for-syntax (list->syntax l) #`(#,@l))
+
+; These are auxiliary functions for manipulating a unison definition
+; into a form amenable for the right runtime behavior. This involves
+; multiple separate definitions:
 ;
-; The intent is for the scheme compiler to be able to recognize and
-; optimize static, fast path calls itself, while still supporting
-; unison-like automatic partial application and such.
-(define-syntax (define-unison x)
-  (define (fast-path-symbol name)
-    (string->symbol
-      (string-append
-        (symbol->string name)
-        ":fast-path")))
+; 1. an :impl definition is generated containing the actual code body
+; 2. a :fast definition, which takes exactly the number of arguments
+;    as the original, but checks if stack information needs to be
+;    stored for continuation serialization.
+; 3. a :slow path which implements under/over application to unison
+;    definitions, so they act like curried functions, not scheme
+;    procedures
+; 4. a macro that implements the actual occurrences, and directly
+;    calls the fast path for static calls with exactly the right
+;    number of arguments
+;
+; Additionally, arguments are threaded through the internal
+; definitions that indicate whether an ability handler is in place
+; that could potentially result in the continuation being serialized.
+; If so, then calls write additional information to the continuation
+; for that serialization. This isn't cheap for tight loops, so we
+; attempt to avoid this as much as possible (conditioning the
+; annotation on a flag checkseems to cause no performance loss).
 
-  (define (fast-path-name name)
-    (datum->syntax name (fast-path-symbol (syntax->datum name))))
 
-  ; Helper function. Turns a list of syntax objects into a
-  ; list-syntax object.
-  (define (list->syntax l) #`(#,@l))
-  ; Builds partial application cases for unison functions.
-  ; It seems most efficient to have a case for each posible
-  ; under-application.
-  (define (build-partials name formals)
-    (let rec ([us formals] [acc '()])
-      (syntax-case us ()
-        [() (list->syntax (cons #`[() #,name] acc))]
-        [(a ... z)
-         (rec #'(a ...)
-              (cons
-                #`[(a ... z)
-                   (with-name
-                     #,(datum->syntax name (syntax->datum name))
-                     (partial-app #,name a ... z))]
-                acc))])))
+; This builds the core definition for a unison definition. It is just
+; a lambda expression with the original code, but with an additional
+; keyword argument for threading purity information.
+(define-for-syntax (make-impl name:impl:stx arg:stx body:stx)
+  (with-syntax ([name:impl name:impl:stx]
+                [args arg:stx]
+                [body body:stx])
+    (syntax/loc body:stx
+      (define (name:impl #:pure pure? . args) . body))))
 
-  ; Given an overall function name, a fast path name, and a list of
-  ; arguments, builds the case-lambda body of a unison function that
-  ; enables applying to arbitrary numbers of arguments.
-  (define (func-cases name name:fast args)
-    (syntax-case args ()
-      [() (quasisyntax/loc x
-            (case-lambda
-              [() (#,name:fast)]
-              [r (apply (#,name:fast) r)]))]
-      [(a ... z)
-       (quasisyntax/loc x
-         (case-lambda
-           #,@(build-partials name #'(a ...))
-           [(a ... z) (#,name:fast a ... z)]
-           [(a ... z . r) (apply (#,name:fast a ... z) r)]))]))
+(define frame-contents (gensym))
 
-  (syntax-case x ()
-    [(define-unison (name a ...) e ...)
-     (let ([fname (fast-path-name #'name)])
-       (with-syntax ([name:fast fname]
-                     [fast (syntax/loc x (lambda (a ...) e ...))]
-                     [slow (func-cases #'name fname #'(a ...))])
-         (syntax/loc x
-           (define-values (name:fast name) (values fast slow)))))]))
+; Builds the wrapper definition, 'fast path,' which just tests the
+; purity, writes the stack information if necessary, and calls the
+; implementation. If #:force-pure is specified, the fast path just
+; directly calls the implementation procedure. This should allow
+; tight loops to still perform well if we can detect that they
+; (hereditarily) cannot make ability requests, even in contexts
+; where a handler is present.
+(define-for-syntax
+  (make-fast-path
+    #:force-pure force-pure?
+    loc ; original location
+    name:fast:stx name:impl:stx
+    arg:stx)
+
+  (with-syntax ([name:impl name:impl:stx]
+                [name:fast name:fast:stx]
+                [args arg:stx])
+    (if force-pure?
+      (syntax/loc loc
+        (define name:fast name:impl))
+
+      (syntax/loc loc
+        (define (name:fast #:pure pure? . args)
+          (if pure?
+            (name:impl #:pure pure? . args)
+            (with-continuation-mark
+              frame-contents
+              (vector . args)
+              (name:impl #:pure pure? . args))))))))
+
+; Slow path -- unnecessary
+; (define-for-syntax (make-slow-path loc name argstx)
+;   (with-syntax ([name:slow (adjust-symbol name "slow")]
+;                 [n (length (syntax->list argstx))])
+;     (syntax/loc loc
+;       (define (name:slow #:pure pure? . as)
+;         (define k (length as))
+;         (cond
+;           [(< k n) (unison-closure n name:slow as)]
+;           [(= k n) (apply name:fast #:pure pure? as)]
+;           [(> k n)
+;            (define-values (h t) (split-at as n))
+;            (apply
+;              (apply name:fast #:pure pure? h)
+;              #:pure pure?
+;              t)])))))
+
+; This definition builds a macro that defines the behavior of actual
+; occurences of the definition names. It has the following behavior:
+;
+; 1. Exactly saturated occurences directly call the fast path
+; 2. Undersaturated or unapplied occurrences become closure
+;    construction
+; 3. Oversaturated occurrences become an appropriate nested
+;    application
+;
+; Because of point 2, all function values end up represented as
+; unison-closure objects, so a slow path procedure is no longer
+; necessary; it is handled by the prop:procedure of the closure
+; structure. This should also make various universal operations easier
+; to handle, because we can just test for unison-closures, instead of
+; having to deal with raw procedures.
+(define-for-syntax
+  (make-callsite-macro
+    #:internal internal?
+    loc ; original location
+    name:stx name:fast:stx
+    arity:val)
+  (with-syntax ([name name:stx]
+                [name:fast name:fast:stx]
+                [arity arity:val])
+    (cond
+      [internal?
+        (syntax/loc loc
+          (define-syntax (name stx)
+            (syntax-case stx ()
+              [(_ #:by-name _ . bs)
+               (syntax/loc stx
+                 (unison-closure arity name:fast (list . bs)))]
+              [(_ . bs)
+               (let ([k (length (syntax->list #'bs))])
+                 (cond
+                   [(= arity k) ; saturated
+                    (syntax/loc stx
+                      (name:fast #:pure #t . bs))]
+                   [(> arity k) ; undersaturated
+                    (syntax/loc stx
+                      (unison-closure arity name:fast (list . bs)))]
+                   [(< arity k) ; oversaturated
+                    (define-values (h t)
+                      (split-at (syntax->list #'bs) arity))
+
+                    (quasisyntax/loc stx
+                      ((name:fast #:pure #t #,@h) #,@t))]))]
+              [_ (syntax/loc stx
+                   (unison-closure arity name:fast (list)))])))]
+      [else
+        (syntax/loc loc
+          (define-syntax (name stx)
+            (syntax-case stx ()
+              [(_ #:by-name _ . bs)
+               (syntax/loc stx
+                 (unison-closure arity name:fast (list . bs)))]
+              [(_ . bs)
+               (let ([k (length (syntax->list #'bs))])
+
+                 ; todo: purity
+
+                 ; capture local pure?
+                 (with-syntax ([pure? (format-id stx "pure?")])
+                   (cond
+                     [(= arity k) ; saturated
+                      (syntax/loc stx
+                        (name:fast #:pure pure? . bs))]
+                     [(> arity k)
+                      (syntax/loc stx
+                        (unison-closure n name:fast (list . bs)))]
+                     [(< arity k) ; oversaturated
+                      (define-values (h t)
+                        (split-at (syntax->list #'bs) arity))
+
+                      ; TODO: pending argument frame
+                      (quasisyntax/loc stx
+                        ((name:fast #:pure pure? #,@h)
+                         #:pure pure?
+                         #,@t))])))]
+              ; non-applied occurrence; partial ap immediately
+              [_ (syntax/loc stx
+                   (unison-closure arity name:fast (list)))])))])))
+
+(define-for-syntax
+  (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)
+  (if no-link-decl?
+    #'()
+    (let ([name:link:stx (adjust-name name:stx "termlink")])
+      (with-syntax
+        ([name:fast name:fast:stx]
+         [name:impl name:impl:stx]
+         [name:link name:link:stx])
+        (syntax/loc loc
+          ((declare-function-link name:fast name:link)
+           (declare-function-link name:impl name:link)))))))
+
+(define-for-syntax (process-hints hs)
+  (for/fold ([internal? #f]
+             [force-pure? #t]
+             [gen-link? #f]
+             [no-link-decl? #f])
+            ([h hs])
+    (values
+      (or internal? (eq? h 'internal))
+      (or force-pure? (eq? h 'force-pure) (eq? h 'internal))
+      (or gen-link? (eq? h 'gen-link))
+      (or no-link-decl? (eq? h 'no-link-decl)))))
+
+(define-for-syntax
+  (make-link-def gen-link? loc name:stx name:link:stx)
+
+  (define (chop s)
+    (if (string-prefix? s "builtin-")
+      (substring s 8)
+      s))
+
+  (define name:txt
+    (chop
+      (symbol->string
+        (syntax->datum name:stx))))
+
+  (cond
+    [gen-link?
+      (with-syntax ([name:link name:link:stx])
+        (quasisyntax/loc loc
+          ((define name:link
+             (unison-termlink-builtin #,name:txt)))))]
+    [else #'()]))
+
+(define-for-syntax
+  (expand-define-unison
+    #:hints hints
+    loc name:stx arg:stx expr:stx)
+
+  (define-values
+    (internal? force-pure? gen-link? no-link-decl?)
+    (process-hints hints))
+
+  (let ([name:fast:stx (adjust-name name:stx "fast")]
+        [name:impl:stx (adjust-name name:stx "impl")]
+        [name:link:stx (adjust-name name:stx "termlink")]
+        [arity (length (syntax->list arg:stx))])
+    (with-syntax
+      ([(link ...) (make-link-def gen-link? loc name:stx name:link:stx)]
+       [fast (make-fast-path
+               #:force-pure force-pure?
+               loc name:fast:stx name:impl:stx arg:stx)]
+       [impl (make-impl name:impl:stx arg:stx expr:stx)]
+       [call (make-callsite-macro
+               #:internal internal?
+               loc name:stx name:fast:stx arity)]
+       [(decls ...)
+        (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)])
+      (syntax/loc loc
+        (begin link ... impl fast call decls ...)))))
+
+; Function definition supporting various unison features, like
+; partial application and continuation serialization. See above for
+; details.
+;
+; `#:internal #t` indicates that the definition is for builtin
+; functions. These should always be built in a way that does not
+; annotate the stack, because they don't make relevant ability
+; requests. This is important for performance and some correct
+; behavior (i.e. they may occur in non-unison contexts where a
+; `pure?` indicator is not being threaded).
+(define-syntax (define-unison stx)
+  (syntax-case stx ()
+    [(define-unison #:hints hs (name . args) . exprs)
+     (expand-define-unison
+       #:hints (syntax->datum #'hs)
+       stx #'name #'args #'exprs)]
+    [(define-unison (name . args) . exprs)
+     (expand-define-unison
+       #:hints '[internal]
+       stx #'name #'args #'exprs)]))
+
+(define-syntax (define-unison-builtin stx)
+  (syntax-case stx ()
+    [(define-unison-builtin . rest)
+     (syntax/loc stx
+       (define-unison #:hints [internal gen-link] . rest))]))
 
 ; call-by-name bindings
-(define-syntax name
-  (lambda (stx)
-    (syntax-case stx ()
-      ((name ([v (f . args)] ...) body ...)
-       (with-syntax ([(lam ...)
-                      (map (lambda (body)
-                             (quasisyntax/loc stx
-                               (lambda r #,body)))
-                           (syntax->list #'[(apply f (append (list . args) r)) ...]))])
-         #`(let ([v lam] ...)
-             body ...))))))
+(define-syntax (name stx)
+  (syntax-case stx ()
+    [(name ([v (f . args)] ...) body ...)
+     (syntax/loc stx
+       (let ([v (f #:by-name #t . args)] ...) body ...))]))
 
 ; Wrapper that more closely matches `handle` constructs
-;
-; Note: this uses the prompt _twice_ to achieve the sort of dynamic
-; scoping we want. First we push an outer delimiter, then install
-; the continuation marks corresponding to the handled abilities
-; (which tells which propt to use for that ability and which
-; functions to use for each request). Then we re-delimit by the same
-; prompt.
-;
-; If we just used one delimiter, we'd have a problem. If we pushed
-; the marks _after_ the delimiter, then the continuation captured
-; when handling would contain those marks, and would effectively
-; retain the handler for requests within the continuation. If the
-; marks were outside the prompt, we'd be in a similar situation,
-; except where the handler would be automatically handling requests
-; within its own implementation (although, in both these cases we'd
-; get control errors, because we would be using the _function_ part
-; of the handler without the necessary delimiters existing on the
-; continuation). Both of these situations are wrong for _shallow_
-; handlers.
-;
-; Instead, what we need to be able to do is capture the continuation
-; _up to_ the marks, then _discard_ the marks, and this is what the
-; multiple delimiters accomplish. There might be more efficient ways
-; to accomplish this with some specialized mark functions, but I'm
-; uncertain of what pitfalls there are with regard to that (whehter
-; they work might depend on exact frame structure of the
-; metacontinuation).
 (define-syntax handle
   (syntax-rules ()
     [(handle [r ...] h e ...)
-     (let ([p (make-prompt)])
-       (prompt0-at p
-         (let ([v (let-marks (list r ...) (cons p h)
-                    (prompt0-at p e ...))])
-           (h (make-pure v)))))]))
+     (call-with-handler (list r ...) h (lambda () e ...))]))
 
 ; wrapper that more closely matches ability requests
 (define-syntax request

scheme-libs/racket/unison/concurrent.ss

@@ -66,17 +66,17 @@
              [cas! (lambda () (unsafe-struct*-cas! promise 2 value (some new-value)))]
              [awake-readers (lambda () (semaphore-post (promise-semaphore promise)))])
         (cond
-          [(some? value) false]
+          [(some? value) sum-false]
           [else
-           (let ([ok (parameterize-break #f (if (cas!) (awake-readers) false))])
-             (if ok true (loop)))]))))
+           (let ([ok (parameterize-break #f (if (cas!) (awake-readers) sum-false))])
+             (if ok sum-true (loop)))]))))
 
   (define (ref-cas ref ticket value)
-    (if (box-cas! ref ticket value) true false))
+    (if (box-cas! ref ticket value) sum-true sum-false))
 
   (define (sleep n)
     (sleep-secs (/ n 1000000))
-    (right unit))
+    (right sum-unit))
 
   ;; Swallows uncaught breaks/thread kills rather than logging them to
   ;; match the behaviour of the Haskell runtime
@@ -88,5 +88,5 @@
 
   (define (kill threadId)
     (break-thread threadId)
-    (right unit))
+    (right sum-unit))
   )

scheme-libs/racket/unison/core.ss

@@ -23,6 +23,7 @@
   (struct-out exn:bug)
 
   let-marks
+  call-with-marks
   ref-mark
 
   chunked-string-foldMap-chunks
@@ -192,7 +193,9 @@
      (string-append "{Value " (describe-value v) "}")]
     [(unison-code v)
      (string-append "{Code " (describe-value v) "}")]
-    [(unison-closure code env)
+    [(unison-cont-reflected fs) "{Continuation}"]
+    [(unison-cont-wrapped _) "{Continuation}"]
+    [(unison-closure _ code env)
      (define dc
        (termlink->string (lookup-function-link code) #t))
      (define (f v)
@@ -437,13 +440,6 @@
 ;     [() '()]
 ;     [(x . xs) (cons #'x (syntax->list #'xs))]))
 
-(define (call-with-marks rs v f)
-  (cond
-    [(null? rs) (f)]
-    [else
-      (with-continuation-mark (car rs) v
-        (call-with-marks (cdr rs) v f))]))
-
 (define-syntax let-marks
   (syntax-rules ()
     [(let-marks ks bn e ...)

scheme-libs/racket/unison/data.ss

@@ -12,6 +12,12 @@
   have-code?
 
   (struct-out unison-data)
+  (struct-out unison-continuation)
+  (struct-out unison-cont-wrapped)
+  (struct-out unison-cont-reflected)
+  (struct-out unison-frame)
+  (struct-out unison-frame-push)
+  (struct-out unison-frame-mark)
   (struct-out unison-sum)
   (struct-out unison-pure)
   (struct-out unison-request)
@@ -27,6 +33,9 @@
   (struct-out unison-quote)
   (struct-out unison-timespec)
 
+  call-with-handler
+  call-with-marks
+
   define-builtin-link
   declare-builtin-link
 
@@ -45,9 +54,9 @@
   left?
   either-get
   either-get
-  unit
-  false
-  true
+  sum-unit
+  sum-false
+  sum-true
   bool
   char
   ord
@@ -100,12 +109,15 @@
   builtin-tls.version:typelink
 
   unison-tuple->list
+  unison-pair->cons
 
   typelink->string
   termlink->string)
 
 (require
-  racket
+  (rename-in racket
+    [make-continuation-prompt-tag make-prompt])
+  (only-in racket/control prompt0-at control0-at)
   racket/fixnum
   (only-in "vector-trie.rkt" ->fx/wraparound)
   unison/bytevector)
@@ -290,13 +302,10 @@
   (write-string ")" port))
 
 (struct unison-closure
-  (code env)
+  (arity code env)
   #:transparent
   #:methods gen:custom-write
   [(define (write-proc clo port mode)
-     (define code-tl
-       (lookup-function-link (unison-closure-code clo)))
-
      (define rec
        (case mode
          [(#t) write]
@@ -308,12 +317,31 @@
      (write-string " " port)
      (write-sequence (unison-closure-env clo) port mode)
      (write-string ")" port))]
+
+  ; This has essentially becomes the slow path for unison function
+  ; application. The definition macro immediately creates a closure
+  ; for any statically under-saturated call or unapplied occurrence.
+  ; This means that there is never a bare unison function being passed
+  ; as a value. So, we can define the slow path here once and for all.
   #:property prop:procedure
-  (case-lambda
-    [(clo) clo]
-    [(clo . rest)
-     (apply (unison-closure-code clo)
-            (append (unison-closure-env clo) rest))]))
+  (lambda (clo #:pure [pure? #f] #:by-name [by-name? #f] . rest)
+    (define arity (unison-closure-arity clo))
+    (define old-env (unison-closure-env clo))
+    (define code (unison-closure-code clo))
+
+    (define new-env (append old-env rest))
+    (define k (length rest))
+    (define l (length new-env))
+    (cond
+      [(or by-name? (> arity l))
+       (struct-copy unison-closure clo [env new-env])]
+      [(= arity l) ; saturated
+       (apply code #:pure pure? new-env)]
+      [(= k 0) clo] ; special case, 0-applying undersaturated
+      [(< arity l)
+       ; TODO: pending arg annotation if no pure?
+       (define-values (now pending) (split-at new-env arity))
+       (apply (apply code #:pure pure? now) #:pure pure? pending)])))
 
 (struct unison-timespec (sec nsec)
   #:transparent
@@ -335,6 +363,115 @@
 
     (list equal-proc (hash-proc 3) (hash-proc 5))))
 
+; This is the base struct for continuation representations. It has
+; two possibilities seen below.
+(struct unison-continuation () #:transparent)
+
+; This is a wrapper that allows for a struct representation of all
+; continuations involved in unison. I.E. instead of just passing
+; around a raw racket continuation, we wrap it in a box for easier
+; identification.
+(struct unison-cont-wrapped unison-continuation (cont)
+  ; Use the wrapped continuation for procedure calls. Continuations
+  ; will always be called via the jumpCont wrapper which exactly
+  ; applies them to one argument.
+  #:property prop:procedure 0)
+
+; Basic mechanism for installing handlers, defined here so that it
+; can be used in the implementation of reflected continuations.
+;
+; Note: this uses the prompt _twice_ to achieve the sort of dynamic
+; scoping we want. First we push an outer delimiter, then install
+; the continuation marks corresponding to the handled abilities
+; (which tells which propt to use for that ability and which
+; functions to use for each request). Then we re-delimit by the same
+; prompt.
+;
+; If we just used one delimiter, we'd have a problem. If we pushed
+; the marks _after_ the delimiter, then the continuation captured
+; when handling would contain those marks, and would effectively
+; retain the handler for requests within the continuation. If the
+; marks were outside the prompt, we'd be in a similar situation,
+; except where the handler would be automatically handling requests
+; within its own implementation (although, in both these cases we'd
+; get control errors, because we would be using the _function_ part
+; of the handler without the necessary delimiters existing on the
+; continuation). Both of these situations are wrong for _shallow_
+; handlers.
+;
+; Instead, what we need to be able to do is capture the continuation
+; _up to_ the marks, then _discard_ the marks, and this is what the
+; multiple delimiters accomplish. There might be more efficient ways
+; to accomplish this with some specialized mark functions, but I'm
+; uncertain of what pitfalls there are with regard to that (whehter
+; they work might depend on exact frame structure of the
+; metacontinuation).
+(define (call-with-handler rs h f)
+  (let ([p (make-prompt)])
+    (prompt0-at p
+      (let ([v (call-with-marks rs (cons p h)
+                 (lambda () (prompt0-at p (f))))])
+        (h (make-pure v))))))
+
+(define (call-with-marks rs v f)
+  (cond
+    [(null? rs) (f)]
+    [else
+      (with-continuation-mark (car rs) v
+        (call-with-marks (cdr rs) v f))]))
+
+; Version of the above for re-installing a handlers in the serialized
+; format. In that case, there is an association list of links and
+; handlers, rather than a single handler (although the separate
+; handlers are likely duplicates).
+(define (call-with-assoc-marks p hs f)
+  (match hs
+    ['() (f)]
+    [(cons (cons r h) rest)
+     (with-continuation-mark r (cons p h)
+       (call-with-assoc-marks rest f))]))
+
+(define (call-with-handler-assocs hs f)
+  (let ([p (make-prompt)])
+    (prompt0-at p
+      (call-with-assoc-marks p hs
+        (lambda () (prompt0-at p (f)))))))
+
+(define (repush frames v)
+  (match frames
+    ['() v]
+    [(cons (unison-frame-mark as tls hs) frames)
+     ; handler frame; as are pending arguments, tls are typelinks
+     ; for handled abilities; hs are associations from links to
+     ; handler values.
+     ;
+     ; todo: args
+     (call-with-handler-assocs hs
+       (lambda () (repush frames v)))]
+    [(cons (unison-frame-push ls as rt) rest)
+     (displayln (list ls as rt))
+     (raise "repush push: not implemented yet")]))
+
+; This is a *reflected* representation of continuations amenable
+; to serialization. Most continuations won't be in this format,
+; because it's foolish to eagerly parse the racket continuation if
+; it's just going to be applied. But, a continuation that we've
+; gotten from serialization will be in this format.
+;
+; `frames` should be a list of the below `unison-frame` structs.
+(struct unison-cont-reflected unison-continuation (frames)
+  #:property prop:procedure
+  (lambda (cont v) (repush (unison-cont-reflected-frames cont) v)))
+
+; Stack frames for reflected continuations
+(struct unison-frame () #:transparent)
+
+(struct unison-frame-push unison-frame
+  (locals args return-to))
+
+(struct unison-frame-mark unison-frame
+  (args abilities handlers))
+
 (define-syntax (define-builtin-link stx)
   (syntax-case stx ()
     [(_ name)
@@ -344,9 +481,11 @@
             [dname (datum->syntax stx
                      (string->symbol
                        (string-append
-                         "builtin-" txt ":termlink")))])
-       #`(define #,dname
-           (unison-termlink-builtin #,(datum->syntax stx txt))))]))
+                         "builtin-" txt ":termlink"))
+                     #'name)])
+       (quasisyntax/loc stx
+         (define #,dname
+           (unison-termlink-builtin #,(datum->syntax stx txt)))))]))
 
 (define-syntax (declare-builtin-link stx)
   (syntax-case stx ()
@@ -357,7 +496,8 @@
             [dname (datum->syntax stx
                      (string->symbol
                        (string-append txt ":termlink")))])
-       #`(declare-function-link name #,dname))]))
+       (quasisyntax/loc stx
+         (declare-function-link name #,dname)))]))
 
 (define (partial-app f . args) (unison-closure f args))
 
@@ -382,11 +522,11 @@
 
 ; #<void> works as well
 ; Unit
-(define unit (sum 0))
+(define sum-unit (sum 0))
 
 ; Booleans are represented as numbers
-(define false 0)
-(define true 1)
+(define sum-false 0)
+(define sum-true 1)
 
 (define (bool b) (if b 1 0))
 
@@ -542,6 +682,13 @@
       [else
         (raise "unison-tuple->list: unexpected value")])))
 
+(define (unison-pair->cons t)
+  (match t
+    [(unison-data _ _ (list x (unison-data _ _ (list y _))))
+     (cons x y)]
+    [else
+     (raise "unison-pair->cons: unexpected value")]))
+
 (define (hash-string hs)
   (string-append
     "#"

scheme-libs/racket/unison/io-handles.rkt

@@ -3,7 +3,7 @@
          rnrs/io/ports-6
          (only-in rnrs standard-error-port standard-input-port standard-output-port vector-map)
          (only-in racket empty? with-output-to-string system/exit-code system false?)
-         (only-in unison/boot data-case define-unison)
+         (only-in unison/boot data-case define-unison-builtin)
          unison/data
          unison/chunked-seq
          unison/data
@@ -15,26 +15,39 @@
 (provide
  unison-FOp-IO.stdHandle
  unison-FOp-IO.openFile.impl.v3
- (prefix-out
-  builtin-IO.
-  (combine-out
-    seekHandle.impl.v3
-    getLine.impl.v1
-    getSomeBytes.impl.v1
-    getBuffering.impl.v3
-    setBuffering.impl.v3
-    getEcho.impl.v1
-    setEcho.impl.v1
-    getArgs.impl.v1
-    getEnv.impl.v1
-    getChar.impl.v1
-    isFileOpen.impl.v3
-    isSeekable.impl.v3
-    handlePosition.impl.v3
-    process.call
-    getCurrentDirectory.impl.v3
-    ready.impl.v1
-    ))
+
+ builtin-IO.seekHandle.impl.v3
+ builtin-IO.seekHandle.impl.v3:termlink
+ builtin-IO.getLine.impl.v1
+ builtin-IO.getLine.impl.v1:termlink
+ builtin-IO.getSomeBytes.impl.v1
+ builtin-IO.getSomeBytes.impl.v1:termlink
+ builtin-IO.getBuffering.impl.v3
+ builtin-IO.getBuffering.impl.v3:termlink
+ builtin-IO.setBuffering.impl.v3
+ builtin-IO.setBuffering.impl.v3:termlink
+ builtin-IO.getEcho.impl.v1
+ builtin-IO.getEcho.impl.v1:termlink
+ builtin-IO.setEcho.impl.v1
+ builtin-IO.setEcho.impl.v1:termlink
+ builtin-IO.getArgs.impl.v1
+ builtin-IO.getArgs.impl.v1:termlink
+ builtin-IO.getEnv.impl.v1
+ builtin-IO.getEnv.impl.v1:termlink
+ builtin-IO.getChar.impl.v1
+ builtin-IO.getChar.impl.v1:termlink
+ builtin-IO.isFileOpen.impl.v3
+ builtin-IO.isFileOpen.impl.v3:termlink
+ builtin-IO.isSeekable.impl.v3
+ builtin-IO.isSeekable.impl.v3:termlink
+ builtin-IO.handlePosition.impl.v3
+ builtin-IO.handlePosition.impl.v3:termlink
+ builtin-IO.process.call
+ builtin-IO.process.call:termlink
+ builtin-IO.getCurrentDirectory.impl.v3
+ builtin-IO.getCurrentDirectory.impl.v3:termlink
+ builtin-IO.ready.impl.v1
+ builtin-IO.ready.impl.v1:termlink
 
 ; Still to implement:
 ;    handlePosition.impl.v3
@@ -49,28 +62,34 @@
            [f (ref-failure-failure typeLink msg a)])
     (ref-either-left f)))
 
-(define-unison (isFileOpen.impl.v3 port)
+(define-unison-builtin
+  (builtin-IO.isFileOpen.impl.v3 port)
     (ref-either-right (not (port-closed? port))))
 
-(define-unison (ready.impl.v1 port)
+(define-unison-builtin
+  (builtin-IO.ready.impl.v1 port)
     (if (byte-ready? port)
         (ref-either-right #t)
         (if (port-eof? port)
             (Exception ref-iofailure:typelink "EOF" port)
             (ref-either-right #f))))
 
-(define-unison (getCurrentDirectory.impl.v3 unit)
+(define-unison-builtin
+  (builtin-IO.getCurrentDirectory.impl.v3 unit)
     (ref-either-right
       (string->chunked-string (path->string (current-directory)))))
 
-(define-unison (isSeekable.impl.v3 handle)
+(define-unison-builtin
+  (builtin-IO.isSeekable.impl.v3 handle)
     (ref-either-right
         (port-has-set-port-position!? handle)))
 
-(define-unison (handlePosition.impl.v3 handle)
+(define-unison-builtin
+  (builtin-IO.handlePosition.impl.v3 handle)
     (ref-either-right (port-position handle)))
 
-(define-unison (seekHandle.impl.v3 handle mode amount)
+(define-unison-builtin
+  (builtin-IO.seekHandle.impl.v3 handle mode amount)
     (data-case mode
         (0 ()
             (set-port-position! handle amount)
@@ -85,14 +104,16 @@
               "SeekFromEnd not supported"
               0))))
 
-(define-unison (getLine.impl.v1 handle)
+(define-unison-builtin
+  (builtin-IO.getLine.impl.v1 handle)
   (let* ([line (read-line handle)])
     (if (eof-object? line)
         (ref-either-right (string->chunked-string ""))
         (ref-either-right (string->chunked-string line))
         )))
 
-(define-unison (getChar.impl.v1 handle)
+(define-unison-builtin
+  (builtin-IO.getChar.impl.v1 handle)
   (let* ([char (read-char handle)])
     (if (eof-object? char)
         (Exception
@@ -101,7 +122,8 @@
           ref-unit-unit)
         (ref-either-right char))))
 
-(define-unison (getSomeBytes.impl.v1 handle nbytes)
+(define-unison-builtin
+  (builtin-IO.getSomeBytes.impl.v1 handle nbytes)
   (let* ([buffer (make-bytes nbytes)]
          [line (read-bytes-avail! buffer handle)])
     (cond
@@ -119,7 +141,8 @@
              (subbytes buffer 0 line)
              buffer)))])))
 
-(define-unison (getBuffering.impl.v3 handle)
+(define-unison-builtin
+  (builtin-IO.getBuffering.impl.v3 handle)
     (case (file-stream-buffer-mode handle)
         [(none) (ref-either-right ref-buffermode-no-buffering)]
         [(line) (ref-either-right
@@ -135,7 +158,8 @@
                 "Unexpected response from file-stream-buffer-mode"
                 ref-unit-unit)]))
 
-(define-unison (setBuffering.impl.v3 handle mode)
+(define-unison-builtin
+  (builtin-IO.setBuffering.impl.v3 handle mode)
     (data-case mode
         (0 ()
             (file-stream-buffer-mode handle 'none)
@@ -166,7 +190,8 @@
     [(1) stdout]
     [(2) stderr]))
 
-(define-unison (getEcho.impl.v1 handle)
+(define-unison-builtin
+  (builtin-IO.getEcho.impl.v1 handle)
   (if (eq? handle stdin)
       (ref-either-right (get-stdin-echo))
       (Exception
@@ -174,7 +199,8 @@
         "getEcho only supported on stdin"
         ref-unit-unit)))
 
-(define-unison (setEcho.impl.v1 handle echo)
+(define-unison-builtin
+  (builtin-IO.setEcho.impl.v1 handle echo)
   (if (eq? handle stdin)
       (begin
         (if echo
@@ -190,12 +216,14 @@
   (let ([current (with-output-to-string (lambda () (system "stty -a")))])
     (string-contains? current " echo ")))
 
-(define-unison (getArgs.impl.v1 unit)
+(define-unison-builtin
+  (builtin-IO.getArgs.impl.v1 unit)
     (ref-either-right
       (vector->chunked-list
         (vector-map string->chunked-string (current-command-line-arguments)))))
 
-(define-unison (getEnv.impl.v1 key)
+(define-unison-builtin
+  (builtin-IO.getEnv.impl.v1 key)
     (let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))])
         (if (false? value)
             (Exception
@@ -224,7 +252,8 @@
           s)
       "''"))
 
-(define-unison (process.call command arguments)
+(define-unison-builtin
+  (builtin-IO.process.call command arguments)
   (system/exit-code
           (string-join (cons
                         (chunked-string->string command)

scheme-libs/racket/unison/io.rkt

@@ -9,7 +9,7 @@
            date-dst?
            date-time-zone-offset
            date*-time-zone-name)
-         (only-in unison/boot data-case define-unison)
+         (only-in unison/boot data-case define-unison-builtin)
          (only-in
            rnrs/arithmetic/flonums-6
            flmod))
@@ -33,20 +33,29 @@
    getTempDirectory.impl.v3
    removeFile.impl.v3
    getFileSize.impl.v3))
-  (prefix-out
-    builtin-IO.
-    (combine-out
-        fileExists.impl.v3
-        renameFile.impl.v3
-        createDirectory.impl.v3
-        removeDirectory.impl.v3
-        directoryContents.impl.v3
-        setCurrentDirectory.impl.v3
-        renameDirectory.impl.v3
-        isDirectory.impl.v3
-        systemTime.impl.v3
-        systemTimeMicroseconds.impl.v3
-        createTempDirectory.impl.v3)))
+
+  builtin-IO.fileExists.impl.v3
+  builtin-IO.fileExists.impl.v3:termlink
+  builtin-IO.renameFile.impl.v3
+  builtin-IO.renameFile.impl.v3:termlink
+  builtin-IO.createDirectory.impl.v3
+  builtin-IO.createDirectory.impl.v3:termlink
+  builtin-IO.removeDirectory.impl.v3
+  builtin-IO.removeDirectory.impl.v3:termlink
+  builtin-IO.directoryContents.impl.v3
+  builtin-IO.directoryContents.impl.v3:termlink
+  builtin-IO.setCurrentDirectory.impl.v3
+  builtin-IO.setCurrentDirectory.impl.v3:termlink
+  builtin-IO.renameDirectory.impl.v3
+  builtin-IO.renameDirectory.impl.v3:termlink
+  builtin-IO.isDirectory.impl.v3
+  builtin-IO.isDirectory.impl.v3:termlink
+  builtin-IO.systemTime.impl.v3
+  builtin-IO.systemTime.impl.v3:termlink
+  builtin-IO.systemTimeMicroseconds.impl.v3
+  builtin-IO.systemTimeMicroseconds.impl.v3:termlink
+  builtin-IO.createTempDirectory.impl.v3
+  builtin-IO.createTempDirectory.impl.v3:termlink)
 
 (define (failure-result ty msg vl)
   (ref-either-left
@@ -76,7 +85,8 @@
         (right (file-or-directory-modify-seconds (chunked-string->string path)))))
 
 ; in haskell, it's not just file but also directory
-(define-unison (fileExists.impl.v3 path)
+(define-unison-builtin
+  (builtin-IO.fileExists.impl.v3 path)
     (let ([path-string (chunked-string->string path)])
     (ref-either-right
         (or
@@ -90,11 +100,13 @@
 (define (getTempDirectory.impl.v3)
     (right (string->chunked-string (path->string (find-system-path 'temp-dir)))))
 
-(define-unison (setCurrentDirectory.impl.v3 path)
+(define-unison-builtin
+  (builtin-IO.setCurrentDirectory.impl.v3 path)
     (current-directory (chunked-string->string path))
     (ref-either-right none))
 
-(define-unison (directoryContents.impl.v3 path)
+(define-unison-builtin
+  (builtin-IO.directoryContents.impl.v3 path)
   (with-handlers
     [[exn:fail:filesystem?
        (lambda (e)
@@ -112,7 +124,8 @@
               (list* "." ".." dirss))))))))
 
 
-(define-unison (createTempDirectory.impl.v3 prefix)
+(define-unison-builtin
+  (builtin-IO.createTempDirectory.impl.v3 prefix)
     (ref-either-right
         (string->chunked-string
             (path->string
@@ -120,35 +133,43 @@
                     (string->bytes/utf-8
                         (chunked-string->string prefix)) #"")))))
 
-(define-unison (createDirectory.impl.v3 file)
+(define-unison-builtin
+  (builtin-IO.createDirectory.impl.v3 file)
     (make-directory (chunked-string->string file))
     (ref-either-right none))
 
-(define-unison (removeDirectory.impl.v3 file)
+(define-unison-builtin
+  (builtin-IO.removeDirectory.impl.v3 file)
     (delete-directory/files (chunked-string->string file))
     (ref-either-right none))
 
-(define-unison (isDirectory.impl.v3 path)
+(define-unison-builtin
+  (builtin-IO.isDirectory.impl.v3 path)
     (ref-either-right
         (directory-exists? (chunked-string->string path))))
 
-(define-unison (renameDirectory.impl.v3 old new)
+(define-unison-builtin
+  (builtin-IO.renameDirectory.impl.v3 old new)
     (rename-file-or-directory (chunked-string->string old)
         (chunked-string->string new))
     (ref-either-right none))
 
-(define-unison (renameFile.impl.v3 old new)
+(define-unison-builtin
+  (builtin-IO.renameFile.impl.v3 old new)
     (rename-file-or-directory (chunked-string->string old)
         (chunked-string->string new))
     (ref-either-right none))
 
-(define-unison (systemTime.impl.v3 unit)
+(define-unison-builtin
+  (builtin-IO.systemTime.impl.v3 unit)
     (ref-either-right (current-seconds)))
 
-(define-unison (systemTimeMicroseconds.impl.v3 unit)
+(define-unison-builtin
+  (builtin-IO.systemTimeMicroseconds.impl.v3 unit)
     (ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
 
-(define-unison (builtin-Clock.internals.systemTimeZone.v1 secs)
+(define-unison-builtin
+  (builtin-Clock.internals.systemTimeZone.v1 secs)
   (let* ([d (seconds->date secs)])
     (list->unison-tuple
       (list

scheme-libs/racket/unison/math.rkt

@@ -7,24 +7,39 @@
                   clamp-integer
                   clamp-natural
                   data-case
-                  define-unison
+                  define-unison-builtin
                   nbit63))
 
 (provide
-    builtin-Float.exp
-    builtin-Float.log
-    builtin-Float.max
-    builtin-Float.min
-    builtin-Float.tan
-    builtin-Float.tanh
-    builtin-Float.logBase
-    builtin-Int.*
-    builtin-Int.pow
-    builtin-Int.trailingZeros
-    builtin-Nat.trailingZeros
-    builtin-Int.popCount
-    builtin-Nat.popCount
-    builtin-Float.pow
+  builtin-Float.exp
+  builtin-Float.exp:termlink
+  builtin-Float.log
+  builtin-Float.log:termlink
+  builtin-Float.max
+  builtin-Float.max:termlink
+  builtin-Float.min
+  builtin-Float.min:termlink
+  builtin-Float.tan
+  builtin-Float.tan:termlink
+  builtin-Float.tanh
+  builtin-Float.tanh:termlink
+  builtin-Float.logBase
+  builtin-Float.logBase:termlink
+  builtin-Int.*
+  builtin-Int.*:termlink
+  builtin-Int.pow
+  builtin-Int.pow:termlink
+  builtin-Int.trailingZeros
+  builtin-Int.trailingZeros:termlink
+  builtin-Nat.trailingZeros
+  builtin-Nat.trailingZeros:termlink
+  builtin-Int.popCount
+  builtin-Int.popCount:termlink
+  builtin-Nat.popCount
+  builtin-Nat.popCount:termlink
+  builtin-Float.pow
+  builtin-Float.pow:termlink
+
  (prefix-out unison-POp-
              (combine-out
               ABSF
@@ -71,21 +86,50 @@
               SINF
               ITOF)))
 
-(define-unison (builtin-Float.logBase base num) (log num base))
+(define-unison-builtin
+  (builtin-Float.logBase base num)
+  (log num base))
 (define (LOGB base num) (log num base))
-(define-unison (builtin-Float.exp n) (exp n))
-(define-unison (builtin-Float.log n) (log n))
-(define-unison (builtin-Float.max n m) (max n m))
-(define-unison (builtin-Float.min n m) (min n m))
-(define-unison (builtin-Float.tan n) (tan n))
-(define-unison (builtin-Float.tanh n) (tanh n))
-(define-unison (builtin-Int.* n m) (clamp-integer (* n m)))
-(define-unison (builtin-Int.pow n m) (clamp-integer (expt n m)))
-(define-unison (builtin-Int.trailingZeros n) (TZRO n))
-(define-unison (builtin-Nat.trailingZeros n) (TZRO n))
-(define-unison (builtin-Nat.popCount n) (POPC n))
-(define-unison (builtin-Int.popCount n) (POPC n))
-(define-unison (builtin-Float.pow n m) (expt n m))
+
+(define-unison-builtin
+  (builtin-Float.exp n) (exp n))
+
+(define-unison-builtin
+  (builtin-Float.log n) (log n))
+
+(define-unison-builtin
+  (builtin-Float.max n m) (max n m))
+
+(define-unison-builtin
+  (builtin-Float.min n m) (min n m))
+
+(define-unison-builtin
+  (builtin-Float.tan n) (tan n))
+
+(define-unison-builtin
+  (builtin-Float.tanh n) (tanh n))
+
+(define-unison-builtin
+  (builtin-Int.* n m) (clamp-integer (* n m)))
+
+(define-unison-builtin
+  (builtin-Int.pow n m) (clamp-integer (expt n m)))
+
+(define-unison-builtin
+  (builtin-Int.trailingZeros n) (TZRO n))
+
+(define-unison-builtin
+  (builtin-Nat.trailingZeros n) (TZRO n))
+
+(define-unison-builtin
+  (builtin-Nat.popCount n) (POPC n))
+
+(define-unison-builtin
+  (builtin-Int.popCount n) (POPC n))
+
+(define-unison-builtin
+  (builtin-Float.pow n m) (expt n m))
+
 (define (EXPF n) (exp n))
 (define ABSF abs)
 (define ACOS acos)

scheme-libs/racket/unison/primops-generated.rkt

@@ -31,9 +31,11 @@
   builtin-sandboxLinks
   builtin-sandboxLinks:termlink
 
+  builtin-Code.dependencies:termlink
   builtin-Code.deserialize:termlink
   builtin-Code.serialize:termlink
   builtin-Code.validateLinks:termlink
+  builtin-Value.dependencies:termlink
   builtin-Value.deserialize:termlink
   builtin-Value.serialize:termlink
   builtin-crypto.hash:termlink
@@ -54,21 +56,15 @@
   build-runtime-module
   termlink->proc)
 
-(define-builtin-link Value.value)
-(define-builtin-link Value.reflect)
-(define-builtin-link Code.isMissing)
-(define-builtin-link Code.lookup)
-
+(define-builtin-link Code.dependencies)
 (define-builtin-link Code.deserialize)
 (define-builtin-link Code.serialize)
 (define-builtin-link Code.validateLinks)
+(define-builtin-link Value.dependencies)
 (define-builtin-link Value.deserialize)
 (define-builtin-link Value.serialize)
 (define-builtin-link crypto.hash)
 (define-builtin-link crypto.hmac)
-(define-builtin-link validateSandboxed)
-(define-builtin-link Value.validateSandboxed)
-(define-builtin-link sandboxLinks)
 
 (define (chunked-list->list cl)
   (vector->list (chunked-list->vector cl)))
@@ -129,14 +125,33 @@
       (raise
         (format "decode-binding: unimplemented case: ~a" bn))]))
 
+(define (decode-hints hs)
+  (define (hint->sym t)
+    (cond
+      [(= t ref-defnhint-internal:tag) 'internal]
+      [(= t ref-defnhint-genlink:tag) 'gen-link]
+      [(= t ref-defnhint-nolinkdecl:tag) 'no-link-decl]))
+
+  (for/fold ([def 'define-unison] [out '()]) ([h hs])
+    (match h
+      [(unison-data _ t (list))
+       #:when (= t ref-defnhint-builtin:tag)
+       (values 'define-unison-builtin out)]
+      [(unison-data _ t (list))
+       (values def (cons (hint->sym t) out))])))
+
 (define (decode-syntax dfn)
   (match dfn
-    [(unison-data _ t (list nm vs bd))
+    [(unison-data _ t (list nm hs vs bd))
      #:when (= t ref-schemedefn-define:tag)
-     (let ([head (map text->ident
-                      (cons nm (chunked-list->list vs)))]
-           [body (decode-term bd)])
-       (list 'define-unison head body))]
+     (let-values
+       ([(head) (map text->ident
+                  (cons nm (chunked-list->list vs)))]
+        [(def hints) (decode-hints (chunked-list->list hs))]
+        [(body) (decode-term bd)])
+       (if (null? hints)
+         (list def head body)
+         (list def '#:hints hints head body)))]
     [(unison-data _ t (list nm bd))
      #:when (= t ref-schemedefn-alias:tag)
      (list 'define (text->ident nm) (decode-term bd))]
@@ -195,20 +210,17 @@
                   (describe-value tl)))]
     [1 (rf) rf]))
 
-(define-syntax make-group-ref-decoder
-  (lambda (stx)
-    (syntax-case stx ()
-      [(_)
-       #`(lambda (gr)
-           (data-case (group-ref-ident gr)
-             [#,ref-schemeterm-ident:tag (name) name]
-             [else
-               (raise
-                 (format
-                   "decode-group-ref: unimplemented data case: ~a"
-                   (describe-value gr)))]))])))
+(define (decode-group-ref gr0)
+  (match (group-ref-ident gr0)
+    [(unison-data _ t (list name))
+     #:when (= t ref-schemeterm-ident:tag)
+     name]
+    [else
+     (raise
+       (format
+         "decode-group-ref: unimplemented data case: ~a"
+         (describe-value gr0)))]))
 
-(define decode-group-ref (make-group-ref-decoder))
 (define (group-ref-sym gr)
   (string->symbol
     (chunked-string->string
@@ -301,6 +313,70 @@
        [else
          (raise (format "decode-vlit: unimplemented case: !a" vl))])]))
 
+(define (reify-handlers hs)
+  (for/list ([h (chunked-list->list hs)])
+    (match (unison-pair->cons h)
+      [(cons r h)
+       (cons (reference->typelink r)
+             (reify-value h))])))
+
+(define (reflect-handlers hs)
+  (list->chunked-list
+    (for/list ([h hs])
+      (match h
+        [(cons r h)
+         (unison-tuple
+           (typelink->reference r)
+           (reflect-value h))]))))
+
+(define (reify-groupref gr0)
+  (match gr0
+    [(unison-data _ t (list r i))
+     #:when (= t ref-groupref-group:tag)
+     (cons (reference->typelink r) i)]))
+
+(define (reflect-groupref rt)
+  (match rt
+    [(cons l i)
+     (ref-groupref-group (typelink->reference l) i)]))
+
+(define (parse-continuation orig k0 vs0)
+  (let rec ([k k0] [vs vs0] [frames '()])
+    (match k
+      [(unison-data _ t (list))
+       #:when (= t ref-cont-empty:tag)
+       (unison-cont-reflected (reverse frames))]
+      [(unison-data _ t (list l a gr0 k))
+       #:when (= t ref-cont-push:tag)
+       (cond
+         [(>= (length vs) (+ l a))
+          (let*-values
+            ([(locals int) (split-at vs l)]
+             [(args rest) (split-at int a)]
+             [(gr) (reify-groupref gr0)]
+             [(fm) (unison-frame-push locals args gr)])
+            (rec k rest (cons fm frames)))]
+         [else
+          (raise
+            (make-exn:bug
+              "reify-value: malformed continuation"
+              orig))])]
+      [(unison-data _ t (list a rs0 de0 k))
+       #:when (= t ref-cont-mark:tag)
+       (cond
+         [(>= (length vs) a)
+          (let*-values
+            ([(args rest) (split-at vs a)]
+             [(rs) (map reference->termlink (chunked-list->list rs0))]
+             [(hs) (reify-handlers de0)]
+             [(fm) (unison-frame-mark args rs hs)])
+            (rec k rest (cons fm frames)))]
+         [else
+          (raise
+            (make-exn:bug
+              "reify-value: malformed continuation"
+              orig))])])))
+
 (define (reify-value v)
   (match v
     [(unison-data _ t (list rf rt bs0))
@@ -327,16 +403,14 @@
      #:when (= t ref-value-partial:tag)
      (let ([bs (map reify-value (chunked-list->list bs0))]
            [proc (resolve-proc gr)])
-       (apply proc bs))]
+       (struct-copy unison-closure proc [env bs]))]
     [(unison-data _ t (list vl))
      #:when (= t ref-value-vlit:tag)
      (reify-vlit vl)]
-    [(unison-data _ t (list bs0 k))
+    [(unison-data _ t (list vs0 k))
      #:when (= t ref-value-cont:tag)
-     (raise
-       (make-exn:bug
-         "reify-value: unimplemented cont case"
-         ref-unit-unit))]
+     (parse-continuation v k
+       (map reify-value (chunked-list->list vs0)))]
     [(unison-data r t fs)
      (raise
        (make-exn:bug
@@ -413,14 +487,34 @@
      (ref-value-vlit (ref-vlit-typelink (reflect-typelink v)))]
     [(unison-code sg) (ref-value-vlit (ref-vlit-code sg))]
     [(unison-quote q) (ref-value-vlit (ref-vlit-quote q))]
-    [(unison-closure f as)
+    [(unison-cont-reflected frames0)
+     (for/foldr ([k ref-cont-empty]
+                 [vs '()]
+                 #:result
+                 (ref-value-cont
+                   (list->chunked-list (map reflect-value vs))
+                   k))
+                ([frame frames0])
+       (match frame
+         [(unison-frame-push locals args return-to)
+          (values
+            (ref-cont-push
+              (length locals)
+              (length args)
+              (reflect-groupref return-to)
+              k)
+            (append locals args vs))]
+         [(unison-frame-mark args refs hs)
+          (values
+            (ref-cont-mark
+              (length args)
+              (map typelink->reference refs)
+              (reflect-handlers hs))
+            (append args vs))]))]
+    [(unison-closure arity f as)
      (ref-value-partial
        (function->groupref f)
        (list->chunked-list (map reflect-value as)))]
-    [(? procedure?)
-     (ref-value-partial
-       (function->groupref v)
-       empty-chunked-list)]
     [(unison-data rf t fs)
      (ref-value-data
        (reflect-typelink rf)
@@ -438,7 +532,7 @@
     [(? chunked-list?)
      (for/fold ([acc '()]) ([e (in-chunked-list v)])
        (append (sandbox-value ok e) acc))]
-    [(unison-closure f as)
+    [(unison-closure arity f as)
      (for/fold ([acc (sandbox-proc ok f)]) ([a (in-list as)])
        (append (sandbox-scheme-value ok a) acc))]
     [(? procedure?) (sandbox-proc ok v)]
@@ -474,11 +568,11 @@
     [(unison-quote v) (sandbox-value ok v)]))
 
 ; replacment for Value.unsafeValue : a -> Value
-(define-unison
+(define-unison-builtin
   (builtin-Value.reflect v)
   (reflect-value v))
 
-(define-unison
+(define-unison-builtin
   (builtin-Value.value v)
   (let ([rv (reflect-value v)])
     (unison-quote rv)))
@@ -706,23 +800,23 @@
 
 (define (unison-POp-LKUP tl) (lookup-code tl))
 
-(define-unison (builtin-Code.lookup tl)
+(define-unison-builtin (builtin-Code.lookup tl)
   (match (lookup-code tl)
     [(unison-sum 0 (list)) ref-optional-none]
     [(unison-sum 1 (list co)) (ref-optional-some co)]))
 
-(define-unison (builtin-validateSandboxed ok v)
+(define-unison-builtin (builtin-validateSandboxed ok v)
   (let ([l (sandbox-scheme-value (chunked-list->list ok) v)])
     (null? l)))
 
-(define-unison (builtin-sandboxLinks tl) (check-sandbox tl))
+(define-unison-builtin (builtin-sandboxLinks tl) (check-sandbox tl))
 
-(define-unison (builtin-Code.isMissing tl)
+(define-unison-builtin (builtin-Code.isMissing tl)
   (cond
     [(unison-termlink-builtin? tl) #f]
     [(unison-termlink-con? tl) #f]
     [(have-code? tl) #t]
     [else #f]))
 
-(define-unison (builtin-Value.validateSandboxed ok v)
+(define-unison-builtin (builtin-Value.validateSandboxed ok v)
   (sandbox-quoted (chunked-list->list ok) v))

scheme-libs/racket/unison/sandbox.rkt

@@ -4,7 +4,7 @@
 (provide expand-sandbox check-sandbox set-sandbox)
 
 (require racket racket/hash)
-(require (except-in unison/data true false unit))
+(require unison/data)
 
 ; sandboxing information
 (define sandbox-links (make-hash))

scheme-libs/racket/unison/udp.rkt

@@ -2,7 +2,7 @@
 #lang racket/base
 (require racket/udp
          racket/format
-         (only-in unison/boot define-unison)
+         (only-in unison/boot define-unison-builtin)
          unison/data
          unison/data-info
          unison/chunked-seq
@@ -11,32 +11,29 @@
          unison/core)
 
 (provide
-  (prefix-out
-    builtin-IO.UDP.
-    (combine-out
-      clientSocket.impl.v1
-      clientSocket.impl.v1:termlink
-      UDPSocket.recv.impl.v1
-      UDPSocket.recv.impl.v1:termlink
-      UDPSocket.send.impl.v1
-      UDPSocket.send.impl.v1:termlink
-      UDPSocket.close.impl.v1
-      UDPSocket.close.impl.v1:termlink
-      ListenSocket.close.impl.v1
-      ListenSocket.close.impl.v1:termlink
-      UDPSocket.toText.impl.v1
-      UDPSocket.toText.impl.v1:termlink
-      serverSocket.impl.v1
-      serverSocket.impl.v1:termlink
-      ListenSocket.toText.impl.v1
-      ListenSocket.toText.impl.v1:termlink
-      ListenSocket.recvFrom.impl.v1
-      ListenSocket.recvFrom.impl.v1:termlink
-      ClientSockAddr.toText.v1
-      ClientSockAddr.toText.v1:termlink
-      ListenSocket.sendTo.impl.v1
-      ListenSocket.sendTo.impl.v1:termlink)))
- 
+  builtin-IO.UDP.clientSocket.impl.v1
+  builtin-IO.UDP.clientSocket.impl.v1:termlink
+  builtin-IO.UDP.UDPSocket.recv.impl.v1
+  builtin-IO.UDP.UDPSocket.recv.impl.v1:termlink
+  builtin-IO.UDP.UDPSocket.send.impl.v1
+  builtin-IO.UDP.UDPSocket.send.impl.v1:termlink
+  builtin-IO.UDP.UDPSocket.close.impl.v1
+  builtin-IO.UDP.UDPSocket.close.impl.v1:termlink
+  builtin-IO.UDP.ListenSocket.close.impl.v1
+  builtin-IO.UDP.ListenSocket.close.impl.v1:termlink
+  builtin-IO.UDP.UDPSocket.toText.impl.v1
+  builtin-IO.UDP.UDPSocket.toText.impl.v1:termlink
+  builtin-IO.UDP.serverSocket.impl.v1
+  builtin-IO.UDP.serverSocket.impl.v1:termlink
+  builtin-IO.UDP.ListenSocket.toText.impl.v1
+  builtin-IO.UDP.ListenSocket.toText.impl.v1:termlink
+  builtin-IO.UDP.ListenSocket.recvFrom.impl.v1
+  builtin-IO.UDP.ListenSocket.recvFrom.impl.v1:termlink
+  builtin-IO.UDP.ClientSockAddr.toText.v1
+  builtin-IO.UDP.ClientSockAddr.toText.v1:termlink
+  builtin-IO.UDP.ListenSocket.sendTo.impl.v1
+  builtin-IO.UDP.ListenSocket.sendTo.impl.v1:termlink)
+
 
 (struct client-sock-addr (host port))
 
@@ -48,10 +45,10 @@
   (sum-case a
     (0 (type msg meta)
       (ref-either-left (ref-failure-failure type msg (unison-any-any meta))))
-    (1 (data) 
+    (1 (data)
       (ref-either-right data))))
 
-(define 
+(define
   (format-socket socket)
   (let*-values ([(local-hn local-port remote-hn remote-port) (udp-addresses socket #t)]
                 [(rv) (~a "<socket local=" local-hn ":" local-port " remote=" remote-hn ":" remote-port ">")])
@@ -64,7 +61,7 @@
     (wrap-in-either rv)))
 
 ;; define termlink builtins
-(define clientSocket.impl.v1:termlink 
+(define clientSocket.impl.v1:termlink
   (unison-termlink-builtin "IO.UDP.clientSocket.impl.v1"))
 (define UDPSocket.recv.impl.v1:termlink
   (unison-termlink-builtin "IO.UDP.UDPSocket.recv.impl.v1"))
@@ -72,7 +69,7 @@
   (unison-termlink-builtin "IO.UDP.UDPSocket.send.impl.v1"))
 (define UDPSocket.close.impl.v1:termlink
   (unison-termlink-builtin "IO.UDP.UDPSocket.close.impl.v1"))
-(define ListenSocket.close.impl.v1:termlink 
+(define ListenSocket.close.impl.v1:termlink
   (unison-termlink-builtin "IO.UDP.ListenSocket.close.impl.v1"))
 (define UDPSocket.toText.impl.v1:termlink
   (unison-termlink-builtin "IO.UDP.UDPSocket.toText.impl.v1"))
@@ -89,22 +86,25 @@
 
 ;; define builtins
 
-(define-unison
-  (UDPSocket.recv.impl.v1 socket) ; socket -> Either Failure Bytes
-  (let 
-    ([rv (handle-errors (lambda() 
+(define-unison-builtin
+  (builtin-IO.UDP.UDPSocket.recv.impl.v1 socket)
+  ; socket -> Either Failure Bytes
+  (let
+    ([rv (handle-errors (lambda()
       (let*-values
         ([(buffer) (make-bytes buffer-size)]
          [(len a b) (udp-receive! socket buffer)])
         (right (bytes->chunked-bytes (subbytes buffer 0 len))))))])
     (wrap-in-either rv)))
 
-(define-unison
-  (ListenSocket.close.impl.v1 socket) ; socket -> Either Failure ()
+(define-unison-builtin
+  (builtin-IO.UDP.ListenSocket.close.impl.v1 socket)
+  ; socket -> Either Failure ()
   (close-socket socket))
 
-(define-unison
-  (serverSocket.impl.v1 ip port) ; string string -> Either Failure socket
+(define-unison-builtin
+  (builtin-IO.UDP.serverSocket.impl.v1 ip port)
+  ; string string -> Either Failure socket
     (let
       ([result (handle-errors (lambda()
         (let* ([iip (chunked-string->string ip)]
@@ -115,12 +115,13 @@
             (right sock)))))])
       (wrap-in-either result)))
 
-(define-unison
-  (ListenSocket.recvFrom.impl.v1 socket) ; socket -> Either Failure (Bytes, ClientSockAddr)
-  (let ([result (handle-errors (lambda() 
+(define-unison-builtin
+  (builtin-IO.UDP.ListenSocket.recvFrom.impl.v1 socket)
+  ; socket -> Either Failure (Bytes, ClientSockAddr)
+  (let ([result (handle-errors (lambda()
     (if (not (udp? socket))
       (raise-argument-error 'socket "a UDP socket" socket)
-      (let*-values 
+      (let*-values
         ([(buffer) (make-bytes buffer-size)]
          [(len host port) (udp-receive! socket buffer)]
          [(csa) (client-sock-addr host port)]
@@ -129,18 +130,20 @@
         (right (ref-tuple-pair chunked (ref-tuple-pair csa ref-unit-unit)))))))])
     (wrap-in-either result)))
 
-(define-unison
-  (UDPSocket.send.impl.v1 socket data) ; socket -> Bytes -> Either Failure ()
+(define-unison-builtin
+  (builtin-IO.UDP.UDPSocket.send.impl.v1 socket data)
+  ; socket -> Bytes -> Either Failure ()
   (let
     ([result (handle-errors (lambda () (begin
-      (udp-send socket (chunked-bytes->bytes data)) 
+      (udp-send socket (chunked-bytes->bytes data))
       (right ref-unit-unit))))])
     (wrap-in-either result)))
 
-(define-unison
-  (ListenSocket.sendTo.impl.v1 sock bytes addr) ; socket -> Bytes -> ClientSockAddr -> Either Failure ()
+(define-unison-builtin
+  (builtin-IO.UDP.ListenSocket.sendTo.impl.v1 sock bytes addr)
+  ; socket -> Bytes -> ClientSockAddr -> Either Failure ()
   (let
-    ([result (handle-errors (lambda() 
+    ([result (handle-errors (lambda()
       (let* ([host (client-sock-addr-host addr)]
              [port (client-sock-addr-port addr)]
              [bytes (chunked-bytes->bytes bytes)])
@@ -149,28 +152,32 @@
           (right ref-unit-unit)))))])
     (wrap-in-either result)))
 
-(define-unison
-  (UDPSocket.toText.impl.v1 socket) ; socket -> string
+(define-unison-builtin
+  (builtin-IO.UDP.UDPSocket.toText.impl.v1 socket) ; socket -> string
   (format-socket socket))
 
-(define-unison
-  (ClientSockAddr.toText.v1 addr) ; ClientSocketAddr -> string
+(define-unison-builtin
+  (builtin-IO.UDP.ClientSockAddr.toText.v1 addr)
+  ; ClientSocketAddr -> string
   (string->chunked-string (format "<client-sock-addr ~a ~a>" (client-sock-addr-host addr) (client-sock-addr-port addr))))
 
-(define-unison
-  (ListenSocket.toText.impl.v1 socket) ; socket -> string
+(define-unison-builtin
+  (builtin-IO.UDP.ListenSocket.toText.impl.v1 socket)
+  ; socket -> string
   (format-socket socket))
 
-(define-unison
-  (UDPSocket.close.impl.v1 socket) ; socket -> Either Failure ()
+(define-unison-builtin
+  (builtin-IO.UDP.UDPSocket.close.impl.v1 socket)
+  ; socket -> Either Failure ()
   (let
     ([rv (handle-errors (lambda() (begin
       (udp-close socket)
       (right ref-unit-unit))))])
     (wrap-in-either rv)))
 
-(define-unison
-  (clientSocket.impl.v1 host port) ; string string -> Either Failure socket
+(define-unison-builtin
+  (builtin-IO.UDP.clientSocket.impl.v1 host port)
+  ; string string -> Either Failure socket
   (let ([rv (handle-errors (lambda() (let* ([pport (string->number (chunked-string->string port))]
          [hhost (chunked-string->string host)]
          [sock (udp-open-socket hhost pport)]

stack.yaml

@@ -29,7 +29,6 @@ packages:
   - lib/unison-util-bytes
   - lib/unison-util-cache
   - lib/unison-util-file-embed
-  - lib/unison-util-nametree
   - lib/unison-util-relation
   - lib/unison-util-rope
   - parser-typechecker
@@ -63,9 +62,14 @@ extra-deps:
   - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484
   - monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605
   - recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672
+  - numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
   - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
   - network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075
 
+allow-newer: true
+allow-newer-deps:
+  - numerals
+
 ghc-options:
   # All packages
   "$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors

stack.yaml.lock

@@ -61,6 +61,13 @@ packages:
       size: 2489
   original:
     hackage: recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672
+- completed:
+    hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
+    pantry-tree:
+      sha256: c616791b08f1792fd1d4ca03c6d2c773dedb25b24b66454c97864aefd85a5d0a
+      size: 13751
+  original:
+    hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
 - completed:
     hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
     pantry-tree:

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

unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md

@@ -1,7 +1,7 @@
 # Integration test: transcript
 
-```unison
-use .builtin
+``` unison
+use lib.builtins
 
 unique type MyBool = MyTrue | MyFalse
 
@@ -27,7 +27,7 @@ main = do
     _ -> ()
 ```
 
-```ucm
+``` ucm
 
   Loading changes detected in scratch.u.
 
@@ -43,8 +43,8 @@ main = do
       resume : Request {g, Break} x -> x
 
 ```
-```ucm
-.> add
+``` ucm
+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
 
 ```

unison-cli/package.yaml

@@ -19,6 +19,7 @@ dependencies:
   - base
   - bytes
   - bytestring
+  - cmark
   - co-log-core
   - code-page
   - concurrent-output
@@ -54,6 +55,7 @@ dependencies:
   - network-udp
   - network-uri
   - nonempty-containers
+  - numerals
   - open-browser
   - optparse-applicative >= 0.16.1.0
   - pretty-simple
@@ -93,7 +95,6 @@ dependencies:
   - unison-sqlite
   - unison-syntax
   - unison-util-base32hex
-  - unison-util-nametree
   - unison-util-relation
   - unliftio
   - unordered-containers

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

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

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)) ->
+  (ProjectPath, Branch0 IO -> Cli (Branch0 IO)) ->
   Cli Bool
-stepAt' cause = stepManyAt' @[] cause . pure
-
-stepAtNoSync' ::
-  (Path, Branch0 IO -> Cli (Branch0 IO)) ->
-  Cli Bool
-stepAtNoSync' = stepManyAtNoSync' @[] . pure
-
-stepAtNoSync ::
-  (Path, Branch0 IO -> Branch0 IO) ->
-  Cli ()
-stepAtNoSync = stepManyAtNoSync @[] . pure
+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)) ->
+  [(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] ->
   Cli Bool
-stepManyAt' reason actions = do
-  res <- stepManyAtNoSync' actions
-  syncRoot reason
-  pure res
-
-stepManyAtNoSync' ::
-  (Foldable f) =>
-  f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
-  Cli Bool
-stepManyAtNoSync' actions = do
-  origRoot <- getRootBranch
-  newRoot <- Branch.stepManyAtM actions origRoot
-  setRootBranch newRoot
-  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)) ->
+  [(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] ->
   Cli ()
-stepManyAtM reason actions = do
-  stepManyAtMNoSync actions
-  syncRoot reason
-
-stepManyAtMNoSync ::
-  (Foldable f) =>
-  f (Path, Branch0 IO -> IO (Branch0 IO)) ->
-  Cli ()
-stepManyAtMNoSync actions = do
-  oldRoot <- getRootBranch
-  newRoot <- liftIO (Branch.stepManyAtM actions oldRoot)
-  setRootBranch newRoot
-
--- | 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
+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
 
-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
+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)
 
 ------------------------------------------------------------------------------------------------------------------------

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

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

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

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

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

unison-cli/src/Unison/Cli/UnisonConfigUtils.hs

@@ -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 -> <Nothing>
-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)

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
@@ -59,12 +57,14 @@ import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge)
 import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
 import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
 import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges
+import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm)
 import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
 import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
 import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
 import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI)
 import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format
 import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib)
+import Unison.Codebase.Editor.HandleInput.LSPDebug qualified as LSPDebug
 import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile)
 import Unison.Codebase.Editor.HandleInput.Ls (handleLs)
 import Unison.Codebase.Editor.HandleInput.Merge2 (handleMerge)
@@ -81,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
@@ -93,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
@@ -105,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
@@ -115,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.HashQualifiedPrime qualified as HQ'
 import Unison.LabeledDependency (LabeledDependency)
@@ -132,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)
@@ -202,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 $
@@ -209,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) =
@@ -248,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
@@ -335,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
@@ -358,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
@@ -404,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, _) ->
@@ -416,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
@@ -437,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 $
@@ -445,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'
@@ -464,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
@@ -490,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'
@@ -513,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
@@ -537,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) ->
@@ -575,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
@@ -613,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
@@ -640,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
@@ -697,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
@@ -756,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
@@ -783,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
@@ -805,20 +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
@@ -888,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 ["<unnamed>"] 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
@@ -934,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
@@ -944,6 +882,7 @@ loop e = do
             UpgradeI old new -> handleUpgrade old new
             UpgradeCommitI -> handleCommitUpgrade
             LibInstallI remind libdep -> handleInstallLib remind libdep
+            DebugSynhashTermI name -> handleDebugSynhashTerm name
 
 inputDescription :: Input -> Cli Text
 inputDescription input =
@@ -954,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
@@ -1056,7 +992,17 @@ inputDescription input =
     CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
     ClearI {} -> pure "clear"
     DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
-    --
+    DebugTermI verbose hqName ->
+      if verbose
+        then pure ("debug.term.verbose " <> HQ.toText hqName)
+        else pure ("debug.term " <> HQ.toText hqName)
+    DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
+    DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges"
+    DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
+    DebugFormatI -> pure "debug.format"
+    EditNamespaceI paths ->
+      pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
+    -- wat land
     ApiI -> wat
     AuthLoginI {} -> wat
     BranchI {} -> wat
@@ -1068,17 +1014,11 @@ inputDescription input =
     DebugDoctorI {} -> wat
     DebugDumpNamespaceSimpleI {} -> wat
     DebugDumpNamespacesI {} -> wat
-    DebugTermI verbose hqName ->
-      if verbose
-        then pure ("debug.term.verbose " <> HQ.toText hqName)
-        else pure ("debug.term " <> HQ.toText hqName)
-    DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
-    DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges"
+    DebugLSPNameCompletionI {} -> wat
     DebugNameDiffI {} -> wat
     DebugNumberedArgsI {} -> wat
-    DebugTabCompletionI _input -> wat
-    DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
-    DebugFormatI -> pure "debug.format"
+    DebugSynhashTermI {} -> wat
+    DebugTabCompletionI {} -> wat
     DebugTypecheckedUnisonFileI {} -> wat
     DiffNamespaceI {} -> wat
     DisplayI {} -> wat
@@ -1086,15 +1026,13 @@ inputDescription input =
     DocsToHtmlI {} -> wat
     FindI {} -> wat
     FindShallowI {} -> wat
-    StructuredFindI {} -> wat
-    StructuredFindReplaceI {} -> wat
     HistoryI {} -> wat
     LibInstallI {} -> wat
     ListDependenciesI {} -> wat
     ListDependentsI {} -> wat
     LoadI {} -> wat
-    MergeI {} -> wat
     MergeCommitI {} -> wat
+    MergeI {} -> wat
     NamesI {} -> wat
     NamespaceDependenciesI {} -> wat
     PopBranchI {} -> wat
@@ -1110,26 +1048,34 @@ inputDescription input =
     QuitI {} -> wat
     ReleaseDraftI {} -> wat
     ShowDefinitionI {} -> wat
-    EditNamespaceI paths ->
-      pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
-    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
     UiI {} -> wat
     UpI {} -> wat
-    UpgradeI {} -> wat
     UpgradeCommitI {} -> wat
+    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"
@@ -1144,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 ->
@@ -1162,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.
@@ -1170,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 =
@@ -1316,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
@@ -1527,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'
@@ -1547,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)
@@ -1574,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
@@ -1589,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
@@ -1598,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)
 
@@ -1659,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
@@ -1771,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)

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)

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
+      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)
 
-  project <-
-    Cli.runTransactionWithRollback \rollback -> do
-      Queries.loadProjectByName projectName & onNothingM do
-        -- We can't make the *first* branch of a project with `branch`; the project has to already exist.
-        rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
-
-  _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
+  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)

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

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

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
 

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
 

unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugSynhashTerm.hs

@@ -0,0 +1,65 @@
+-- | @debug.synhash.term@ input handler.
+module Unison.Codebase.Editor.HandleInput.DebugSynhashTerm
+  ( handleDebugSynhashTerm,
+  )
+where
+
+import Control.Monad.Reader (ask)
+import U.Util.Base32Hex qualified as Base32Hex
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Cli.MonadUtils qualified as Cli
+import Unison.Cli.Pretty (prettyBase32Hex, prettyHash)
+import Unison.Cli.PrettyPrintUtils qualified as Cli
+import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Branch.Names qualified as Branch
+import Unison.Codebase.Editor.Output (Output (..))
+import Unison.Hash (Hash)
+import Unison.Hashable qualified as Hashable
+import Unison.Merge.Synhash (hashBuiltinTermTokens, hashDerivedTermTokens)
+import Unison.Name (Name)
+import Unison.Names qualified as Names
+import Unison.Prelude
+import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
+import Unison.Reference qualified as Reference
+import Unison.Util.Pretty (ColorText, Pretty)
+import Unison.Util.Pretty qualified as Pretty
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Unison.Syntax.Name as Name
+
+handleDebugSynhashTerm :: Name -> Cli ()
+handleDebugSynhashTerm name = do
+  namespace <- Cli.getCurrentBranch0
+  let names = Branch.toNames namespace
+  pped <- Cli.prettyPrintEnvDeclFromNames names
+
+  for_ (Names.refTermsNamed names name) \ref -> do
+    maybeTokens <-
+      case ref of
+        Reference.Builtin builtin -> pure (Just (hashBuiltinTermTokens builtin))
+        Reference.DerivedId refId -> do
+          env <- ask
+          Cli.runTransaction (Codebase.getTerm env.codebase refId) <&> \case
+            Nothing -> Nothing
+            Just term -> Just (hashDerivedTermTokens pped.unsuffixifiedPPE term)
+    whenJust maybeTokens \tokens -> do
+      let filename = Name.toText name <> "-" <> Reference.toText ref <> "-synhash-tokens.txt"
+      let renderedTokens =
+            tokens
+              & map prettyToken
+              & Pretty.lines
+              & Pretty.toAnsiUnbroken
+              & Text.pack
+      liftIO (Text.writeFile (Text.unpack filename) renderedTokens)
+      Cli.respond (Output'DebugSynhashTerm ref (Hashable.accumulate tokens) filename)
+
+prettyToken :: Hashable.Token Hash -> Pretty ColorText
+prettyToken = \case
+  Hashable.Bytes bytes -> "0x" <> prettyBase32Hex (Base32Hex.fromByteString bytes)
+  Hashable.Double n -> Pretty.string (show n)
+  Hashable.Hashed h -> prettyHash h
+  Hashable.Int n -> (if n >= 0 then "+" else mempty) <> Pretty.string (show n)
+  Hashable.Nat n -> Pretty.string (show n)
+  Hashable.Tag n -> "@" <> Pretty.string (show n)
+  Hashable.Text s -> Pretty.string (show s)

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

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

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)
 

unison-cli/src/Unison/Codebase/Editor/HandleInput/LSPDebug.hs

@@ -0,0 +1,15 @@
+module Unison.Codebase.Editor.HandleInput.LSPDebug (debugLspNameCompletion) where
+
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Cli.NamesUtils qualified as Cli
+import Unison.Codebase.Editor.Output (Output (DisplayDebugLSPNameCompletions))
+import Unison.LSP.Completion qualified as Completion
+import Unison.Prelude
+
+debugLspNameCompletion :: Text -> Cli ()
+debugLspNameCompletion prefix = do
+  names <- Cli.currentNames
+  let ct = Completion.namesToCompletionTree names
+  let (_, matches) = Completion.completionsForQuery ct prefix
+  Cli.respond $ DisplayDebugLSPNameCompletions matches

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

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

unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs

@@ -1,3 +1,4 @@
+-- | @merge@ input handler.
 module Unison.Codebase.Editor.HandleInput.Merge2
   ( handleMerge,
 
@@ -8,6 +9,9 @@ module Unison.Codebase.Editor.HandleInput.Merge2
     LcaMergeInfo (..),
     doMerge,
     doMergeLocalBranch,
+
+    -- * API exported for @todo@
+    hasDefnsInLib,
   )
 where
 
@@ -65,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
@@ -85,6 +91,7 @@ import Unison.Merge.EitherWay (EitherWay (..))
 import Unison.Merge.EitherWayI (EitherWayI (..))
 import Unison.Merge.EitherWayI qualified as EitherWayI
 import Unison.Merge.Libdeps qualified as Merge
+import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
 import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
 import Unison.Merge.Synhashed (Synhashed (..))
 import Unison.Merge.Synhashed qualified as Synhashed
@@ -138,12 +145,12 @@ import Unison.Util.SyntaxText (SyntaxText')
 import Unison.Var (Var)
 import Witch (unsafeFrom)
 import Prelude hiding (unzip, zip, zipWith)
-import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
 
 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.
@@ -193,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
@@ -210,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
@@ -238,11 +244,7 @@ doMerge info = do
 
       -- Assert that neither Alice nor Bob have defns in lib
       for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
-        libdeps <-
-          case Map.lookup NameSegment.libSegment branch.children of
-            Nothing -> pure V2.Branch.empty
-            Just libdeps -> Cli.runTransaction libdeps.value
-        when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
+        whenM (Cli.runTransaction (hasDefnsInLib branch)) do
           done (Output.MergeDefnsInLib who)
 
       -- Load Alice/Bob/LCA definitions and decl name lookups
@@ -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)
@@ -485,6 +486,17 @@ loadLibdeps branches = do
           libdepsBranch <- libdepsCausal.value
           pure libdepsBranch.children
 
+------------------------------------------------------------------------------------------------------------------------
+-- Merge precondition violation checks
+
+hasDefnsInLib :: Applicative m => V2.Branch m -> m Bool
+hasDefnsInLib branch = do
+  libdeps <-
+    case Map.lookup NameSegment.libSegment branch.children of
+      Nothing -> pure V2.Branch.empty
+      Just libdeps -> libdeps.value
+  pure (not (Map.null libdeps.terms) || not (Map.null libdeps.types))
+
 ------------------------------------------------------------------------------------------------------------------------
 -- Creating Unison files
 

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

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

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

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

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,

unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDiffUtils.hs

@@ -36,7 +36,7 @@ diffHelper before after =
     Cli.Env {codebase} <- ask
     hqLength <- Cli.runTransaction Codebase.hashLength
     diff <- liftIO (BranchDiff.diff0 before after)
-    names <- Cli.currentNames
+    names <- Cli.currentNames <&> \currentNames -> currentNames <> Branch.toNames before <> Branch.toNames after
     pped <- Cli.prettyPrintEnvDeclFromNames names
     let suffixifiedPPE = PPED.suffixifiedPPE pped
     fmap (suffixifiedPPE,) do

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

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

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)