Solve conflicts

Sync.hs

@@ -0,0 +1,930 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Unison.Share.Sync
+  ( -- ** Get causal hash by path
+    getCausalHashByPath,
+    GetCausalHashByPathError (..),
+
+    -- ** Push
+    checkAndSetPush,
+    CheckAndSetPushError (..),
+    uploadEntities,
+
+    -- ** Pull
+    pull,
+    PullError (..),
+    downloadEntities,
+  )
+where
+
+import Control.Concurrent.STM
+import Control.Lens
+import Control.Monad.Except
+import Control.Monad.Reader (ask)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+import Control.Monad.Trans.Reader qualified as Reader
+import Data.Foldable qualified as Foldable (find)
+import Data.List.NonEmpty (pattern (:|))
+import Data.List.NonEmpty qualified as List (NonEmpty)
+import Data.List.NonEmpty qualified as List.NonEmpty
+import Data.Map qualified as Map
+import Data.Map.NonEmpty (NEMap)
+import Data.Map.NonEmpty qualified as NEMap
+import Data.Proxy
+import Data.Sequence.NonEmpty (NESeq ((:<||)))
+import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|))
+import Data.Set qualified as Set
+import Data.Set.NonEmpty (NESet)
+import Data.Set.NonEmpty qualified as NESet
+import Data.Text.Lazy qualified as Text.Lazy
+import Data.Text.Lazy.Encoding qualified as Text.Lazy
+import GHC.IO (unsafePerformIO)
+import Ki qualified
+import Network.HTTP.Client qualified as Http.Client
+import Network.HTTP.Types qualified as HTTP
+import Servant.API qualified as Servant ((:<|>) (..), (:>))
+import Servant.Client (BaseUrl)
+import Servant.Client qualified as Servant
+import System.Environment (lookupEnv)
+import U.Codebase.HashTags (CausalHash)
+import U.Codebase.Sqlite.Queries qualified as Q
+import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
+import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
+import Unison.Auth.HTTPClient qualified as Auth
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Codebase qualified as Codebase
+import Unison.Debug qualified as Debug
+import Unison.Hash32 (Hash32)
+import Unison.Prelude
+import Unison.Share.API.Hash qualified as Share
+import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches)
+import Unison.Share.Sync.Types
+import Unison.Sqlite qualified as Sqlite
+import Unison.Sync.API qualified as Share (API)
+import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash)
+import Unison.Sync.EntityValidation qualified as EV
+import Unison.Sync.Types qualified as Share
+import Unison.Util.Monoid (foldMapM)
+
+------------------------------------------------------------------------------------------------------------------------
+-- Pile of constants
+
+-- | The maximum number of downloader threads, during a pull.
+maxSimultaneousPullDownloaders :: Int
+maxSimultaneousPullDownloaders = unsafePerformIO $ do
+  lookupEnv "UNISON_PULL_WORKERS" <&> \case
+    Just n -> read n
+    Nothing -> 5
+{-# NOINLINE maxSimultaneousPullDownloaders #-}
+
+-- | The maximum number of push workers at a time. Each push worker reads from the database and uploads entities.
+-- Share currently parallelizes on it's own in the backend, and any more than one push worker
+-- just results in serialization conflicts which slow things down.
+maxSimultaneousPushWorkers :: Int
+maxSimultaneousPushWorkers = unsafePerformIO $ do
+  lookupEnv "UNISON_PUSH_WORKERS" <&> \case
+    Just n -> read n
+    Nothing -> 1
+{-# NOINLINE maxSimultaneousPushWorkers #-}
+
+syncChunkSize :: Int
+syncChunkSize = unsafePerformIO $ do
+  lookupEnv "UNISON_SYNC_CHUNK_SIZE" <&> \case
+    Just n -> read n
+    Nothing -> 50
+{-# NOINLINE syncChunkSize #-}
+
+------------------------------------------------------------------------------------------------------------------------
+-- Push
+
+-- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the
+-- server is missing, too) to Unison Share.
+--
+-- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation
+-- is off, we won't proceed with the push.
+checkAndSetPush ::
+  -- | The Unison Share URL.
+  BaseUrl ->
+  -- | The repo+path to push to.
+  Share.Path ->
+  -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error.
+  -- This prevents accidentally pushing over data that we didn't know was there.
+  Maybe Hash32 ->
+  -- | The hash of our local causal to push.
+  CausalHash ->
+  -- | Callback that's given a number of entities we just uploaded.
+  (Int -> IO ()) ->
+  Cli (Either (SyncError CheckAndSetPushError) ())
+checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do
+  Cli.Env {authHTTPClient} <- ask
+
+  Cli.label \done -> do
+    let failed :: SyncError CheckAndSetPushError -> Cli void
+        failed = done . Left
+
+    let updatePathError :: Share.UpdatePathError -> Cli void
+        updatePathError err =
+          failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err))
+
+    -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it
+    -- needs this causal (UpdatePathMissingDependencies).
+    dependencies <-
+      updatePath >>= \case
+        Share.UpdatePathSuccess -> done (Right ())
+        Share.UpdatePathFailure err ->
+          case err of
+            Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies
+            _ -> updatePathError err
+
+    -- Upload the causal and all of its dependencies.
+    uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err ->
+      failed (CheckAndSetPushError'UploadEntities <$> err)
+
+    -- After uploading the causal and all of its dependencies, try setting the remote path again.
+    updatePath >>= \case
+      Share.UpdatePathSuccess -> pure (Right ())
+      Share.UpdatePathFailure err -> updatePathError err
+
+-- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments,
+-- excluding the newest hash (second argument).
+loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32])
+loadCausalSpineBetween earlierHash laterHash =
+  dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash
+
+data Step a
+  = DeadEnd
+  | KeepSearching (List.NonEmpty a)
+  | FoundGoal a
+
+-- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each
+-- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True).
+--
+-- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because
+-- it was provided as an input ;))
+--
+-- For example, when searching a tree that looks like
+--
+--                    1
+--                   / \
+--                  2   3
+--                 / \   \
+--                4  [5]  6
+--
+-- (where the goal is marked [5]), we'd return
+--
+--                Just [5,2]
+--
+-- And (as another example), if the root node is the goal,
+--
+--                   [1]
+--                   / \
+--                  2   3
+--                 / \   \
+--                4   5   6
+--
+-- we'd return
+--
+--                Just []
+dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a])
+dagbfs goal children =
+  let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied,
+      -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet.
+      -- (Otherwise, we wouldn't still be in this loop, we'd return!).
+      --
+      -- For example, say we are exploring the tree
+      --
+      --                    1
+      --                   / \
+      --                  2   3
+      --                 / \   \
+      --                4   5   6
+      --
+      -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below
+      -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children,
+      -- and maybe it doesn't).
+      --
+      -- The loop state, in this case, would be these three paths:
+      --
+      --   [ 4, 2 ]
+      --   [ 5, 2 ]
+      --   [ 6, 3 ]
+      --
+      -- (Note, again, that we do not include the root).
+      go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a))
+      go (path :<|| paths) =
+        -- Step forward from the first path in our loop state (in the example above, [4, 2]).
+        step (List.NonEmpty.head path) >>= \case
+          -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep
+          -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because
+          -- this was the only remaining path.
+          DeadEnd ->
+            case NESeq.nonEmptySeq paths of
+              Nothing -> pure Nothing
+              Just paths' -> go paths'
+          -- If node 4 did have children, then maybe the search tree now looks like this.
+          --
+          --                1
+          --               / \
+          --              2   3
+          --             / \   \
+          --            4   5   6
+          --           / \
+          --          7   8
+          --
+          -- There are two cases to handle:
+          --
+          --   1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path
+          --
+          --        [ 7, 4, 2 ]
+          --
+          --   2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end
+          --      of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four
+          --      paths:
+          --
+          --        [ 5, 2 ]      \ these two are are variable 'paths', the tail of the loop state.
+          --        [ 6, 3 ]      /
+          --        [ 7, 4, 2 ]   \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children
+          --        [ 8, 4, 2 ]   / to itself, making two new paths to search
+          KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys))
+          FoundGoal y -> pure (Just (List.NonEmpty.cons y path))
+
+      -- Step forward from a single node. There are 3 possible outcomes:
+      --
+      --   1. We discover it has no children. (return DeadEnd)
+      --   2. We discover is has children, none of which are a goal. (return KeepSearching)
+      --   3. We discover it has children, (at least) one of which is a goal. (return FoundGoal)
+      step :: a -> m (Step a)
+      step x = do
+        ys0 <- children x
+        pure case List.NonEmpty.nonEmpty ys0 of
+          Nothing -> DeadEnd
+          Just ys ->
+            case Foldable.find goal ys of
+              Nothing -> KeepSearching ys
+              Just y -> FoundGoal y
+   in \root ->
+        if goal root
+          then pure (Just [])
+          else
+            step root >>= \case
+              DeadEnd -> pure Nothing
+              -- lts-18.28 doesn't have List.NonEmpty.singleton
+              KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs))
+              FoundGoal x -> pure (Just [x])
+  where
+    -- Concatenate a seq and a non-empty seq.
+    append :: Seq x -> NESeq x -> NESeq x
+    append = (NESeq.><|)
+
+------------------------------------------------------------------------------------------------------------------------
+-- Pull
+
+pull ::
+  -- | The Unison Share URL.
+  BaseUrl ->
+  -- | The repo+path to pull from.
+  Share.Path ->
+  -- | Callback that's given a number of entities we just downloaded.
+  (Int -> IO ()) ->
+  Cli (Either (SyncError PullError) CausalHash)
+pull unisonShareUrl repoPath downloadedCallback =
+  getCausalHashByPath unisonShareUrl repoPath >>= \case
+    Left err -> pure (Left (PullError'GetCausalHash <$> err))
+    -- There's nothing at the remote path, so there's no causal to pull.
+    Right Nothing -> pure (Left (SyncError (PullError'NoHistoryAtPath repoPath)))
+    Right (Just hashJwt) ->
+      downloadEntities unisonShareUrl (Share.pathRepoInfo repoPath) hashJwt downloadedCallback <&> \case
+        Left err -> Left (PullError'DownloadEntities <$> err)
+        Right () -> Right (hash32ToCausalHash (Share.hashJWTHash hashJwt))
+
+------------------------------------------------------------------------------------------------------------------------
+-- Download entities
+
+downloadEntities ::
+  -- | The Unison Share URL.
+  BaseUrl ->
+  -- | The repo to download from.
+  Share.RepoInfo ->
+  -- | The hash to download.
+  Share.HashJWT ->
+  -- | Callback that's given a number of entities we just downloaded.
+  (Int -> IO ()) ->
+  Cli (Either (SyncError Share.DownloadEntitiesError) ())
+downloadEntities unisonShareUrl repoInfo hashJwt downloadedCallback = do
+  Cli.Env {authHTTPClient, codebase} <- ask
+
+  Cli.label \done -> do
+    let failed :: SyncError Share.DownloadEntitiesError -> Cli void
+        failed = done . Left
+
+    let hash = Share.hashJWTHash hashJwt
+
+    maybeTempEntities <-
+      Cli.runTransaction (Q.entityLocation hash) >>= \case
+        Just Q.EntityInMainStorage -> pure Nothing
+        Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash))
+        Nothing -> do
+          let request =
+                httpDownloadEntities
+                  authHTTPClient
+                  unisonShareUrl
+                  Share.DownloadEntitiesRequest {repoInfo, hashes = NESet.singleton hashJwt}
+          entities <-
+            liftIO request >>= \case
+              Left err -> failed (TransportError err)
+              Right (Share.DownloadEntitiesFailure err) -> failed (SyncError err)
+              Right (Share.DownloadEntitiesSuccess entities) -> pure entities
+          case validateEntities entities of
+            Left err -> failed . SyncError . Share.DownloadEntitiesEntityValidationFailure $ err
+            Right () -> pure ()
+          tempEntities <- Cli.runTransaction (insertEntities entities)
+          liftIO (downloadedCallback 1)
+          pure (NESet.nonEmptySet tempEntities)
+
+    whenJust maybeTempEntities \tempEntities -> do
+      let doCompleteTempEntities =
+            completeTempEntities
+              authHTTPClient
+              unisonShareUrl
+              ( \action ->
+                  Codebase.withConnection codebase \conn ->
+                    action (Sqlite.runTransaction conn)
+              )
+              repoInfo
+              downloadedCallback
+              tempEntities
+      liftIO doCompleteTempEntities & onLeftM \err ->
+        failed err
+    -- Since we may have just inserted and then deleted many temp entities, we attempt to recover some disk space by
+    -- vacuuming after each pull. If the vacuum fails due to another open transaction on this connection, that's ok,
+    -- we'll try vacuuming again next pull.
+    _success <- liftIO (Codebase.withConnection codebase Sqlite.vacuum)
+    pure (Right ())
+
+-- | Validates the provided entities if and only if the environment variable `UNISON_ENTITY_VALIDATION` is set to "true".
+validateEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Either Share.EntityValidationError ()
+validateEntities entities =
+  when shouldValidateEntities $ do
+    ifor_ (NEMap.toMap entities) \hash entity -> do
+      let entityWithHashes = entity & Share.entityHashes_ %~ Share.hashJWTHash
+      case EV.validateEntity hash entityWithHashes of
+        Nothing -> pure ()
+        Just err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) ->
+          let expectedMismatches = case et of
+                Share.TermComponentType -> expectedComponentHashMismatches
+                Share.DeclComponentType -> expectedComponentHashMismatches
+                Share.CausalType -> expectedCausalHashMismatches
+                _ -> mempty
+           in case Map.lookup supplied expectedMismatches of
+                Just expected
+                  | expected == computed -> pure ()
+                _ -> do
+                  Left err
+        Just err -> do
+          Left err
+
+-- | Validate entities received from the server unless this flag is set to false.
+validationEnvKey :: String
+validationEnvKey = "UNISON_ENTITY_VALIDATION"
+
+shouldValidateEntities :: Bool
+shouldValidateEntities = unsafePerformIO $ do
+  lookupEnv validationEnvKey <&> \case
+    Just "false" -> False
+    _ -> True
+{-# NOINLINE shouldValidateEntities #-}
+
+type WorkerCount =
+  TVar Int
+
+newWorkerCount :: IO WorkerCount
+newWorkerCount =
+  newTVarIO 0
+
+recordWorking :: WorkerCount -> STM ()
+recordWorking sem =
+  modifyTVar' sem (+ 1)
+
+recordNotWorking :: WorkerCount -> STM ()
+recordNotWorking sem =
+  modifyTVar' sem \n -> n - 1
+
+-- What the dispatcher is to do
+data DispatcherJob
+  = DispatcherForkWorker (NESet Share.HashJWT)
+  | DispatcherReturnEarlyBecauseDownloaderFailed (SyncError Share.DownloadEntitiesError)
+  | DispatcherDone
+
+-- | Finish downloading entities from Unison Share (or return the first failure to download something).
+--
+-- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the
+-- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage.
+completeTempEntities ::
+  AuthenticatedHttpClient ->
+  BaseUrl ->
+  (forall a. ((forall x. Sqlite.Transaction x -> IO x) -> IO a) -> IO a) ->
+  Share.RepoInfo ->
+  (Int -> IO ()) ->
+  NESet Hash32 ->
+  IO (Either (SyncError Share.DownloadEntitiesError) ())
+completeTempEntities httpClient unisonShareUrl connect repoInfo downloadedCallback initialNewTempEntities = do
+  -- The set of hashes we still need to download
+  hashesVar <- newTVarIO Set.empty
+
+  -- The set of hashes that we haven't inserted yet, but will soon, because we've committed to downloading them.
+  uninsertedHashesVar <- newTVarIO Set.empty
+
+  -- The entities payloads (along with the jwts that we used to download them) that we've downloaded
+  entitiesQueue <- newTQueueIO
+
+  -- The sets of new (at the time of inserting, anyway) temp entity rows, which we need to elaborate, then download.
+  newTempEntitiesQueue <- newTQueueIO
+
+  -- How many workers (downloader / inserter / elaborator) are currently doing stuff.
+  workerCount <- newWorkerCount
+
+  -- The first download error seen by a downloader, if any.
+  downloaderFailedVar <- newEmptyTMVarIO
+
+  -- Kick off the cycle of inserter->elaborator->dispatcher->downloader by giving the elaborator something to do
+  atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities))
+
+  Ki.scoped \scope -> do
+    Ki.fork_ scope (inserter entitiesQueue newTempEntitiesQueue workerCount)
+    Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount)
+    dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar
+  where
+    -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders.
+    --
+    -- We stop when either all of the following are true:
+    --
+    --   - There are no outstanding workers (downloaders, inserter, elaboraror)
+    --   - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`)
+    --   - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`)
+    --
+    -- Or:
+    --
+    --   - Some downloader failed to download something
+    dispatcher ::
+      TVar (Set Share.HashJWT) ->
+      TVar (Set Share.HashJWT) ->
+      TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) ->
+      TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) ->
+      WorkerCount ->
+      TMVar (SyncError Share.DownloadEntitiesError) ->
+      IO (Either (SyncError Share.DownloadEntitiesError) ())
+    dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount downloaderFailedVar =
+      Ki.scoped \scope ->
+        let loop :: IO (Either (SyncError Share.DownloadEntitiesError) ())
+            loop =
+              atomically (checkIfDownloaderFailedMode <|> dispatchWorkMode <|> checkIfDoneMode) >>= \case
+                DispatcherDone -> pure (Right ())
+                DispatcherReturnEarlyBecauseDownloaderFailed err -> pure (Left err)
+                DispatcherForkWorker hashes -> do
+                  atomically do
+                    -- Limit number of simultaneous downloaders (plus 2, for inserter and elaborator)
+                    workers <- readTVar workerCount
+                    check (workers < maxSimultaneousPullDownloaders + 2)
+                    -- we do need to record the downloader as working outside of the worker thread, not inside.
+                    -- otherwise, we might erroneously fall through the teardown logic below and conclude there's
+                    -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as
+                    -- far as recording its own existence
+                    recordWorking workerCount
+                  _ <-
+                    Ki.fork @() scope do
+                      downloader entitiesQueue workerCount hashes & onLeftM \err ->
+                        void (atomically (tryPutTMVar downloaderFailedVar err))
+                  loop
+         in loop
+      where
+        checkIfDownloaderFailedMode :: STM DispatcherJob
+        checkIfDownloaderFailedMode =
+          DispatcherReturnEarlyBecauseDownloaderFailed <$> readTMVar downloaderFailedVar
+
+        dispatchWorkMode :: STM DispatcherJob
+        dispatchWorkMode = do
+          hashes <- readTVar hashesVar
+          check (not (Set.null hashes))
+          let (hashes1, hashes2) = Set.splitAt syncChunkSize hashes
+          modifyTVar' uninsertedHashesVar (Set.union hashes1)
+          writeTVar hashesVar hashes2
+          pure (DispatcherForkWorker (NESet.unsafeFromSet hashes1))
+
+        -- Check to see if there are no hashes left to download, no outstanding workers, and no work in either queue
+        checkIfDoneMode :: STM DispatcherJob
+        checkIfDoneMode = do
+          workers <- readTVar workerCount
+          check (workers == 0)
+          isEmptyTQueue entitiesQueue >>= check
+          isEmptyTQueue newTempEntitiesQueue >>= check
+          pure DispatcherDone
+
+    -- Downloader thread: download entities, (if successful) enqueue to `entitiesQueue`
+    downloader ::
+      TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) ->
+      WorkerCount ->
+      NESet Share.HashJWT ->
+      IO (Either (SyncError Share.DownloadEntitiesError) ())
+    downloader entitiesQueue workerCount hashes = do
+      httpDownloadEntities httpClient unisonShareUrl Share.DownloadEntitiesRequest {repoInfo, hashes} >>= \case
+        Left err -> do
+          atomically (recordNotWorking workerCount)
+          pure (Left (TransportError err))
+        Right (Share.DownloadEntitiesFailure err) -> do
+          atomically (recordNotWorking workerCount)
+          pure (Left (SyncError err))
+        Right (Share.DownloadEntitiesSuccess entities) -> do
+          downloadedCallback (NESet.size hashes)
+          case validateEntities entities of
+            Left err -> pure . Left . SyncError . Share.DownloadEntitiesEntityValidationFailure $ err
+            Right () -> do
+              atomically do
+                writeTQueue entitiesQueue (hashes, entities)
+                recordNotWorking workerCount
+              pure (Right ())
+
+    -- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue`
+    inserter ::
+      TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) ->
+      TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) ->
+      WorkerCount ->
+      IO Void
+    inserter entitiesQueue newTempEntitiesQueue workerCount =
+      connect \runTransaction ->
+        forever do
+          (hashJwts, entities) <-
+            atomically do
+              entities <- readTQueue entitiesQueue
+              recordWorking workerCount
+              pure entities
+          newTempEntities0 <-
+            runTransaction do
+              NEMap.toList entities & foldMapM \(hash, entity) ->
+                upsertEntitySomewhere hash entity <&> \case
+                  Q.EntityInMainStorage -> Set.empty
+                  Q.EntityInTempStorage -> Set.singleton hash
+          atomically do
+            writeTQueue newTempEntitiesQueue (NESet.toSet hashJwts, NESet.nonEmptySet newTempEntities0)
+            recordNotWorking workerCount
+
+    -- Elaborator thread: dequeue from `newTempEntitiesQueue`, elaborate, "enqueue" to `hashesVar`
+    elaborator ::
+      TVar (Set Share.HashJWT) ->
+      TVar (Set Share.HashJWT) ->
+      TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) ->
+      WorkerCount ->
+      IO Void
+    elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount =
+      connect \runTransaction ->
+        forever do
+          maybeNewTempEntities <-
+            atomically do
+              (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue
+              -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would
+              -- still be correct if we never delete from `uninsertedHashes`.
+              --
+              -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion
+              -- in order to ensure that no running transaction of the elaborator is viewing a snapshot that precedes
+              -- the snapshot that inserted those hashes.
+              modifyTVar' uninsertedHashesVar \uninsertedHashes -> Set.difference uninsertedHashes hashJwts
+              case mayNewTempEntities of
+                Nothing -> pure Nothing
+                Just newTempEntities -> do
+                  recordWorking workerCount
+                  pure (Just newTempEntities)
+          whenJust maybeNewTempEntities \newTempEntities -> do
+            newElaboratedHashes <- runTransaction (elaborateHashes newTempEntities)
+            atomically do
+              uninsertedHashes <- readTVar uninsertedHashesVar
+              hashes0 <- readTVar hashesVar
+              writeTVar hashesVar $! Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0
+              recordNotWorking workerCount
+
+-- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than
+-- of main storage (`object` / `causal`) due to missing dependencies.
+insertEntities :: NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> Sqlite.Transaction (Set Hash32)
+insertEntities entities =
+  NEMap.toList entities & foldMapM \(hash, entity) ->
+    upsertEntitySomewhere hash entity <&> \case
+      Q.EntityInMainStorage -> Set.empty
+      Q.EntityInTempStorage -> Set.singleton hash
+
+------------------------------------------------------------------------------------------------------------------------
+-- Get causal hash by path
+
+-- | Get the causal hash of a path hosted on Unison Share.
+getCausalHashByPath ::
+  -- | The Unison Share URL.
+  BaseUrl ->
+  Share.Path ->
+  Cli (Either (SyncError GetCausalHashByPathError) (Maybe Share.HashJWT))
+getCausalHashByPath unisonShareUrl repoPath = do
+  Cli.Env {authHTTPClient} <- ask
+  liftIO (httpGetCausalHashByPath authHTTPClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath)) <&> \case
+    Left err -> Left (TransportError err)
+    Right (Share.GetCausalHashByPathSuccess maybeHashJwt) -> Right maybeHashJwt
+    Right (Share.GetCausalHashByPathNoReadPermission _) ->
+      Left (SyncError (GetCausalHashByPathErrorNoReadPermission repoPath))
+    Right (Share.GetCausalHashByPathInvalidRepoInfo err repoInfo) ->
+      Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo err repoInfo))
+    Right Share.GetCausalHashByPathUserNotFound ->
+      Left (SyncError $ GetCausalHashByPathErrorUserNotFound (Share.pathRepoInfo repoPath))
+
+------------------------------------------------------------------------------------------------------------------------
+-- Upload entities
+
+data UploadDispatcherJob
+  = UploadDispatcherReturnFailure (SyncError Share.UploadEntitiesError)
+  | UploadDispatcherForkWorkerWhenAvailable (NESet Hash32)
+  | UploadDispatcherForkWorker (NESet Hash32)
+  | UploadDispatcherDone
+
+-- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to
+-- missing dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing
+-- anything.
+--
+-- Returns true on success, false on failure (because the user does not have write permission).
+uploadEntities ::
+  BaseUrl ->
+  Share.RepoInfo ->
+  NESet Hash32 ->
+  (Int -> IO ()) ->
+  Cli (Either (SyncError Share.UploadEntitiesError) ())
+uploadEntities unisonShareUrl repoInfo hashes0 uploadedCallback = do
+  Cli.Env {authHTTPClient, codebase} <- ask
+
+  liftIO do
+    hashesVar <- newTVarIO (NESet.toSet hashes0)
+    -- Semantically, this is the set of hashes we've uploaded so far, but we do delete from it when it's safe to, so it
+    -- doesn't grow unbounded. It's used to filter out hashes that would be duplicate uploads: the server, when
+    -- responding to any particular upload request, may declare that it still needs some hashes that we're in the
+    -- process of uploading from another thread.
+    dedupeVar <- newTVarIO Set.empty
+    nextWorkerIdVar <- newTVarIO 0
+    workersVar <- newTVarIO Set.empty
+    workerFailedVar <- newEmptyTMVarIO
+
+    Ki.scoped \scope ->
+      dispatcher
+        scope
+        authHTTPClient
+        (Codebase.runTransaction codebase)
+        hashesVar
+        dedupeVar
+        nextWorkerIdVar
+        workersVar
+        workerFailedVar
+  where
+    dispatcher ::
+      Ki.Scope ->
+      AuthenticatedHttpClient ->
+      (forall a. Sqlite.Transaction a -> IO a) ->
+      TVar (Set Hash32) ->
+      TVar (Set Hash32) ->
+      TVar Int ->
+      TVar (Set Int) ->
+      TMVar (SyncError Share.UploadEntitiesError) ->
+      IO (Either (SyncError Share.UploadEntitiesError) ())
+    dispatcher scope httpClient runTransaction hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do
+      loop
+      where
+        loop :: IO (Either (SyncError Share.UploadEntitiesError) ())
+        loop =
+          doJob [checkForFailureMode, dispatchWorkMode, checkIfDoneMode]
+
+        doJob :: [STM UploadDispatcherJob] -> IO (Either (SyncError Share.UploadEntitiesError) ())
+        doJob jobs =
+          atomically (asum jobs) >>= \case
+            UploadDispatcherReturnFailure err -> pure (Left err)
+            UploadDispatcherForkWorkerWhenAvailable hashes -> doJob [forkWorkerMode hashes, checkForFailureMode]
+            UploadDispatcherForkWorker hashes -> do
+              workerId <-
+                atomically do
+                  workerId <- readTVar nextWorkerIdVar
+                  writeTVar nextWorkerIdVar $! workerId + 1
+                  modifyTVar' workersVar (Set.insert workerId)
+                  pure workerId
+              _ <-
+                Ki.fork @() scope do
+                  worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes
+              loop
+            UploadDispatcherDone -> pure (Right ())
+
+        checkForFailureMode :: STM UploadDispatcherJob
+        checkForFailureMode = do
+          err <- readTMVar workerFailedVar
+          pure (UploadDispatcherReturnFailure err)
+
+        dispatchWorkMode :: STM UploadDispatcherJob
+        dispatchWorkMode = do
+          hashes <- readTVar hashesVar
+          when (Set.null hashes) retry
+          let (hashes1, hashes2) = Set.splitAt syncChunkSize hashes
+          modifyTVar' dedupeVar (Set.union hashes1)
+          writeTVar hashesVar hashes2
+          pure (UploadDispatcherForkWorkerWhenAvailable (NESet.unsafeFromSet hashes1))
+
+        forkWorkerMode :: NESet Hash32 -> STM UploadDispatcherJob
+        forkWorkerMode hashes = do
+          workers <- readTVar workersVar
+          when (Set.size workers >= maxSimultaneousPushWorkers) retry
+          pure (UploadDispatcherForkWorker hashes)
+
+        checkIfDoneMode :: STM UploadDispatcherJob
+        checkIfDoneMode = do
+          workers <- readTVar workersVar
+          when (not (Set.null workers)) retry
+          pure UploadDispatcherDone
+
+    worker ::
+      AuthenticatedHttpClient ->
+      (forall a. Sqlite.Transaction a -> IO a) ->
+      TVar (Set Hash32) ->
+      TVar (Set Hash32) ->
+      TVar (Set Int) ->
+      TMVar (SyncError Share.UploadEntitiesError) ->
+      Int ->
+      NESet Hash32 ->
+      IO ()
+    worker httpClient runTransaction hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do
+      entities <-
+        fmap NEMap.fromAscList do
+          runTransaction do
+            for (NESet.toAscList hashes) \hash -> do
+              entity <- expectEntity hash
+              pure (hash, entity)
+
+      result <-
+        httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest {entities, repoInfo} <&> \case
+          Left err -> Left (TransportError err)
+          Right response ->
+            case response of
+              Share.UploadEntitiesSuccess -> Right Set.empty
+              Share.UploadEntitiesFailure err ->
+                case err of
+                  Share.UploadEntitiesError'NeedDependencies (Share.NeedDependencies moreHashes) ->
+                    Right (NESet.toSet moreHashes)
+                  err -> Left (SyncError err)
+
+      case result of
+        Left err -> void (atomically (tryPutTMVar workerFailedVar err))
+        Right moreHashes -> do
+          uploadedCallback (NESet.size hashes)
+          maybeYoungestWorkerThatWasAlive <-
+            atomically do
+              -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from
+              -- the `dedupe` set, but whether or not we are "alive" is relevant only to:
+              --
+              --   - The main dispatcher thread, which terminates when there are no more hashes to upload, and no alive
+              --     workers. It is not important for us to delete from the `dedupe` set in this case.
+              --
+              --   - Other worker threads, each of which independently decides when it is safe to delete the set of
+              --     hashes they just uploaded from the `dedupe` set (as we are doing now).
+              !workers <- Set.delete workerId <$> readTVar workersVar
+              writeTVar workersVar workers
+              -- Add more work (i.e. hashes to upload) to the work queue (really a work set), per the response we just
+              -- got from the server. Remember to only add hashes that aren't in the `dedupe` set (see the comment on
+              -- the dedupe set above for more info).
+              when (not (Set.null moreHashes)) do
+                dedupe <- readTVar dedupeVar
+                hashes0 <- readTVar hashesVar
+                writeTVar hashesVar $! Set.union (Set.difference moreHashes dedupe) hashes0
+              pure (Set.lookupMax workers)
+          -- Block until we are sure that the server does not have any uncommitted transactions that see a version of
+          -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the
+          -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any
+          -- subsequent deduping operations. If we didn't delete from the `dedupe` set, this algorithm would still be
+          -- correct, it would just use an unbounded amount of memory to remember all the hashes we've uploaded so far.
+          whenJust maybeYoungestWorkerThatWasAlive \youngestWorkerThatWasAlive -> do
+            atomically do
+              workers <- readTVar workersVar
+              whenJust (Set.lookupMin workers) \oldestWorkerAlive ->
+                when (oldestWorkerAlive <= youngestWorkerThatWasAlive) retry
+          atomically (modifyTVar' dedupeVar (`Set.difference` (NESet.toSet hashes)))
+
+------------------------------------------------------------------------------------------------------------------------
+-- Database operations
+
+-- | "Elaborate" a set of `temp_entity` hashes.
+--
+-- For each hash, then we ought to instead download its missing dependencies (which themselves are
+--    elaborated by this same procedure, in case we have any of *them* already in temp storage, too.
+-- 3. If it's in main storage, we should ignore it.
+--
+-- In the end, we return a set of hashes that correspond to entities we actually need to download.
+elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (Set Share.HashJWT)
+elaborateHashes hashes =
+  Q.elaborateHashes (NESet.toList hashes) <&> Set.fromList . coerce @[Text] @[Share.HashJWT]
+
+-- | Upsert a downloaded entity "somewhere" -
+--
+--   1. Nowhere if we already had the entity (in main or temp storage).
+--   2. In main storage if we already have all of its dependencies in main storage.
+--   3. In temp storage otherwise.
+upsertEntitySomewhere ::
+  Hash32 ->
+  Share.Entity Text Hash32 Share.HashJWT ->
+  Sqlite.Transaction Q.EntityLocation
+upsertEntitySomewhere hash entity =
+  Q.entityLocation hash >>= \case
+    Just location -> pure location
+    Nothing -> do
+      missingDependencies1 :: Map Hash32 Share.HashJWT <-
+        Share.entityDependencies entity
+          & foldMapM
+            ( \hashJwt -> do
+                let hash = Share.hashJWTHash hashJwt
+                Q.entityExists hash <&> \case
+                  True -> Map.empty
+                  False -> Map.singleton hash hashJwt
+            )
+      case NEMap.nonEmptyMap missingDependencies1 of
+        Nothing -> do
+          _id <- Q.saveTempEntityInMain v2HashHandle hash (entityToTempEntity Share.hashJWTHash entity)
+          pure Q.EntityInMainStorage
+        Just missingDependencies -> do
+          Q.insertTempEntity
+            hash
+            (entityToTempEntity Share.hashJWTHash entity)
+            ( coerce
+                @(NEMap Hash32 Share.HashJWT)
+                @(NEMap Hash32 Text)
+                missingDependencies
+            )
+          pure Q.EntityInTempStorage
+
+------------------------------------------------------------------------------------------------------------------------
+-- HTTP calls
+
+httpGetCausalHashByPath ::
+  Auth.AuthenticatedHttpClient ->
+  BaseUrl ->
+  Share.GetCausalHashByPathRequest ->
+  IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse)
+httpDownloadEntities ::
+  Auth.AuthenticatedHttpClient ->
+  BaseUrl ->
+  Share.DownloadEntitiesRequest ->
+  IO (Either CodeserverTransportError Share.DownloadEntitiesResponse)
+httpUploadEntities ::
+  Auth.AuthenticatedHttpClient ->
+  BaseUrl ->
+  Share.UploadEntitiesRequest ->
+  IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
+( httpGetCausalHashByPath,
+  httpDownloadEntities,
+  httpUploadEntities
+  ) =
+    let ( httpGetCausalHashByPath
+            Servant.:<|> httpDownloadEntities
+            Servant.:<|> httpUploadEntities
+          ) =
+            let pp :: Proxy ("ucm" Servant.:> "v1" Servant.:> "sync" Servant.:> Share.API)
+                pp = Proxy
+             in Servant.hoistClient pp hoist (Servant.client pp)
+     in ( go httpGetCausalHashByPath,
+          go httpDownloadEntities,
+          go httpUploadEntities
+        )
+    where
+      hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) a
+      hoist m = do
+        clientEnv <- Reader.ask
+        liftIO (Servant.runClientM m clientEnv) >>= \case
+          Right a -> pure a
+          Left err -> do
+            Debug.debugLogM Debug.Sync (show err)
+            throwError case err of
+              Servant.FailureResponse _req resp ->
+                case HTTP.statusCode $ Servant.responseStatusCode resp of
+                  401 -> Unauthenticated (Servant.baseUrl clientEnv)
+                  -- The server should provide semantically relevant permission-denied messages
+                  -- when possible, but this should catch any we miss.
+                  403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp)
+                  408 -> Timeout
+                  429 -> RateLimitExceeded
+                  504 -> Timeout
+                  _ -> UnexpectedResponse resp
+              Servant.DecodeFailure msg resp -> DecodeFailure msg resp
+              Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp
+              Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp
+              Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv)
+
+      go ::
+        (req -> ReaderT Servant.ClientEnv (ExceptT CodeserverTransportError IO) resp) ->
+        Auth.AuthenticatedHttpClient ->
+        BaseUrl ->
+        req ->
+        IO (Either CodeserverTransportError resp)
+      go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req =
+        (Servant.mkClientEnv httpClient unisonShareUrl)
+          { Servant.makeClientRequest = \url request ->
+              -- Disable client-side timeouts
+              (Servant.defaultMakeClientRequest url request)
+                { Http.Client.responseTimeout = Http.Client.responseTimeoutNone
+                }
+          }
+          & runReaderT (f req)
+          & runExceptT

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,15 @@ module U.Codebase.Sqlite.Operations
     fuzzySearchDefinitions,
     namesPerspectiveForRootAndPath,
 
+    -- * Projects
+    expectProjectAndBranchNames,
+    expectProjectBranchHead,
+
     -- * reflog
     getReflog,
     appendReflog,
+    getProjectReflog,
+    appendProjectReflog,
 
     -- * low-level stuff
     expectDbBranch,
@@ -183,6 +185,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 +205,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 +238,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 :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
-loadCausalHashAtPath mayRootCausalHash =
+loadCausalHashAtPath rootCausalHash =
   let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
       go hashId = \case
         [] -> lift (Q.expectCausalHash hashId)
@@ -258,15 +251,13 @@ loadCausalHashAtPath mayRootCausalHash =
           (_, hashId') <- MaybeT (pure (Map.lookup tid children))
           go hashId' ts
    in \path -> do
-        hashId <- case mayRootCausalHash of
+        hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
-          Nothing -> Q.expectNamespaceRoot
-          Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
         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 :: CausalHash -> [NameSegment] -> Transaction CausalHash
-expectCausalHashAtPath mayRootCausalHash =
+expectCausalHashAtPath rootCausalHash =
   let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
       go hashId = \case
         [] -> Q.expectCausalHash hashId
@@ -276,23 +267,21 @@ expectCausalHashAtPath mayRootCausalHash =
           let (_, hashId') = children Map.! tid
           go hashId' ts
    in \path -> do
-        hashId <- case mayRootCausalHash of
+        hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
-          Nothing -> Q.expectNamespaceRoot
-          Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
         go hashId path
 
 loadCausalBranchAtPath ::
-  Maybe CausalHash ->
+  CausalHash ->
   [NameSegment] ->
   Transaction (Maybe (C.Branch.CausalBranch Transaction))
-loadCausalBranchAtPath maybeRootCausalHash path =
+loadCausalBranchAtPath rootCausalHash path =
-  loadCausalHashAtPath maybeRootCausalHash path >>= \case
+  loadCausalHashAtPath rootCausalHash path >>= \case
     Nothing -> pure Nothing
     Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
 
-loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
+loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
-loadBranchAtPath maybeRootCausalHash path =
+loadBranchAtPath rootCausalHash path =
-  loadCausalBranchAtPath maybeRootCausalHash path >>= \case
+  loadCausalBranchAtPath rootCausalHash path >>= \case
     Nothing -> pure Nothing
     Just causal -> Just <$> C.Causal.value causal
 
@@ -613,16 +602,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 +728,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
@@ -1520,6 +1496,17 @@ appendReflog entry = do
   dbEntry <- (bitraverse Q.saveCausalHash pure) entry
   Q.appendReflog dbEntry
 
+-- | Gets the specified number of reflog entries in chronological order, most recent first.
+getProjectReflog :: Int -> Transaction [ProjectReflog.Entry CausalHash]
+getProjectReflog numEntries = do
+  entries <- Q.getProjectReflog numEntries
+  (traverse . traverse) Q.expectCausalHash entries
+
+appendProjectReflog :: ProjectReflog.Entry CausalHash -> Transaction ()
+appendProjectReflog entry = do
+  dbEntry <- traverse Q.saveCausalHash entry
+  Q.appendProjectReflog dbEntry
+
 -- | Delete any name lookup that's not in the provided list.
 --
 -- This can be used to garbage collect unreachable name lookups.
@@ -1584,3 +1571,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,33 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module U.Codebase.Sqlite.ProjectReflog where
+
+import Data.Text (Text)
+import Data.Time (UTCTime)
+import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId)
+import Unison.Sqlite (FromRow (..), ToRow (..), field)
+
+data Entry causal = Entry
+  { project :: ProjectId,
+    branch :: ProjectBranchId,
+    time :: UTCTime,
+    fromRootCausalHash :: Maybe causal,
+    toRootCausalHash :: causal,
+    reason :: Text
+  }
+  deriving stock (Show, Functor, Foldable, Traversable)
+
+instance ToRow (Entry CausalHashId) where
+  toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) =
+    toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason)
+
+instance FromRow (Entry CausalHashId) where
+  fromRow = do
+    project <- field
+    branch <- field
+    time <- field
+    fromRootCausalHash <- field
+    toRootCausalHash <- field
+    reason <- field
+    pure $ Entry {..}

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,
 
@@ -217,6 +213,8 @@ module U.Codebase.Sqlite.Queries
     -- * Reflog
     appendReflog,
     getReflog,
+    appendProjectReflog,
+    getProjectReflog,
 
     -- * garbage collection
     garbageCollectObjectsWithoutHashes,
@@ -237,12 +235,12 @@ module U.Codebase.Sqlite.Queries
     -- * elaborate hashes
     elaborateHashes,
 
-    -- * most recent namespace
+    -- * current project path
-    expectMostRecentNamespace,
+    expectCurrentProjectPath,
-    setMostRecentNamespace,
+    setCurrentProjectPath,
 
     -- * migrations
-    createSchema,
+    runCreateSql,
     addTempEntityTables,
     addReflogTable,
     addNamespaceStatsTables,
@@ -254,6 +252,9 @@ module U.Codebase.Sqlite.Queries
     addSquashResultTable,
     addSquashResultTableIfNotExists,
     cdToProjectRoot,
+    addCurrentProjectPathTable,
+    addProjectBranchReflogTable,
+    addProjectBranchCausalHashIdColumn,
 
     -- ** schema version
     currentSchemaVersion,
@@ -315,6 +316,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 +369,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 +402,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 +418,11 @@ type TextPathSegments = [Text]
 -- * main squeeze
 
 currentSchemaVersion :: SchemaVersion
-currentSchemaVersion = 16
+currentSchemaVersion = 17
 
-createSchema :: Transaction ()
+runCreateSql :: Transaction ()
-createSchema = do
+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 +432,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 +471,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 +1339,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
@@ -3514,6 +3490,24 @@ getReflog numEntries =
       LIMIT :numEntries
     |]
 
+appendProjectReflog :: ProjectReflog.Entry CausalHashId -> Transaction ()
+appendProjectReflog entry =
+  execute
+    [sql|
+      INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason)
+      VALUES (@entry, @, @, @, @, @)
+    |]
+
+getProjectReflog :: Int -> Transaction [ProjectReflog.Entry CausalHashId]
+getProjectReflog numEntries =
+  queryListRow
+    [sql|
+      SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
+      FROM project_branch_reflog
+      ORDER BY time DESC
+      LIMIT :numEntries
+    |]
+
 -- | Does a project exist with this id?
 projectExists :: ProjectId -> Transaction Bool
 projectExists projectId =
@@ -3803,12 +3797,15 @@ loadProjectAndBranchNames projectId branchId =
     |]
 
 -- | Insert a project branch.
-insertProjectBranch :: ProjectBranch -> Transaction ()
+insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
-insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
+insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
+  -- Ensure we never point at a causal we don't have the branch for.
+  _ <- expectBranchObjectIdByCausalHashId causalHashId
+
   execute
     [sql|
-      INSERT INTO project_branch (project_id, branch_id, name)
+      INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
-        VALUES (:projectId, :branchId, :branchName)
+        VALUES (:projectId, :branchId, :branchName, :causalHashId)
     |]
   whenJust maybeParentBranchId \parentBranchId ->
     execute
@@ -3816,6 +3813,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
+  appendProjectReflog $
+    ProjectReflog.Entry
+      { project = projectId,
+        branch = branchId,
+        time,
+        fromRootCausalHash = Nothing,
+        toRootCausalHash = causalHashId,
+        reason = description
+      }
 
 -- | Rename a project branch.
 --
@@ -3888,6 +3895,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
+  appendProjectReflog $
+    ProjectReflog.Entry
+      { project = projectId,
+        branch = branchId,
+        time = time,
+        fromRootCausalHash = Just oldRootCausalHashId,
+        toRootCausalHash = causalHashId,
+        reason = description
+      }
+
+expectProjectBranchHead :: ProjectId -> ProjectBranchId -> Transaction CausalHashId
+expectProjectBranchHead projectId branchId =
+  queryOneCol
+    [sql|
+      SELECT causal_hash_id
+      FROM project_branch
+      WHERE project_id = :projectId AND branch_id = :branchId
+    |]
+
 data LoadRemoteBranchFlag
   = IncludeSelfRemote
   | ExcludeSelfRemote
@@ -4372,33 +4411,39 @@ data JsonParseFailure = JsonParseFailure
   deriving anyclass (SqliteExceptionReason)
 
 -- | Get the most recent namespace the user has visited.
-expectMostRecentNamespace :: Transaction [NameSegment]
+expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
-expectMostRecentNamespace =
+expectCurrentProjectPath =
-  queryOneColCheck
+  queryOneRowCheck
     [sql|
-      SELECT namespace
+      SELECT project_id, branch_id, path
-      FROM most_recent_namespace
+      FROM current_project_path
     |]
     check
   where
-    check :: Text -> Either JsonParseFailure [NameSegment]
+    check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
-    check bytes =
+    check (projId, branchId, pathText) =
-      case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
+      case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of
-        Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
+        Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure}
-        Right namespace -> Right (map NameSegment namespace)
+        Right namespace -> Right (projId, branchId, map NameSegment namespace)
 
 -- | Set the most recent namespace the user has visited.
-setMostRecentNamespace :: [NameSegment] -> Transaction ()
+setCurrentProjectPath ::
-setMostRecentNamespace namespace =
+  ProjectId ->
+  ProjectBranchId ->
+  [NameSegment] ->
+  Transaction ()
+setCurrentProjectPath projId branchId path = do
+  execute
+    [sql| DELETE FROM current_project_path |]
   execute
     [sql|
-      UPDATE most_recent_namespace
+      INSERT INTO current_project_path(project_id, branch_id, path)
-      SET namespace = :json
+      VALUES (:projId, :branchId, :jsonPath)
     |]
   where
-    json :: Text
+    jsonPath :: Text
-    json =
+    jsonPath =
-      Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace)
+      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,6 +27,7 @@ dependencies:
   - nonempty-containers
   - safe
   - text
+  - time
   - transformers
   - unison-codebase
   - unison-codebase-sync

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,26 @@
+CREATE TABLE project_branch_reflog (
+    project_id INTEGER NOT NULL,
+    project_branch_id INTEGER NOT NULL,
+    -- Reminder that SQLITE doesn't have any actual 'time' type,
+    -- This column contains TEXT values formatted as ISO8601 strings
+    -- ("YYYY-MM-DD HH:MM:SS.SSS")
+    time TEXT NOT NULL,
+    -- from_root_causal_id will be null if the branch was just created
+    from_root_causal_id INTEGER NULL REFERENCES causal(self_hash_id),
+    to_root_causal_id INTEGER NOT NULL REFERENCES causal(self_hash_id),
+    reason TEXT NOT NULL,
+
+    foreign key (project_id, 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
+);
+

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,6 +125,7 @@ library
     , nonempty-containers
     , safe
     , text
+    , time
     , transformers
     , unison-codebase
     , unison-codebase-sync

lib/unison-sqlite/src/Unison/Sqlite/Connection.hs

@@ -151,7 +151,7 @@ logQuery (Sql sql params) result =
 
 -- Without results
 
-execute :: Connection -> Sql -> IO ()
+execute :: HasCallStack => Connection -> Sql -> IO ()
 execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
   logQuery sql Nothing
   doExecute `catch` \(exception :: Sqlite.SQLError) ->
@@ -171,7 +171,7 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
 -- | Execute one or more semicolon-delimited statements.
 --
 -- This function does not support parameters, and is mostly useful for executing DDL and migrations.
-executeStatements :: Connection -> Text -> IO ()
+executeStatements :: HasCallStack => Connection -> Text -> IO ()
 executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do
   logQuery (Sql sql []) Nothing
   Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) ->
@@ -184,7 +184,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do
 
 -- With results, without checks
 
-queryStreamRow :: Sqlite.FromRow a => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r
+queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r
 queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
   run `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
@@ -201,7 +201,7 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
 
 queryStreamCol ::
   forall a r.
-  (Sqlite.FromField a) =>
+  (HasCallStack, Sqlite.FromField a) =>
   Connection ->
   Sql ->
   (IO (Maybe a) -> IO r) ->
@@ -212,7 +212,7 @@ queryStreamCol =
     @(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r)
     queryStreamRow
 
-queryListRow :: forall a. (Sqlite.FromRow a) => Connection -> Sql -> IO [a]
+queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a]
 queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
   result <-
     doQuery
@@ -237,35 +237,35 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
                 Just row -> loop (row : rows)
         loop []
 
-queryListCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a]
+queryListCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO [a]
 queryListCol =
   coerce @(Connection -> Sql -> IO [Sqlite.Only a]) @(Connection -> Sql -> IO [a]) queryListRow
 
-queryMaybeRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO (Maybe a)
+queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO (Maybe a)
 queryMaybeRow conn s =
   queryListRowCheck conn s \case
     [] -> Right Nothing
     [x] -> Right (Just x)
     xs -> Left (ExpectedAtMostOneRowException (anythingToString xs))
 
-queryMaybeCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO (Maybe a)
+queryMaybeCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO (Maybe a)
 queryMaybeCol conn s =
   coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow conn s)
 
-queryOneRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO a
+queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO a
 queryOneRow conn s =
   queryListRowCheck conn s \case
     [x] -> Right x
     xs -> Left (ExpectedExactlyOneRowException (anythingToString xs))
 
-queryOneCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO a
+queryOneCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO a
 queryOneCol conn s = do
   coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s)
 
 -- With results, with checks
 
 queryListRowCheck ::
-  (Sqlite.FromRow a, SqliteExceptionReason e) =>
+  (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   ([a] -> Either e r) ->
@@ -274,7 +274,7 @@ queryListRowCheck conn s check =
   gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check)
 
 gqueryListCheck ::
-  (Sqlite.FromRow a) =>
+  (Sqlite.FromRow a, HasCallStack) =>
   Connection ->
   Sql ->
   ([a] -> Either SomeSqliteExceptionReason r) ->
@@ -293,7 +293,7 @@ gqueryListCheck conn sql check = do
 
 queryListColCheck ::
   forall a e r.
-  (Sqlite.FromField a, SqliteExceptionReason e) =>
+  (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   ([a] -> Either e r) ->
@@ -302,7 +302,7 @@ queryListColCheck conn s check =
   queryListRowCheck conn s (coerce @([a] -> Either e r) @([Sqlite.Only a] -> Either e r) check)
 
 queryMaybeRowCheck ::
-  (Sqlite.FromRow a, SqliteExceptionReason e) =>
+  (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   (a -> Either e r) ->
@@ -315,7 +315,7 @@ queryMaybeRowCheck conn s check =
 
 queryMaybeColCheck ::
   forall a e r.
-  (Sqlite.FromField a, SqliteExceptionReason e) =>
+  (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   (a -> Either e r) ->
@@ -324,7 +324,7 @@ queryMaybeColCheck conn s check =
   queryMaybeRowCheck conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check)
 
 queryOneRowCheck ::
-  (Sqlite.FromRow a, SqliteExceptionReason e) =>
+  (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   (a -> Either e r) ->
@@ -336,7 +336,7 @@ queryOneRowCheck conn s check =
 
 queryOneColCheck ::
   forall a e r.
-  (Sqlite.FromField a, SqliteExceptionReason e) =>
+  (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
   Connection ->
   Sql ->
   (a -> Either e r) ->

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

other-thing.md

@@ -0,0 +1,6 @@
+```ucm
+.> clone @unison/cloud
+@unison/cloud/main> reset #t30tkb0hj1
+@unison/cloud/main> branch bug
+@unison/cloud/bug> delete.namespace lib.httpserver_4_1_0
+```

other-thing.output.md

@@ -0,0 +1,23 @@
+```ucm
+.> clone @unison/cloud
+
+  Downloaded 92354 entities.
+
+  Cloned @unison/cloud/main.
+
+@unison/cloud/main> reset #t30tkb0hj1
+
+  Done.
+
+@unison/cloud/main> branch bug
+
+  Done. I've created the bug branch based off of main.
+  
+  Tip: Use `merge /bug /main` to merge your work back into the
+       main branch.
+
+@unison/cloud/bug> delete.namespace lib.httpserver_4_1_0
+
+  Done.
+
+```

parser-typechecker/src/Unison/Codebase.hs

@@ -1,6 +1,10 @@
 module Unison.Codebase
   ( Codebase,
 
+    -- * UCM session state
+    expectCurrentProjectPath,
+    setCurrentProjectPath,
+
     -- * Terms
     getTerm,
     unsafeGetTerm,
@@ -43,18 +47,19 @@ module Unison.Codebase
     lca,
     SqliteCodebase.Operations.before,
     getShallowBranchAtPath,
+    getMaybeShallowBranchAtPath,
     getShallowCausalAtPath,
-    getBranchAtPath,
     Operations.expectCausalBranchByCausalHash,
-    getShallowCausalFromRoot,
+    getShallowCausalAtPathFromRootHash,
-    getShallowRootBranch,
+    getShallowProjectBranchRoot,
-    getShallowRootCausal,
+    expectShallowProjectBranchRoot,
+    getShallowBranchAtProjectPath,
+    getMaybeShallowBranchAtProjectPath,
+    getShallowProjectRootByNames,
+    expectProjectBranchRoot,
+    getBranchAtProjectPath,
 
     -- * Root branch
-    getRootBranch,
-    SqliteCodebase.Operations.getRootBranchExists,
-    Operations.expectRootCausalHash,
-    putRootBranch,
     SqliteCodebase.Operations.namesAtPath,
 
     -- * Patches
@@ -103,16 +108,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 +130,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 +144,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 +175,105 @@ runTransactionWithRollback ::
 runTransactionWithRollback Codebase {withConnection} action =
   withConnection \conn -> Sqlite.runTransactionWithRollback conn action
 
-getShallowCausalFromRoot ::
+getShallowCausalAtPathFromRootHash ::
-  -- Optional root branch, if Nothing use the codebase's root branch.
+  -- Causal to start at, if Nothing use the codebase's root branch.
-  Maybe CausalHash ->
+  CausalHash ->
   Path.Path ->
   Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-getShallowCausalFromRoot mayRootHash p = do
+getShallowCausalAtPathFromRootHash rootCausalHash p = do
-  rootCausal <- case mayRootHash of
+  rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
-    Nothing -> getShallowRootCausal
+  getShallowCausalAtPath p rootCausal
-    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
 
 -- | 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
+getShallowCausalAtPath path causal = do
-  causal <- whenNothing mayCausal getShallowRootCausal
   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
+getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch
-  branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
+
+-- | 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.
+-- | Recursively descend into causals following the given path,
-getBranchAtPath ::
+-- 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 ->
+  PP.ProjectPath ->
-  m (Branch m)
+  m (Maybe (Branch m))
-getBranchAtPath codebase path = do
+getBranchAtProjectPath codebase pp = runMaybeT do
-  V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing
+  rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId
-  expectBranchForHash codebase causalHash
+  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 +391,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.dataDecls tl)
-            <|> Map.lookup r (TL.typeOfTerms tl) $> ()
+            $> ()
-            <|> Map.lookup r (TL.effectDecls 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 +556,15 @@ 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))

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

@@ -26,6 +26,7 @@ import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
 import Unison.HashQualified' (HashQualified (HashQualified, NameOnly))
+import Unison.NameSegment (NameSegment)
 import Unison.Names (Names)
 import Unison.Names qualified as Names
 import Unison.Prelude
@@ -69,10 +70,10 @@ getBranch (p, seg) b = case Path.toList p of
     (Branch.head <$> Map.lookup h (b ^. Branch.children))
       >>= getBranch (Path.fromList p, seg)
 
-makeAddTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m)
+makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
 makeAddTermName (p, name) r = (p, Branch.addTermName r name)
 
-makeDeleteTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m)
+makeDeleteTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
 makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name)
 
 makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
@@ -81,10 +82,10 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name)
 makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
 makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name)
 
-makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
+makeAddTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
 makeAddTypeName (p, name) r = (p, Branch.addTypeName r name)
 
-makeDeleteTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
+makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
 makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name)
 
 makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)

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 :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text
-printWriteRemoteNamespace = \case
+printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
-  WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
-    displayShareCodeserver server repo path
-  WriteRemoteProjectBranch 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.Except
-import Control.Monad.IO.Class (liftIO)
+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
+    (project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do
-    let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
+      project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project))
-        loadTypeOfTerm = Codebase.getTypeOfTerm codebase
+      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
+    AbsolutePath' abs -> Text.unpack $ absToText abs
-    RelativePath' rel -> show rel
+    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) =
+    into @Text (ProjectAndBranch proj branch) <> ":" <> Path.absToText path
+
+instance From (ProjectPathG () ProjectBranchName) Text where
+  from (ProjectPath () branch path) =
+    "/" <> into @Text branch <> ":" <> Path.absToText path
+
+type ProjectPath = ProjectPathG Project ProjectBranch
+
+projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath
+projectBranchRoot (ProjectAndBranch proj branch) = ProjectPath proj branch Path.absoluteEmpty
+
+-- | Discard any path within the project and get the project's root
+toRoot :: ProjectPath -> ProjectPath
+toRoot (ProjectPath proj branch _) = ProjectPath proj branch Path.absoluteEmpty
+
+fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath
+fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path
+
+-- | Project a project context into a project path of just IDs
+toIds :: ProjectPath -> ProjectPathIds
+toIds (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path
+
+-- | Project a project context into a project path of just names
+toNames :: ProjectPath -> ProjectPathNames
+toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path
+
+toProjectAndBranch :: ProjectPathG p b -> ProjectAndBranch p b
+toProjectAndBranch (ProjectPath proj branch _) = ProjectAndBranch proj branch
+
+instance Bifunctor ProjectPathG where
+  bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path
+
+instance Bifoldable ProjectPathG where
+  bifoldMap f g (ProjectPath p b _) = f p <> g b
+
+instance Bitraversable ProjectPathG where
+  bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path
+
+toText :: ProjectPathG Project ProjectBranch -> Text
+toText (ProjectPath proj branch path) =
+  into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path
+
+absPath_ :: Lens' (ProjectPathG p b) Path.Absolute
+absPath_ = lens absPath set
+  where
+    set (ProjectPath n b _) p = ProjectPath n b p
+
+path :: (ProjectPathG p b) -> Path.Path
+path (ProjectPath _ _ p) = Path.unabsolute p
+
+path_ :: Lens' (ProjectPathG p b) Path.Path
+path_ = absPath_ . Path.absPath_
+
+projectAndBranch_ :: Lens (ProjectPathG p b) (ProjectPathG p' b') (ProjectAndBranch p b) (ProjectAndBranch p' b')
+projectAndBranch_ = lens go set
+  where
+    go (ProjectPath proj branch _) = ProjectAndBranch proj branch
+    set (ProjectPath _ _ p) (ProjectAndBranch proj branch) = ProjectPath proj branch p
+
+type Parser = Megaparsec.Parsec Void Text
+
+projectPathParser :: Parser ProjectPathNames
+projectPathParser = do
+  (projName, hasTrailingSlash) <- Project.projectNameParser
+  projBranchName <- Project.projectBranchNameParser (not hasTrailingSlash)
+  _ <- Megaparsec.char ':'
+  path' >>= \case
+    Path.AbsolutePath' p -> pure $ ProjectPath projName projBranchName p
+    Path.RelativePath' {} -> fail "Expected an absolute path"
+  where
+    path' :: Parser Path.Path'
+    path' = do
+      pathStr <- Megaparsec.takeRest
+      case Path.parsePath' (Text.unpack pathStr) of
+        Left err -> fail (Text.unpack err)
+        Right x -> pure x
+
+parseProjectPath :: Text -> Either Text ProjectPathNames
+parseProjectPath txt = first (Text.pack . Megaparsec.errorBundlePretty) $ Megaparsec.parse projectPathParser "" txt

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/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
@@ -106,8 +101,7 @@ createCodebaseOrError onCreate debugName path lockOption action = do
       withConnection (debugName ++ ".createSchema") path \conn -> do
         Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
         Sqlite.runTransaction conn do
-          Q.createSchema
+          CodebaseOps.createSchema
-          void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
           onCreate
 
       sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case
@@ -136,7 +130,7 @@ initSchemaIfNotExist path = liftIO do
     createDirectoryIfMissing True (makeCodebaseDirPath path)
   unlessM (doesFileExist $ makeCodebasePath path) $
     withConnection "initSchemaIfNotExist" path \conn ->
-      Sqlite.runTransaction conn Q.createSchema
+      Sqlite.runTransaction conn CodebaseOps.createSchema
 
 -- 1) buffer up the component
 -- 2) in the event that the component is complete, then what?
@@ -167,7 +161,6 @@ sqliteCodebase ::
   (Codebase m Symbol Ann -> m r) ->
   m (Either Codebase1.OpenCodebaseError r)
 sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do
-  rootBranchCache <- newEmptyRootBranchCacheIO
   branchCache <- newBranchCache
   getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
   -- The v1 codebase interface has operations to read and write individual definitions
@@ -238,37 +231,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
             putTypeDeclarationComponent =
               CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer
 
-            getRootBranch :: m (Branch m)
-            getRootBranch =
-              Branch.transform runTransaction
-                <$> fetchRootBranch
-                  rootBranchCache
-                  (runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType))
-
-            putRootBranch :: Text -> Branch m -> m ()
-            putRootBranch reason branch1 = do
-              now <- liftIO getCurrentTime
-              withRunInIO \runInIO -> do
-                -- this is naughty, the type says Transaction but it
-                -- won't run automatically with whatever Transaction
-                -- it is composed into unless the enclosing
-                -- Transaction is applied to the same db connection.
-                let branch1Trans = Branch.transform (Sqlite.unsafeIO . runInIO) branch1
-                    putRootBranchTrans :: Sqlite.Transaction () = do
-                      let emptyCausalHash = Branch.headHash Branch.empty
-                      fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash
-                      let toRootCausalHash = Branch.headHash branch1
-                      CodebaseOps.putRootBranch branch1Trans
-                      Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason})
-
-                -- We need to update the database and the cached
-                -- value. We want to keep these in sync, so we take
-                -- the cache lock while updating sqlite.
-                withLock
-                  rootBranchCache
-                  (\restore _ -> restore $ runInIO $ runTransaction putRootBranchTrans)
-                  (\_ -> Just branch1Trans)
-
             -- if this blows up on cromulent hashes, then switch from `hashToHashId`
             -- to one that returns Maybe.
             getBranchForHash :: CausalHash -> m (Maybe (Branch m))
@@ -334,8 +296,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
                   putTypeDeclaration,
                   putTypeDeclarationComponent,
                   getTermComponentWithTypes,
-                  getRootBranch,
-                  putRootBranch,
                   getBranchForHash,
                   putBranch,
                   syncFromDirectory,

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 ())
+  Map SchemaVersion (Sqlite.Connection -> IO ())
-migrations getDeclType termBuffer declBuffer rootCodebasePath =
+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),
+      (6, runT $ migrateSchema5To6 rootCodebasePath),
-      (7, migrateSchema6To7),
+      (7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)),
-      (8, migrateSchema7To8),
+      (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
+        \conn -> Sqlite.runWriteTransaction conn \run -> run
-          Q.expectSchemaVersion (ver - 1)
+          do
-          migration
+            Q.expectSchemaVersion (ver - 1)
-          Q.setSchemaVersion ver
+            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 <-
+        ranMigrations <- do
-          Sqlite.runWriteTransaction conn \run -> do
+          currentSchemaVersion <- Sqlite.runTransaction conn $ do
             -- Get the schema version again now that we're in a transaction.
-            currentSchemaVersion <- run Q.schemaVersion
+            Q.schemaVersion
-            let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
             -- 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 < 5) Q.addTempEntityTables
-            when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables
+            when (currentSchemaVersion < 6) Q.addNamespaceStatsTables
-            for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
+            pure currentSchemaVersion
-              putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
+          let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
-              run migration
+          for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
-            let ranMigrations = not (null migrationsToRun)
+            putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
-            when ranMigrations do
+            migration conn
-              region <-
+          let ranMigrations = not (null migrationsToRun)
-                UnliftIO.mask_ do
+          pure ranMigrations
-                  region <- Region.openConsoleRegion Region.Linear
+        Debug.debugLogM Debug.Migration "Migrations complete"
-                  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 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,221 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where
+
+import Control.Lens
+import Data.Map qualified as Map
+import Data.Text qualified as Text
+import Data.UUID (UUID)
+import Data.UUID qualified as UUID
+import U.Codebase.Branch.Type qualified as V2Branch
+import U.Codebase.Causal qualified as V2Causal
+import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId (..), ProjectId (..))
+import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
+import U.Codebase.Sqlite.Queries qualified as Q
+import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Branch qualified as Branch
+import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.SqliteCodebase.Branch.Cache qualified as BranchCache
+import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
+import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
+import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName))
+import Unison.Debug qualified as Debug
+import Unison.NameSegment (NameSegment)
+import Unison.NameSegment.Internal (NameSegment (NameSegment))
+import Unison.NameSegment.Internal qualified as NameSegment
+import Unison.Prelude
+import Unison.Sqlite qualified as Sqlite
+import Unison.Sqlite.Connection qualified as Connection
+import Unison.Syntax.NameSegment qualified as NameSegment
+import UnliftIO qualified
+import UnliftIO qualified as UnsafeIO
+
+-- | This migration converts the codebase from having all projects in a single codebase root to having separate causal
+-- roots for each project branch.
+-- It:
+-- * adds a new table to the schema, `currentProjectPath`, and sets it to contain the path to the scratch project.
+-- * Adds the causal_hash_id column to the project_branch table.
+--
+-- It requires a Connection argument rather than working inside a Transaction because it needs to temporarily disable
+-- foreign key checking, and the foreign_key pragma cannot be set within a transaction.
+migrateSchema16To17 :: Sqlite.Connection -> IO ()
+migrateSchema16To17 conn = withDisabledForeignKeys $ do
+  Q.expectSchemaVersion 16
+  Q.addProjectBranchReflogTable
+  Debug.debugLogM Debug.Migration "Adding causal hashes to project branches table."
+  addCausalHashesToProjectBranches
+  Debug.debugLogM Debug.Migration "Making legacy project from loose code."
+  makeLegacyProjectFromLooseCode
+  Debug.debugLogM Debug.Migration "Adding scratch project"
+  scratchMain <-
+    Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case
+      Just pb -> pure pb
+      Nothing -> do
+        (_, emptyCausalHashId) <- Codebase.emptyCausalHash
+        (_proj, pb) <- Ops.insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
+        pure pb
+  Debug.debugLogM Debug.Migration "Adding current project path table"
+  Q.addCurrentProjectPathTable
+  Debug.debugLogM Debug.Migration "Setting current project path to scratch project"
+  Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId []
+  Debug.debugLogM Debug.Migration "Done migrating to version 17"
+  Q.setSchemaVersion 17
+  where
+    scratchProjectName = UnsafeProjectName "scratch"
+    scratchBranchName = UnsafeProjectBranchName "main"
+    withDisabledForeignKeys :: Sqlite.Transaction r -> IO r
+    withDisabledForeignKeys m = do
+      let disable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=OFF |]
+      let enable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=ON |]
+      let action = Sqlite.runWriteTransaction conn \run -> run $ m
+      UnsafeIO.bracket disable (const enable) (const action)
+
+data ForeignKeyFailureException
+  = ForeignKeyFailureException
+      -- We leave the data as raw as possible to ensure we can display it properly rather than get decoding errors while
+      -- trying to display some other error.
+      [[Sqlite.SQLData]]
+  | MissingRootBranch
+  deriving stock (Show)
+  deriving anyclass (Exception)
+
+addCausalHashesToProjectBranches :: Sqlite.Transaction ()
+addCausalHashesToProjectBranches = do
+  Debug.debugLogM Debug.Migration "Creating new_project_branch"
+  -- Create the new version of the project_branch table with the causal_hash_id column.
+  Sqlite.execute
+    [Sqlite.sql|
+CREATE TABLE new_project_branch (
+  project_id uuid NOT NULL REFERENCES project (id),
+  branch_id uuid NOT NULL,
+  name text NOT NULL,
+  causal_hash_id integer NOT NULL REFERENCES causal(self_hash_id),
+
+  primary key (project_id, branch_id),
+
+  unique (project_id, name)
+)
+without rowid;
+|]
+  rootCausalHashId <- expectNamespaceRoot
+  rootCh <- Q.expectCausalHash rootCausalHashId
+  projectsRoot <- Codebase.getShallowCausalAtPathFromRootHash rootCh (Path.singleton $ projectsNameSegment) >>= V2Causal.value
+  ifor_ (V2Branch.children projectsRoot) \projectIdNS projectsCausal -> do
+    projectId <- case projectIdNS of
+      UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID
+      _ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS
+    Debug.debugM Debug.Migration "Migrating project" projectId
+    projectsBranch <- V2Causal.value projectsCausal
+    case (Map.lookup branchesNameSegment $ V2Branch.children projectsBranch) of
+      Nothing -> pure ()
+      Just branchesCausal -> do
+        branchesBranch <- V2Causal.value branchesCausal
+        ifor_ (V2Branch.children branchesBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do
+          projectBranchId <- case branchIdNS of
+            UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID
+            _ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS
+          Debug.debugM Debug.Migration "Migrating project branch" projectBranchId
+          let branchCausalHash = V2Causal.causalHash projectBranchCausal
+          causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash
+          branchName <-
+            MaybeT $
+              Sqlite.queryMaybeCol @ProjectBranchName
+                [Sqlite.sql|
+                  SELECT project_branch.name
+                  FROM project_branch
+                  WHERE
+                    project_branch.project_id = :projectId
+                    AND project_branch.branch_id = :projectBranchId
+                |]
+          -- Insert the full project branch with HEAD into the new table
+          lift $
+            Sqlite.execute
+              [Sqlite.sql|
+              INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id)
+                VALUES (:projectId, :projectBranchId, :branchName, :causalHashId)
+            |]
+
+  Debug.debugLogM Debug.Migration "Deleting orphaned project branch data"
+  -- Delete any project branch data that don't have a matching branch in the current root.
+  -- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite
+  -- foreign key references.
+  -- We have to do this manually since we had to disable foreign key checks to add the new column.
+  Sqlite.execute
+    [Sqlite.sql| DELETE FROM project_branch_parent AS pbp
+      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id)
+    |]
+  Debug.debugLogM Debug.Migration "Deleting orphaned remote mapping data"
+  Sqlite.execute
+    [Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp
+      WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id)
+    |]
+  Sqlite.execute [Sqlite.sql| DELETE FROM most_recent_branch |]
+
+  Debug.debugLogM Debug.Migration "Swapping old and new project branch tables"
+  -- Drop the old project_branch table and rename the new one to take its place.
+  Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |]
+  Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |]
+  Debug.debugLogM Debug.Migration "Checking foreign keys"
+  foreignKeyErrs <- Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |]
+  when (not . null $ foreignKeyErrs) . Sqlite.unsafeIO . UnliftIO.throwIO $ ForeignKeyFailureException foreignKeyErrs
+
+makeLegacyProjectFromLooseCode :: Sqlite.Transaction ()
+makeLegacyProjectFromLooseCode = do
+  rootChId <-
+    Sqlite.queryOneCol @CausalHashId
+      [Sqlite.sql|
+    SELECT causal_id
+    FROM namespace_root
+  |]
+  rootCh <- Q.expectCausalHash rootChId
+  branchCache <- Sqlite.unsafeIO BranchCache.newBranchCache
+  getDeclType <- Sqlite.unsafeIO $ CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
+  rootBranch <-
+    CodebaseOps.getBranchForHash branchCache getDeclType rootCh `whenNothingM` do
+      Sqlite.unsafeIO . UnliftIO.throwIO $ MissingRootBranch
+  -- Remove the hidden projects root if one existed.
+  let rootWithoutProjects = rootBranch & over (Branch.head_ . Branch.children) (Map.delete projectsNameSegment)
+  CodebaseOps.putBranch rootWithoutProjects
+  let legacyBranchRootHash = Branch.headHash rootWithoutProjects
+  legacyBranchRootHashId <- Q.expectCausalHashIdByCausalHash legacyBranchRootHash
+
+  let findLegacyName :: Maybe Int -> Sqlite.Transaction ProjectName
+      findLegacyName mayN = do
+        let tryProjName = case mayN of
+              Nothing -> UnsafeProjectName "legacy"
+              Just n -> UnsafeProjectName $ "legacy" <> Text.pack (show n)
+        Q.loadProjectBranchByNames tryProjName legacyBranchName >>= \case
+          Nothing -> pure tryProjName
+          Just _ -> findLegacyName . Just $ maybe 1 succ mayN
+  legacyProjName <- findLegacyName Nothing
+  void $ Ops.insertProjectAndBranch legacyProjName legacyBranchName legacyBranchRootHashId
+  pure ()
+  where
+    legacyBranchName = UnsafeProjectBranchName "main"
+
+expectNamespaceRoot :: Sqlite.Transaction CausalHashId
+expectNamespaceRoot =
+  Sqlite.queryOneCol loadNamespaceRootSql
+
+loadNamespaceRootSql :: Sqlite.Sql
+loadNamespaceRootSql =
+  [Sqlite.sql|
+    SELECT causal_id
+    FROM namespace_root
+  |]
+
+pattern UUIDNameSegment :: UUID -> NameSegment
+pattern UUIDNameSegment uuid <-
+  ( NameSegment.toUnescapedText ->
+      (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid))
+    )
+  where
+    UUIDNameSegment uuid =
+      NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid)))
+
+projectsNameSegment :: NameSegment
+projectsNameSegment = NameSegment.unsafeParseText "__projects"
+
+branchesNameSegment :: NameSegment
+branchesNameSegment = NameSegment.unsafeParseText "branches"

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/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 ()
+-- | 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 projectId projectName branchId branchName = do
+insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch)
-  Q.insertProject projectId projectName
+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
+    "Project Created"
-      { projectId,
+    chId
-        branchId,
+    projectBranch
-        name = branchName,
-        parentBranchId = Nothing
-      }
   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.

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))) ->
+  (ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
-  [NameSegment] ->
+  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/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

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
+      -- Starting project
-      (Maybe Path.Absolute)
+      (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)
+startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-startingPathOption =
+startingProjectOption =
   let meta =
-        metavar ".path.in.codebase"
+        metavar "project/branch"
-          <> long "path"
+          <> 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,28 +48,32 @@ module Unison.Cli.Monad
     runTransaction,
     runTransactionWithRollback,
 
+    -- * Internal
+    setMostRecentProjectPath,
+    setInMemoryCurrentProjectRoot,
+
     -- * 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.DbId (ProjectBranchId, ProjectId)
-import U.Codebase.Sqlite.Queries qualified as Queries
+import U.Codebase.Sqlite.Queries qualified as Q
 import Unison.Auth.CredentialManager (CredentialManager)
 import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
 import Unison.Codebase (Codebase)
@@ -77,7 +83,9 @@ 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
@@ -178,10 +186,9 @@ data Env = Env
 --
 -- There's an additional pseudo @"currentPath"@ field lens, for convenience.
 data LoopState = LoopState
-  { root :: TMVar (Branch IO),
+  { currentProjectRoot :: TMVar (Branch IO),
-    lastSavedRootHash :: CausalHash,
+    -- the current position in the codebase, with the head being the most recent lcoation.
-    -- the current position in the namespace
+    projectPathStack :: List.NonEmpty PP.ProjectPathIds,
-    currentPathStack :: List.NonEmpty Path.Absolute,
     -- TBD
     -- , _activeEdits :: Set Branch.EditGuid
 
@@ -206,26 +213,12 @@ data LoopState = LoopState
   }
   deriving stock (Generic)
 
-instance
-  {-# OVERLAPS #-}
-  (Functor f) =>
-  IsLabel "currentPath" ((Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState))
-  where
-  fromLabel :: (Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState)
-  fromLabel =
-    lens
-      (\LoopState {currentPathStack} -> List.NonEmpty.head currentPathStack)
-      ( \loopState@LoopState {currentPathStack = _ List.NonEmpty.:| paths} path ->
-          loopState {currentPathStack = path List.NonEmpty.:| paths}
-      )
-
 -- | Create an initial loop state given a root branch and the current path.
-loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
+loopState0 :: TMVar (Branch IO) -> PP.ProjectPathIds -> LoopState
-loopState0 lastSavedRootHash b p = do
+loopState0 b p = do
   LoopState
-    { root = b,
+    { currentProjectRoot = b,
-      lastSavedRootHash = lastSavedRootHash,
+      projectPathStack = pure p,
-      currentPathStack = pure p,
       latestFile = Nothing,
       latestTypecheckedFile = Nothing,
       lastInput = Nothing,
@@ -387,11 +380,33 @@ 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
+  pp <- getProjectPathIds
-  State.modify' \state ->
+  let newPP = pp & PP.absPath_ .~ path
-    state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)}
+  setMostRecentProjectPath newPP
+  #projectPathStack %= NonEmpty.cons newPP
+
+-- | Set the in-memory project root to the given branch, without updating the database.
+setInMemoryCurrentProjectRoot :: Branch IO -> Cli ()
+setInMemoryCurrentProjectRoot !newRoot = do
+  rootVar <- use #currentProjectRoot
+  atomically do
+    void $ swapTMVar rootVar newRoot
+
+switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
+switchProject (ProjectAndBranch projectId branchId) = do
+  Env {codebase} <- ask
+  let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty
+  #projectPathStack %= NonEmpty.cons newPP
+  runTransaction $ do Q.setMostRecentBranch projectId branchId
+  pbr <- liftIO $ Codebase.expectProjectBranchRoot codebase projectId branchId
+  setInMemoryCurrentProjectRoot pbr
+  setMostRecentProjectPath newPP
 
 -- | Pop the latest path off the stack, if it's not the only path in the stack.
 --
@@ -399,16 +414,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)
+      setMostRecentProjectPath (List.NonEmpty.head paths)
-      State.put state {currentPathStack = paths}
+      State.put state {projectPathStack = paths}
       pure True
 
-setMostRecentNamespace :: Path.Absolute -> Cli ()
+setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
-setMostRecentNamespace =
+setMostRecentProjectPath loc =
-  runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute
+  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,
+    getCurrentProjectRoot,
-    setRootBranch,
+    getCurrentProjectRoot0,
-    modifyRootBranch,
-    getRootBranch0,
     getCurrentBranch,
     getCurrentBranch0,
-    getBranchAt,
+    getProjectBranchRoot,
-    getBranch0At,
+    getBranchFromProjectPath,
-    getLastSavedRootHash,
+    getBranch0FromProjectPath,
-    setLastSavedRootHash,
+    getMaybeBranchFromProjectPath,
-    getMaybeBranchAt,
+    getMaybeBranch0FromProjectPath,
-    getMaybeBranch0At,
     expectBranchAtPath,
     expectBranchAtPath',
     expectBranch0AtPath,
@@ -43,13 +48,10 @@ module Unison.Cli.MonadUtils
     stepAt',
     stepAt,
     stepAtM,
-    stepAtNoSync',
-    stepAtNoSync,
     stepManyAt,
-    stepManyAtMNoSync,
+    stepManyAtM,
-    stepManyAtNoSync,
+    updateProjectBranchRoot,
-    syncRoot,
+    updateProjectBranchRoot_,
-    updateRoot,
     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
@@ -137,25 +145,55 @@ getConfig key = do
 ------------------------------------------------------------------------------------------------------------------------
 -- Getting paths, path resolution, etc.
 
--- | Get the current path.
+getCurrentProjectPath :: Cli PP.ProjectPath
+getCurrentProjectPath = do
+  (PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds
+  -- TODO: Reset to a valid project on error.
+  (proj, branch) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do
+    project <- MaybeT $ Q.loadProject projId
+    branch <- MaybeT $ Q.loadProjectBranch projId branchId
+    pure (project, branch)
+  pure (PP.ProjectPath proj branch path)
+
+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
+  pp <- getCurrentProjectPath
-  pure (Path.resolve currentPath (Path.Relative path))
+  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' -> Cli PP.ProjectPath
-resolvePath' path = do
+resolvePath' path' = do
-  currentPath <- getCurrentPath
+  pp <- getCurrentProjectPath
-  pure (Path.resolve currentPath path)
+  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 +204,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
+  Input.BranchAtSCH hash -> resolveShortCausalHash hash
-  Right path -> getBranchAt path
+  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
+resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case
-  Left shortHash -> do
+  Input.BranchAtSCH shortHash -> do
     hash <- resolveShortCausalHashToCausalHash rollback shortHash
-    succeed (Codebase.expectCausalBranchByCausalHash hash)
+    causal <- (Codebase.expectCausalBranchByCausalHash hash)
-  Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
+    V2Causal.value causal
-  where
+  Input.BranchAtPath absPath -> do
-    succeed getCausal = do
+    let pp = PP.ProjectPath proj branch absPath
-      causal <- getCausal
+    Codebase.getShallowBranchAtProjectPath pp
-      V2Causal.value causal
+  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 +236,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 +264,52 @@ resolveShortCausalHashToCausalHash rollback shortHash = do
 -- Getting/Setting branches
 
 -- | Get the root branch.
-getRootBranch :: Cli (Branch IO)
+getCurrentProjectRoot :: Cli (Branch IO)
-getRootBranch = do
+getCurrentProjectRoot = do
-  use #root >>= atomically . readTMVar
+  use #currentProjectRoot >>= atomically . readTMVar
 
 -- | Get the root branch0.
-getRootBranch0 :: Cli (Branch0 IO)
+getCurrentProjectRoot0 :: Cli (Branch0 IO)
-getRootBranch0 =
+getCurrentProjectRoot0 =
-  Branch.head <$> getRootBranch
+  Branch.head <$> getCurrentProjectRoot
-
--- | 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
 
 -- | 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.
+-- | Get the branch at an absolute path from the project root.
-getLastSavedRootHash :: Cli CausalHash
+getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO)
-getLastSavedRootHash = do
+getBranchFromProjectPath pp =
-  use #lastSavedRootHash
+  getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty
-
--- | 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 branch0 at an absolute path.
-getBranch0At :: Path.Absolute -> Cli (Branch0 IO)
+getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO)
-getBranch0At path =
+getBranch0FromProjectPath pp =
-  Branch.head <$> getBranchAt path
+  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))
+getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO))
-getMaybeBranchAt path = do
+getMaybeBranchFromProjectPath pp = do
-  rootBranch <- getRootBranch
+  Cli.Env {codebase} <- ask
-  pure (Branch.getAt (Path.unabsolute path) rootBranch)
+  liftIO $ Codebase.getBranchAtProjectPath codebase pp
 
 -- | Get the maybe-branch0 at an absolute path.
-getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO))
+getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO))
-getMaybeBranch0At path =
+getMaybeBranch0FromProjectPath pp =
-  fmap Branch.head <$> getMaybeBranchAt path
+  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 +320,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 +346,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 <- Codebase.getShallowBranchAtProjectPath pp
-    branch <- V2Causal.value causal
     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
+stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)]
-
-stepAtNoSync' ::
-  (Path, Branch0 IO -> Cli (Branch0 IO)) ->
-  Cli Bool
-stepAtNoSync' = stepManyAtNoSync' @[] . pure
-
-stepAtNoSync ::
-  (Path, Branch0 IO -> Branch0 IO) ->
-  Cli ()
-stepAtNoSync = stepManyAtNoSync @[] . pure
 
 stepAtM ::
   Text ->
-  (Path, Branch0 IO -> IO (Branch0 IO)) ->
+  (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
+stepManyAt pb reason actions = do
-  stepManyAtNoSync actions
+  updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions)
-  syncRoot reason
 
 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
+stepManyAt' pb reason actions = do
-  res <- stepManyAtNoSync' actions
+  origRoot <- getProjectBranchRoot pb
-  syncRoot reason
+  newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot
-  pure res
+  didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot))
-
+  pure didChange
-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)
 
 -- 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
+stepManyAtM pb reason actions = do
-  stepManyAtMNoSync actions
+  updateProjectBranchRoot pb reason \oldRoot -> do
-  syncRoot reason
+    newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot)
-
+    pure (newRoot, ())
-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
 
 -- | 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
+updateAtM reason pp f = do
-  b <- getRootBranch
+  oldRootBranch <- getProjectBranchRoot (pp ^. #branch)
-  b' <- Branch.modifyAtM p f b
+  newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch
-  updateRoot b' reason
+  updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch)
-  pure $ b /= b'
+  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
+updateAt reason pp f = do
-  updateAtM reason p (pure . f)
+  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
+updateAndStepAt reason projectBranch updates steps = do
-  root <-
+  let f b =
-    (Branch.stepManyAt steps)
+        b
-      . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
+          & (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
-      <$> getRootBranch
+          & (Branch.stepManyAt (first Path.unabsolute <$> steps))
-  updateRoot root reason
+  updateProjectBranchRoot_ projectBranch reason f
 
-updateRoot :: Branch IO -> Text -> Cli ()
+updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r
-updateRoot new reason =
+updateProjectBranchRoot projectBranch reason f = do
-  Cli.time "updateRoot" do
+  currentPB <- getCurrentProjectBranch
-    Cli.Env {codebase} <- ask
+  Cli.Env {codebase} <- ask
-    let newHash = Branch.headHash new
+  Cli.time "updateProjectBranchRoot" do
-    oldHash <- getLastSavedRootHash
+    old <- getProjectBranchRoot projectBranch
-    when (oldHash /= newHash) do
+    (new, result) <- f old
-      liftIO (Codebase.putRootBranch codebase reason new)
+    liftIO $ Codebase.putBranch codebase new
-      setRootBranch new
+    Cli.runTransaction $ do
-      setLastSavedRootHash newHash
+      causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new)
+      Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId
+    if projectBranch.branchId == currentPB.branchId
+      then Cli.setInMemoryCurrentProjectRoot new
+      else pure ()
+    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 :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent)
-getTermsAt path = do
+getTermsAt (pp, hqSeg) = do
-  rootBranch0 <- getRootBranch0
+  rootBranch0 <- getBranch0FromProjectPath pp
-  pure (BranchUtil.getTerm (first Path.unabsolute path) rootBranch0)
+  pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0)
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Getting types
 
-getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference)
+getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference)
-getTypesAt path = do
+getTypesAt (pp, hqSeg) = do
-  rootBranch0 <- getRootBranch0
+  rootBranch0 <- getBranch0FromProjectPath pp
-  pure (BranchUtil.getType (first Path.unabsolute path) rootBranch0)
+  pure (BranchUtil.getType (mempty, hqSeg) rootBranch0)
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Getting patches
@@ -507,8 +495,8 @@ getPatchAt path =
 -- | Get the patch at a path.
 getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch)
 getMaybePatchAt path0 = do
-  (path, name) <- resolveSplit' path0
+  (pp, name) <- resolveSplit' path0
-  branch <- getBranch0At path
+  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
+  Input.BranchAtSCH sch -> prettySCH sch
-  Right absPath -> prettyAbsolute $ absPath
+  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.Codebase.ProjectPath qualified as PP
-import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
+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
+resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath
-branchRelativePathToAbsolute brp =
+resolveBranchRelativePath brp = do
-  resolveBranchRelativePath brp <&> \case
+  case brp of
-    BranchRelativePath.ResolvedLoosePath p -> p
+    BranchPathInCurrentProject projBranchName path -> do
-    BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
+      projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
-      let projectBranchIds = getIds projectBranch
+      pure $ PP.fromProjectAndBranch projectAndBranch path
-          handleRel = case mRel of
+    QualifiedBranchPath projName projBranchName path -> do
-            Nothing -> id
+      projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
-            Just rel -> flip Path.resolve rel
+      pure $ PP.fromProjectAndBranch projectAndBranch path
-       in handleRel (projectBranchPath projectBranchIds)
+    UnqualifiedPath newPath' -> do
-  where
+      pp <- Cli.getCurrentProjectPath
-    getIds = \case
+      pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
-      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
 
 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
+    pp <- Cli.getCurrentProjectPath
-    pure (ProjectAndBranch (project ^. #name) branchName)
+    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
+    (PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
-    branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName))
+    branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
-    pure (ProjectAndBranch project branch)
+    pure (ProjectAndBranch proj branch)
-  These projectName branchName ->
+  These projectName branchName -> do
-    Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName))
+    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.
+--   1. If the project is missing, use the provided project.
---   2. If we have an unambiguous `loose.code.path`, just return it.
+--   2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
---   3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*,
+--      project, defaulting to 'main' if branch is unspecified.
---      we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash).
+resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
-expectLooseCodeOrProjectBranch ::
+resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
-  These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ->
+  let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
-  Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
+  let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
-expectLooseCodeOrProjectBranch =
+  projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
-  _Right expectProjectAndBranchByTheseNames . f
+  pure projectAndBranch
-  where
+
-    f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName)
+-- | Expect/resolve branch reference with the following rules:
-    f = \case
+--
-      This path -> Left path
+--   1. If the project is missing, use the current project.
-      That (ProjectAndBranch Nothing branch) -> Right (That branch)
+--   2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
-      That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
+--      project, defaulting to 'main' if branch is unspecified.
-      These path _ -> Left path -- (3) above
+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 :: ProjectBranch -> Transaction CausalHash
-getProjectBranchCausalHash branch = do
+getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do
-  let path = projectBranchPath branch
+  causalHashId <- Q.expectProjectBranchHead projectId branchId
-  causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
+  Q.expectCausalHash causalHashId
-  pure causal.causalHash
 
 ------------------------------------------------------------------------------------------------------------------------
 -- 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 :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text)
-loadUniqueTypeGuid currentPath name0 = do
+loadUniqueTypeGuid pp name0 = do
-  -- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path
+  let (namePath, finalSegment) = Path.splitFromName name0
-  -- to the unique type, plus its final distinguished name segment.
+  let fullPP = pp & over PP.path_ (<> namePath)
-  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
 
   -- 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))
+  let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
-      loadBranchAtPath = Operations.loadBranchAtPath Nothing
+      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
@@ -93,7 +91,6 @@ import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
 import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2)
 import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
 import Unison.Codebase.Editor.Input
-import Unison.Codebase.Editor.Input qualified as Input
 import Unison.Codebase.Editor.Output
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN
@@ -105,9 +102,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
@@ -132,12 +130,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)
@@ -251,83 +245,17 @@ loop e = do
             ResetI newRoot mtarget -> do
               newRoot <-
                 case newRoot of
-                  This newRoot -> case newRoot of
+                  BranchAtPath p -> do
-                    Left hash -> Cli.resolveShortCausalHash hash
+                    pp <- Cli.resolvePath' p
-                    Right path' -> Cli.expectBranchAtPath' path'
+                    Cli.getBranchFromProjectPath pp
-                  That (ProjectAndBranch mProjectName branchName) -> do
+                  BranchAtSCH sch -> Cli.resolveShortCausalHash sch
-                    let arg = case mProjectName of
+                  BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
-                          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)
-
               target <-
                 case mtarget of
-                  Nothing -> Cli.getCurrentPath
+                  Nothing -> Cli.getCurrentProjectPath
-                  Just looseCodeOrProject -> case looseCodeOrProject of
+                  Just unresolvedProjectAndBranch -> do
-                    This path' -> Cli.resolvePath' path'
+                    targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch)
-                    That (ProjectAndBranch mProjectName branchName) -> do
+                    pure $ PP.projectBranchRoot targetProjectAndBranch
-                      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)))
               description <- inputDescription input
               _ <- Cli.updateAt description target (const newRoot)
               Cli.respond Success
@@ -335,22 +263,23 @@ loop e = do
               Cli.time "reset-root" do
                 newRoot <-
                   case src0 of
-                    Left hash -> Cli.resolveShortCausalHash hash
+                    BranchAtSCH hash -> Cli.resolveShortCausalHash hash
-                    Right path' -> Cli.expectBranchAtPath' path'
+                    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'
+                    srcPP <- ProjectUtils.resolveBranchRelativePath path'
-                    let srcp = Path.AbsolutePath' absPath
+                    srcb <- Cli.getBranchFromProjectPath srcPP
-                    srcb <- Cli.expectBranchAtPath' srcp
+                    pure (srcb, WhichBranchEmptyPath srcPP)
-                    pure (srcb, WhichBranchEmptyPath srcp)
               description <- inputDescription input
-              dest <- ProjectUtils.branchRelativePathToAbsolute dest0
+              dest <- ProjectUtils.resolveBranchRelativePath dest0
               ok <- Cli.updateAtM description dest (const $ pure srcb)
               Cli.respond
                 if ok
@@ -358,54 +287,57 @@ 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
+              srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
-              dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
+              (destPP, destBRP) <- case mayUnresolvedDest of
-              let srcp = looseCodeOrProjectToPath src0
+                Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_))
-              let destp = looseCodeOrProjectToPath dest0
+                Just unresolvedDest -> do
-              srcb <- Cli.expectBranchAtPath' srcp
+                  ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest)
-              dest <- Cli.resolvePath' destp
+              srcBranch <- Cli.getProjectBranchRoot srcPP.branch
-              let err =
+              let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP
-                    Just $
+              mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP
-                      MergeAlreadyUpToDate
+            PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do
-                        ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
-                        ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
-              mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
-            PreviewMergeLocalBranchI src0 dest0 -> do
               Cli.Env {codebase} <- ask
-              src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
+              srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
-              dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
+              destPP <- case mayUnresolvedDest of
-              srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0
+                Nothing -> Cli.getCurrentProjectPath
-              dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0
+                Just unresolvedDest -> do
-              destb <- Cli.getBranchAt dest
+                  ProjectUtils.resolveBranchRelativePath unresolvedDest
-              merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
+              srcBranch <- Cli.getProjectBranchRoot srcPP.branch
-              if merged == destb
+              destBranch <- Cli.getProjectBranchRoot destPP.branch
-                then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0)
+              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)
+                  (ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged)
-                  Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff)
+                  Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff)
             DiffNamespaceI before after -> do
-              absBefore <- traverseOf _Right Cli.resolvePath' before
+              beforeLoc <- case before of
-              absAfter <- traverseOf _Right Cli.resolvePath' after
+                BranchAtSCH sch -> pure $ Left sch
-              beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore
+                BranchAtPath path' -> Right <$> Cli.resolvePath' path'
-              afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter
+                BranchAtProjectPath pp -> pure $ Right pp
+              afterLoc <- case after of
+                BranchAtSCH sch -> pure $ Left sch
+                BranchAtPath path' -> Right <$> Cli.resolvePath' path'
+                BranchAtProjectPath pp -> pure $ Right pp
+              beforeBranch0 <- Branch.head <$> Cli.resolveBranchId before
+              afterBranch0 <- Branch.head <$> Cli.resolveBranchId after
               case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
-                (True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
+                (True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc])
-                (True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [])
+                (True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [])
-                (False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| [])
+                (False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| [])
                 (False, False) -> pure ()
               (ppe, diff) <- diffHelper beforeBranch0 afterBranch0
-              Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
+              Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff)
             MoveBranchI src' dest' -> do
-              hasConfirmed <- confirmedCommand input
               description <- inputDescription input
-              doMoveBranch description hasConfirmed src' dest'
+              doMoveBranch description src' dest'
             SwitchBranchI path' -> do
               path <- Cli.resolvePath' path'
               branchExists <- Cli.branchExistsAtPath' path'
-              when (not branchExists) (Cli.respond $ CreatedNewBranch path)
+              when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_))
-              Cli.cd path
+              Cli.cd (path ^. PP.absPath_)
             UpI -> do
               path0 <- Cli.getCurrentPath
               whenJust (unsnoc path0) \(path, _) ->
@@ -416,10 +348,11 @@ loop e = do
             HistoryI resultsCap diffCap from -> do
               branch <-
                 case from of
-                  Left hash -> Cli.resolveShortCausalHash hash
+                  BranchAtSCH hash -> Cli.resolveShortCausalHash hash
-                  Right path' -> do
+                  BranchAtPath path' -> do
-                    path <- Cli.resolvePath' path'
+                    pp <- Cli.resolvePath' path'
-                    Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch 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 +370,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 +378,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 +398,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'
+              projPath <- ProjectUtils.resolveBranchRelativePath namespacePath'
-              branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
+              branch <- Cli.getBranchFromProjectPath projPath
               _evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
               pure ()
             AliasTermI force src' dest' -> do
@@ -490,7 +424,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 +447,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'
+              destPP <- Cli.resolvePath' dest'
-              old <- Cli.getBranch0At destAbs
+              old <- Cli.getBranch0FromProjectPath destPP
               description <- inputDescription input
-              let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs
+              let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs
-              Cli.stepManyAt description actions
+              Cli.stepManyAt destPP.branch description actions
-              new <- Cli.getBranch0At destAbs
+              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 +471,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 :: Path.HQSplitAbsolute
-                      hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc
+                      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 +510,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
+                    error "TODO: Implement names.global."
-                    -- 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)
                   else do
                     names <- Cli.currentNames
                     pped <- Cli.prettyPrintEnvDeclFromNames names
@@ -613,11 +543,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 PP.absPath authorPath) (d authorRef),
-                  BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
+                  BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef),
-                  BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
+                  BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef)
                 ]
               currentPath <- Cli.getCurrentPath
               finalBranch <- Cli.getCurrentBranch0
@@ -637,51 +569,47 @@ loop e = do
             MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input
             MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input
             MoveAllI src' dest' -> do
-              hasConfirmed <- confirmedCommand input
               desc <- inputDescription input
-              handleMoveAll hasConfirmed src' dest' desc
+              handleMoveAll src' dest' desc
-            DeleteI dtarget -> case dtarget of
+            DeleteI dtarget -> do
-              DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
+              pp <- Cli.getCurrentProjectPath
-              DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
+              let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg)
-              DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
+              let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg)
-              DeleteTarget'Namespace insistence Nothing -> do
+              case dtarget of
-                hasConfirmed <- confirmedCommand input
+                DeleteTarget'TermOrType doutput hqs -> do
-                if hasConfirmed || insistence == Force
+                  delete input doutput getTerms getTypes hqs
-                  then do
+                DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs
-                    description <- inputDescription input
+                DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs
-                    Cli.updateRoot Branch.empty description
+                DeleteTarget'Namespace insistence p@(parentPath, childName) -> do
-                    Cli.respond DeletedEverything
+                  branch <- Cli.expectBranchAtPath (Path.unsplit p)
-                  else Cli.respond DeleteEverythingConfirmation
+                  description <- inputDescription input
-              DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
+                  let toDelete =
-                branch <- Cli.expectBranchAtPath (Path.unsplit p)
+                        Names.prefix0
-                description <- inputDescription input
+                          (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
-                let toDelete =
+                          (Branch.toNames (Branch.head branch))
-                      Names.prefix0
+                  afterDelete <- do
-                        (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
+                    names <- Cli.currentNames
-                        (Branch.toNames (Branch.head branch))
+                    endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
-                afterDelete <- do
+                    case (null endangerments, insistence) of
-                  names <- Cli.currentNames
+                      (True, _) -> pure (Cli.respond Success)
-                  endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
+                      (False, Force) -> do
-                  case (null endangerments, insistence) of
+                        ppeDecl <- Cli.currentPrettyPrintEnvDecl
-                    (True, _) -> pure (Cli.respond Success)
+                        pure do
-                    (False, Force) -> do
+                          Cli.respond Success
-                      ppeDecl <- Cli.currentPrettyPrintEnvDecl
+                          Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
-                      pure do
+                      (False, Try) -> do
-                        Cli.respond Success
+                        ppeDecl <- Cli.currentPrettyPrintEnvDecl
-                        Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
+                        Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
-                    (False, Try) -> do
+                        Cli.returnEarlyWithoutOutput
-                      ppeDecl <- Cli.currentPrettyPrintEnvDecl
+                  parentPathAbs <- Cli.resolvePath parentPath
-                      Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
+                  -- We have to modify the parent in order to also wipe out the history at the
-                      Cli.returnEarlyWithoutOutput
+                  -- child.
-                parentPathAbs <- Cli.resolvePath parentPath
+                  Cli.updateAt description parentPathAbs \parentBranch ->
-                -- We have to modify the parent in order to also wipe out the history at the
+                    parentBranch
-                -- child.
+                      & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
-                Cli.updateAt description parentPathAbs \parentBranch ->
+                  afterDelete
-                  parentBranch
+                DeleteTarget'ProjectBranch name -> handleDeleteBranch name
-                    & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
+                DeleteTarget'Project name -> handleDeleteProject name
-                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 +625,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 +683,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 +711,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 +734,19 @@ loop e = do
               Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
             DebugTabCompletionI inputs -> do
               Cli.Env {authHTTPClient, codebase} <- ask
-              currentPath <- Cli.getCurrentPath
+              pp <- Cli.getCurrentProjectPath
-              let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
+              let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp
               (_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
               Cli.respond (DisplayDebugCompletions completions)
             DebugFuzzyOptionsI command args -> do
               Cli.Env {codebase} <- ask
-              currentPath <- Cli.getCurrentPath
               currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0
-              let projCtx = projectContextFromPath currentPath
               case Map.lookup command InputPatterns.patternMap of
                 Just (IP.InputPattern {args = argTypes}) -> do
                   zip argTypes args & Monoid.foldMapM \case
                     ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do
-                      results <- liftIO $ getOptions codebase projCtx currentBranch
+                      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 +816,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
+              projectRoot <- Cli.getCurrentProjectRoot
-              void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
+              void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot]
             DebugDumpNamespaceSimpleI -> do
-              rootBranch0 <- Cli.getRootBranch0
+              projectRootBranch0 <- Cli.getCurrentProjectRoot0
-              for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) ->
+              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 +862,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
@@ -954,8 +882,8 @@ inputDescription input =
       dest <- brp dest0
       pure ("fork " <> src <> " " <> dest)
     MergeLocalBranchI src0 dest0 mode -> do
-      src <- looseCodeOrProjectToText src0
+      let src = into @Text src0
-      dest <- looseCodeOrProjectToText dest0
+      let dest = maybe "" (into @Text) dest0
       let command =
             case mode of
               Branch.RegularMerge -> "merge"
@@ -963,17 +891,17 @@ inputDescription input =
       pure (command <> " " <> src <> " " <> dest)
     ResetI hash tgt -> do
       hashTxt <- case hash of
-        This hash -> hp' hash
+        BranchAtSCH hash -> hp' $ Left hash
-        That pr -> pure (into @Text pr)
+        BranchAtPath pr -> pure $ into @Text pr
-        These hash _pr -> hp' hash
+        BranchAtProjectPath pp -> pure $ into @Text pp
       tgt <- case tgt of
         Nothing -> pure ""
         Just tgt -> do
-          tgt <- looseCodeOrProjectToText tgt
+          let tgtText = into @Text tgt
-          pure (" " <> 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
@@ -1024,10 +952,10 @@ inputDescription input =
           thing <- traverse hqs' thing0
           pure ("delete.type.verbose " <> Text.intercalate " " thing)
         DeleteTarget'Namespace Try opath0 -> do
-          opath <- ops opath0
+          opath <- ps opath0
           pure ("delete.namespace " <> opath)
         DeleteTarget'Namespace Force opath0 -> do
-          opath <- ops opath0
+          opath <- ps opath0
           pure ("delete.namespace.force " <> opath)
         DeleteTarget'ProjectBranch _ -> wat
         DeleteTarget'Project _ -> wat
@@ -1129,9 +1057,7 @@ inputDescription input =
     p' :: Path' -> Cli Text
     p' = fmap tShow . 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"
     hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
     hhqs' = \case
@@ -1144,12 +1070,6 @@ 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)
 
 handleFindI ::
   Bool ->
@@ -1162,7 +1082,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 +1090,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
+      -- TODO: Rewrite to be properly global again
-      pped <- Cli.prettyPrintEnvDeclFromNames globalNames
+      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 +1237,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
@@ -1410,11 +1331,6 @@ doDisplay outputLoc names tm = do
         else do
           writeUtf8 filePath txt
 
-confirmedCommand :: Input -> Cli Bool
-confirmedCommand i = do
-  loopState <- State.get
-  pure $ Just i == (loopState ^. #lastInput)
-
 -- return `name` and `name.<everything>...`
 _searchBranchPrefix :: Branch m -> Name -> [SearchResult]
 _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
@@ -1527,8 +1443,8 @@ delete input doutput getTerms getTypes hqs' = do
     traverse
       ( \hq -> do
           absolute <- Cli.resolveSplit' hq
-          types <- getTypes absolute
+          types <- getTypes (first PP.absPath absolute)
-          terms <- getTerms absolute
+          terms <- getTerms (first PP.absPath absolute)
           return (hq, types, terms)
       )
       hqs'
@@ -1547,25 +1463,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
+        (pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
-        resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
+        let resolvedSplit = (pp.absPath, ns)
         return
-          ( resolvedPath,
+          (resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3)
-            Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
+
-            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
+  projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0
-  -- global root!
-  rootNames <- Branch.toNames <$> Cli.getRootBranch0
   -- get only once for the entire deletion set
   let allTermsToDelete :: Set LabeledDependency
       allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
@@ -1574,7 +1485,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 +1500,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 +1510,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 +1571,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
@@ -1770,15 +1682,3 @@ addWatch watchName (Just uf) = do
                 (UF.watchComponents uf <> [(WK.RegularWatch, [(v2, ann, Term.var a v, ty)])])
             )
     _ -> addWatch watchName Nothing
-
-looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path'
-looseCodeOrProjectToPath = \case
-  Left pth -> pth
-  Right (ProjectAndBranch prj br) ->
-    Path.absoluteToPath'
-      ( ProjectUtils.projectBranchPath
-          ( ProjectAndBranch
-              (prj ^. #projectId)
-              (br ^. #branchId)
-          )
-      )

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 (..),
-    CreateFrom (..),
+    handleBranch,
-    doCreateBranch,
+    createBranch,
-    doCreateBranch',
   )
 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'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
-  | CreateFrom'LooseCode Path.Absolute
+  | 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
+handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do
-  projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <-
-    case projectAndBranchNames0 of
-      ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName)
-      ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName)
-
   -- 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,80 @@ 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 ->
+      Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
-        ProjectUtils.getCurrentProjectBranch >>= \case
+      Input.BranchSourceI'Empty -> pure Nothing
-          Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath
+      Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
-          Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch)
+        pp <- Cli.getCurrentProjectPath
-      Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness
+        Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
-      Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do
-        currentPath <- Cli.getCurrentPath
-        pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath))
-      Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) ->
-        fmap CreateFrom'Branch do
-          ProjectUtils.expectProjectAndBranchByTheseNames
-            case sourceBranch of
-              ProjectAndBranch Nothing b -> That b
-              ProjectAndBranch (Just p) b -> These p b
-      -- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a
-      -- branch from a relative one-segment namespace.
-      --
-      -- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they
-      -- really meant create a branch from that namespace.
-      Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) ->
-        fmap CreateFrom'Branch do
-          ProjectUtils.expectProjectAndBranchByTheseNames
-            case sourceBranch of
-              ProjectAndBranch Nothing b -> That b
-              ProjectAndBranch (Just p) b -> These p b
 
-  project <-
+  case maySrcProjectAndBranch of
-    Cli.runTransactionWithRollback \rollback -> do
+    Just srcProjectAndBranch -> do
-      Queries.loadProjectByName projectName & onNothingM do
+      let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name))
-        -- We can't make the *first* branch of a project with `branch`; the project has to already exist.
+      void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName)
-        rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
+    Nothing -> do
-
+      let description = "Empty branch created"
-  _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
+      void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName)
 
   Cli.respond $
     Output.CreatedProjectBranch
-      ( case createFrom of
+      ( case maySrcProjectAndBranch of
-          CreateFrom'Branch sourceBranch ->
+          Just sourceBranch ->
-            if sourceBranch ^. #project . #projectId == project ^. #projectId
+            if sourceBranch ^. #project . #projectId == destProject ^. #projectId
               then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
               else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
-          CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path
+          Nothing -> Output.CreatedProjectBranchFrom'Nothingness
-          CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness
       )
-      projectAndBranchNames
+      (projectAndBranchNames & #project .~ projectName)
 
--- | @doCreateBranch createFrom project branch description@:
+-- | @createBranchFromParent createFrom project branch description@:
 --
---   1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@)
+--   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. Switches to the new branch.
---   3. cds to the new branch in the root namespace.
 --
 -- 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
+createBranch ::
-doCreateBranch createFrom project newBranchName description = do
+  Text ->
-  sourceNamespaceObject <-
+  CreateFrom ->
-    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 ->
   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
+      Q.expectProjectBranchHead projectId (parentBranch ^. #branchId)
+      newBranchCausalHashId <- Q.expectProjectBranchHead projectId (parentBranch ^. #branchId)
+      pure (Just (parentBranch ^. #branchId), newBranchCausalHashId)
+    CreateFrom'Nothingness -> Cli.runTransaction do
+      (_, causalHashId) <- Codebase.emptyCausalHash
+      pure (Nothing, causalHashId)
+    CreateFrom'NamespaceWithParent parentBranch namespace -> do
+      liftIO $ Codebase.putBranch codebase namespace
+      Cli.runTransaction $ do
+        newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash namespace)
+        pure (Just (parentBranch ^. #branchId), newBranchCausalHashId)
+    CreateFrom'Namespace branch -> do
+      liftIO $ Codebase.putBranch codebase branch
+      Cli.runTransaction $ do
+        newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch)
+        pure (Nothing, newBranchCausalHashId)
+  (newBranchName, newBranchId) <-
     Cli.runTransactionWithRollback \rollback -> do
       newBranchName <- getNewBranchName
       Queries.projectBranchExistsByName projectId newBranchName >>= \case
@@ -146,16 +131,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 (newBranchName, newBranchId)
-          pure (newBranchId, newBranchName)
 
-  let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
+  Cli.switchProject (ProjectAndBranch projectId newBranchId)
-  _ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
-  Cli.cd newBranchPath
   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)
+            pure (pp ^. #project)
-            Queries.expectProject projectId
       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/DeleteBranch.hs

@@ -5,8 +5,7 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch
   )
 where
 
-import Data.Map.Strict qualified as Map
+import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
-import Data.These (These (..))
 import U.Codebase.Sqlite.Project qualified as Sqlite
 import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
 import U.Codebase.Sqlite.Queries qualified as Queries
@@ -14,10 +13,11 @@ import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
 import Unison.Cli.ProjectUtils qualified as ProjectUtils
-import Unison.Codebase.Branch qualified as Branch
+import Unison.Codebase.Editor.HandleInput.ProjectCreate
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPathG (..))
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
+import Unison.Sqlite qualified as Sqlite
 import Witch (unsafeFrom)
 
 -- | Delete a project branch.
@@ -27,44 +27,50 @@ import Witch (unsafeFrom)
 -- project.
 handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
 handleDeleteBranch projectAndBranchNamesToDelete = do
-  projectAndBranchToDelete <-
+  ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath
-    ProjectUtils.expectProjectAndBranchByTheseNames
+  projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just)
-      case projectAndBranchNamesToDelete of
-        ProjectAndBranch Nothing branch -> That branch
-        ProjectAndBranch (Just project) branch -> These project branch
-
-  maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
-
-  doDeleteProjectBranch projectAndBranchToDelete
 
   -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
   --
   --   1. cd to parent branch, if it exists
   --   2. cd to "main", if it exists
-  --   3. cd to loose code path `.`
+  --   3. Any other branch in the codebase
-  whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
+  --   4. Create a dummy project and go to /main
-    when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
+  when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do
-      newPath <-
+    mayNextLocation <-
-        case projectAndBranchToDelete.branch.parentBranchId of
+      Cli.runTransaction . runMaybeT $
-          Nothing ->
+        asum
-            let loadMain =
+          [ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId),
-                  Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
+            findMainBranchInProject (currentProject ^. #projectId),
-             in Cli.runTransaction loadMain <&> \case
+            findAnyBranchInProject (currentProject ^. #projectId),
-                  Nothing -> Path.Absolute Path.empty
+            findAnyBranchInCodebase,
-                  Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
+            createDummyProject
-          Just parentBranchId ->
+          ]
-            pure $
+    nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing
-              ProjectUtils.projectBranchPath
+    Cli.switchProject nextLoc
-                (ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
+  doDeleteProjectBranch projectAndBranchToDelete
-      Cli.cd newPath
+  where
+    parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
+    parentBranch projectId mayParentBranchId = do
+      parentBranchId <- hoistMaybe mayParentBranchId
+      pure (ProjectAndBranch projectId parentBranchId)
+    findMainBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
+    findMainBranchInProject projectId = do
+      branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")
+      pure (ProjectAndBranch projectId (branch ^. #branchId))
+
+    findAnyBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
+    findAnyBranchInProject projectId = do
+      (someBranchId, _) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing
+      pure (ProjectAndBranch projectId someBranchId)
+    findAnyBranchInCodebase :: MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
+    findAnyBranchInCodebase = do
+      (_, pbIds) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchNamePairs
+      pure pbIds
+    createDummyProject = error "TODO: create new branch or project if we  delete the last branch you're on."
 
 -- | Delete a project branch and record an entry in the reflog.
 doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
 doDeleteProjectBranch projectAndBranch = do
   Cli.runTransaction do
     Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId
-  Cli.stepAt
-    ("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch))
-    ( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId),
-      over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId))
-    )

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

@@ -9,17 +9,16 @@ import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
-import Unison.Cli.ProjectUtils qualified as ProjectUtils
+import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
-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 (ProjectPathG (..))
 import Unison.Prelude
-import Unison.Project (ProjectAndBranch (..), ProjectName)
+import Unison.Project (ProjectName)
 
 -- | Delete a project
 handleDeleteProject :: ProjectName -> Cli ()
 handleDeleteProject projectName = do
-  maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
+  ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath
 
   deletedProject <-
     Cli.runTransactionWithRollback \rollback -> do
@@ -29,14 +28,8 @@ handleDeleteProject projectName = do
       Queries.deleteProject (project ^. #projectId)
       pure project
 
-  let projectId = deletedProject ^. #projectId
+  -- If the user is on the project that they're deleting, we create a new project to switch
-
+  -- to.
-  Cli.updateAt
+  when (((==) `on` (view #projectId)) deletedProject currentProject) do
-    ("delete.project " <> into @Text projectName)
+    nextLoc <- projectCreate False Nothing
-    (ProjectUtils.projectPath projectId)
+    Cli.switchProject nextLoc
-    (const Branch.empty)
-
-  -- If the user is on the project that they're deleting, we cd to the root path
-  whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) ->
-    when (on (==) (view #projectId) deletedProject currentProject) do
-      Cli.cd (Path.Absolute Path.empty)

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 =
+      libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment]
-        Path.resolve
-          currentProjectBranchPath
-          (Path.Relative (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/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
-
+  pp <- Cli.resolvePath' pathArg
-  pathArgAbs <- Cli.resolvePath' pathArg
+  projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch
-  entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
+  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

@@ -65,6 +65,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 +87,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 +141,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 +196,6 @@ doMerge info = do
           then realDebugFunctions
           else fakeDebugFunctions
 
-  let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch)
   let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
   let mergeSource = MergeSourceOrTarget'Source info.bob.source
   let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
@@ -210,7 +212,7 @@ doMerge info = do
       -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
       when (info.lca.causalHash == Just info.alice.causalHash) do
         bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
-        _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
+        _ <- Cli.updateAt info.description (PP.projectBranchRoot info.alice.projectAndBranch) (\_aliceBranch -> bobBranch)
         done (Output.MergeSuccessFastForward mergeSourceAndTarget)
 
       -- Create a bunch of cached database lookup functions
@@ -397,7 +399,7 @@ doMerge info = do
          in if thisMergeHasConflicts
               then pure Nothing
               else do
-                currentPath <- Cli.getCurrentPath
+                currentPath <- Cli.getCurrentProjectPath
                 parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
                 prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
 
@@ -408,12 +410,12 @@ doMerge info = do
         Nothing -> do
           Cli.Env {writeSource} <- ask
           (_temporaryBranchId, temporaryBranchName) <-
-            HandleInput.Branch.doCreateBranch'
+            HandleInput.Branch.createBranch
-              (Branch.mergeNode stageOneBranch parents.alice parents.bob)
+              info.description
-              (Just info.alice.projectAndBranch.branch.branchId)
+              (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.updateProjectBranchRoot_
-            Cli.updateAt
+            info.alice.projectAndBranch.branch
-              info.description
+            info.description
-              alicePath
+            (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
-              (\_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)
+      aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch)
-      bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
+      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)

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

@@ -11,9 +11,9 @@ import Unison.Codebase.Path qualified as Path
 import Unison.HashQualified' qualified as HQ'
 import Unison.Prelude
 
-handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli ()
+handleMoveAll :: Path.Path' -> Path.Path' -> Text -> Cli ()
-handleMoveAll hasConfirmed src' dest' description = do
+handleMoveAll src' dest' description = do
-  moveBranchFunc <- moveBranchFunc hasConfirmed src' dest'
+  moveBranchFunc <- moveBranchFunc src' dest'
   moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
     Nothing -> pure []
     Just (fmap HQ'.NameOnly -> src, dest) -> do
@@ -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,18 @@ import Unison.Codebase.Branch (Branch)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Editor.Output (Output (..))
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Prelude
 
-moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
+-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if
-moveBranchFunc hasConfirmed src' dest' = do
+-- needed.
-  srcAbs <- Cli.resolvePath' src'
+moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
-  destAbs <- Cli.resolvePath' dest'
+moveBranchFunc src' dest' = do
+  -- We currently only support moving within the same project branch.
+  srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src'
+  PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest'
   destBranchExists <- Cli.branchExistsAtPath' dest'
-  let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
+  Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do
-  when (isRootMove && not hasConfirmed) do
-    Cli.returnEarly MoveRootBranchConfirmation
-  Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
     -- We want the move to appear as a single step in the root namespace, but we need to make
     -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
     -- those changes such that they appear as a single change in the root.
@@ -26,17 +27,18 @@ moveBranchFunc hasConfirmed src' dest' = do
           changeRoot
             & Branch.modifyAt srcLoc (const Branch.empty)
             & Branch.modifyAt destLoc (const srcBranch)
-    if (destBranchExists && not isRootMove)
+    if destBranchExists
       then Cli.respond (MovedOverExistingBranch dest')
       else pure ()
     pure (Path.Absolute changeRootPath, doMove)
 
 -- | Moves a branch and its history from one location to another, and saves the new root
 -- branch.
-doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
+doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli ()
-doMoveBranch actionDescription hasConfirmed src' dest' = do
+doMoveBranch actionDescription src' dest' = do
-  moveBranchFunc hasConfirmed src' dest' >>= \case
+  moveBranchFunc src' dest' >>= \case
     Nothing -> Cli.respond (BranchNotFound src')
-    Just (path, func) -> do
+    Just (absPath, func) -> do
-      _ <- Cli.updateAt actionDescription path func
+      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.HashQualified' qualified as HQ'
 import Unison.NameSegment (NameSegment)
 import Unison.Prelude
 
-moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
+moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)]
 moveTermSteps src' dest' = do
   src <- Cli.resolveSplit' src'
   srcTerms <- Cli.getTermsAt src
@@ -29,11 +30,11 @@ moveTermSteps src' dest' = do
       destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
       when (not (Set.null destTerms)) do
         Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
-      let p = first Path.unabsolute src
+      let p = src & _1 %~ view PP.absPath_
       pure
         [ -- Mitchell: throwing away any hash-qualification here seems wrong!
           BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
-          BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm
+          BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm
         ]
 
 doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
@@ -41,5 +42,6 @@ doMoveTerm src' dest' description = do
   steps <- moveTermSteps src' dest'
   when (null steps) do
     Cli.returnEarly (Output.TermNotFound src')
-  Cli.stepManyAt description steps
+  pb <- Cli.getCurrentProjectBranch
+  Cli.stepManyAt pb description steps
   Cli.respond Output.Success

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

@@ -1,6 +1,6 @@
 module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where
 
-import Control.Lens (_2)
+import Control.Lens (_1, _2)
 import Data.Set qualified as Set
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
@@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch (Branch0)
 import Unison.Codebase.BranchUtil qualified as BranchUtil
 import Unison.Codebase.Editor.Output qualified as Output
-import Unison.Codebase.Path (Path, Path')
+import Unison.Codebase.Path (Path')
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.HashQualified' qualified as HQ'
 import Unison.NameSegment (NameSegment)
 import Unison.Prelude
 
-moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
+moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)]
 moveTypeSteps src' dest' = do
   src <- Cli.resolveSplit' src'
   srcTypes <- Cli.getTypesAt src
@@ -29,11 +30,11 @@ moveTypeSteps src' dest' = do
       destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
       when (not (Set.null destTypes)) do
         Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
-      let p = first Path.unabsolute src
+      let p = over _1 (view PP.absPath_) src
       pure
         [ -- Mitchell: throwing away any hash-qualification here seems wrong!
           BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
-          BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType
+          BranchUtil.makeAddTypeName (over _1 (view PP.absPath_) dest) srcType
         ]
 
 doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
@@ -41,5 +42,6 @@ doMoveType src' dest' description = do
   steps <- moveTypeSteps src' dest'
   when (null steps) do
     Cli.returnEarly (Output.TypeNotFound src')
-  Cli.stepManyAt description steps
+  pb <- Cli.getCurrentProjectBranch
+  Cli.stepManyAt pb description steps
   Cli.respond Output.Success

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.getMaybeBranch0FromProjectPath pp & onNothingM do
-      Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path)))
+      Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp))
   externalDependencies <-
     Cli.runTransaction (namespaceDependencies codebase branch)
-  currentPPED <- Cli.currentPrettyPrintEnvDecl
+  pped <- Cli.projectBranchPPED pb
-  globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
+  let ppe = PPED.unsuffixifiedPPE pped
-  globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames
+  Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies
-  -- 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
 
 -- | 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/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.MonadUtils qualified as Cli (getCurrentProjectAndBranch)
-import Unison.Cli.ProjectUtils (projectBranchPath)
 import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Cli.Share.Projects qualified as Share
-import Unison.Codebase qualified as Codebase
 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
+  currentProjectBranch <- Cli.getCurrentProjectAndBranch
-  resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
+  resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0
-  localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
+  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
+resolveRemoteNames includeSquashed currentProjectAndBranch = \case
-  ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
+  ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do
-    case maybeCurrentProjectBranch of
+    case projectNameUserSlug remoteProjectName of
-      Nothing -> resolveP remoteProjectName
+      Nothing -> resolveB remoteBranchName
-      Just (currentProjectAndBranch, _path) ->
+      Just _ ->
-        case projectNameUserSlug remoteProjectName of
+        Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
-          Nothing -> resolveB remoteBranchName
+          Nothing -> resolveP remoteProjectName
-          Just _ ->
+          Just remoteBranchProjectId -> do
-            Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
+            -- Fetching these in parallel would be an improvement
-              Nothing -> resolveP remoteProjectName
+            maybeRemoteProject <- Share.getProjectByName remoteProjectName
-              Just remoteBranchProjectId -> do
+            maybeRemoteBranch <-
-                -- Fetching these in parallel would be an improvement
+              Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
-                maybeRemoteProject <- Share.getProjectByName remoteProjectName
+                Share.GetProjectBranchResponseBranchNotFound -> Nothing
-                maybeRemoteBranch <-
+                Share.GetProjectBranchResponseProjectNotFound -> Nothing
-                  Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
+                Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
-                    Share.GetProjectBranchResponseBranchNotFound -> Nothing
+            case (maybeRemoteProject, maybeRemoteBranch) of
-                    Share.GetProjectBranchResponseProjectNotFound -> Nothing
+              (Just remoteProject, Nothing) -> do
-                    Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
+                let remoteProjectId = remoteProject.projectId
-                case (maybeRemoteProject, maybeRemoteBranch) of
+                let remoteProjectName = remoteProject.projectName
-                  (Just remoteProject, Nothing) -> do
+                let remoteBranchName = unsafeFrom @Text "main"
-                    let remoteProjectId = remoteProject.projectId
+                remoteBranch <-
-                    let remoteProjectName = remoteProject.projectName
+                  ProjectUtils.expectRemoteProjectBranchByName
-                    let remoteBranchName = unsafeFrom @Text "main"
+                    includeSquashed
-                    remoteBranch <-
+                    (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
-                      ProjectUtils.expectRemoteProjectBranchByName
+                pure
-                        includeSquashed
+                  ResolvedRemoteNames
-                        (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
+                    { branch = remoteBranch,
-                    pure
+                      from = ResolvedRemoteNamesFrom'Project
-                      ResolvedRemoteNames
+                    }
-                        { branch = remoteBranch,
+              (Nothing, Just remoteBranch) ->
-                          from = ResolvedRemoteNamesFrom'Project
+                pure
-                        }
+                  ResolvedRemoteNames
-                  (Nothing, Just remoteBranch) ->
+                    { branch = remoteBranch,
-                    pure
+                      from = ResolvedRemoteNamesFrom'Branch
-                      ResolvedRemoteNames
+                    }
-                        { branch = remoteBranch,
+              -- Treat neither existing and both existing uniformly as "ambiguous input"
-                          from = ResolvedRemoteNamesFrom'Branch
+              -- 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"
-                  -- Treat neither existing and both existing uniformly as "ambiguous input"
+              _ -> do
-                  -- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
+                branchProjectName <-
-                  -- wouldn't help, because we did enough work to know neither thing exists"
+                  Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
-                  _ -> do
+                Cli.returnEarly $
-                    branchProjectName <-
+                  Output.AmbiguousCloneRemote
-                      Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
+                    remoteProjectName
-                    Cli.returnEarly $
+                    (ProjectAndBranch branchProjectName remoteBranchName)
-                      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 ->
+        ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do
-          case maybeCurrentProjectBranch of
+          Cli.returnEarly $
-            Nothing -> resolveP localProjectName
+            Output.AmbiguousCloneLocal
-            Just (ProjectAndBranch currentProject _, _path) -> do
+              (ProjectAndBranch localProjectName remoteBranchName)
-              Cli.returnEarly $
+              (ProjectAndBranch currentProject.name localBranchName)
-                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
+  let newProjectAndBranch = (over #project fst localProjectAndBranch)
-  Cli.Env {codebase} <- ask
+  Cli.switchProject newProjectAndBranch
-  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
 
 -- 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
+                  Queries.loadProjectByName projectName >>= \case
-                    False -> do
+                    Nothing -> do
-                      Ops.insertProjectAndBranch projectId projectName branchId branchName
+                      (project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
-                      pure projectName
+                      pure (project, branch)
-                    True -> loop projectNames
+                    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
+              Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
-              pure projectName
             True -> rollback (Output.ProjectNameAlreadyExists projectName)
 
-  let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
+  Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
-  Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
+  Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)
-  Cli.cd path
 
   maybeBaseLatestReleaseBranchObject <-
     if tryDownloadingBase
@@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do
         pure maybeBaseLatestReleaseBranchObject
       else pure Nothing
 
-  let projectBranchObject =
+  for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do
-        case maybeBaseLatestReleaseBranchObject of
+    -- lib.base
-          Nothing -> Branch.empty0
+    let projectBranchLibBaseObject =
-          Just baseLatestReleaseBranchObject ->
+          Branch.empty0
-            let -- lib.base
+            & Branch.children
-                projectBranchLibBaseObject =
+              . at NameSegment.baseSegment
-                  over
+              .~ Just baseLatestReleaseBranchObject
-                    Branch.children
+        projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
-                    (Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject)
+    let branchWithBase =
-                    Branch.empty0
+          Branch.empty
-                projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
+            & Branch.history
-             in over
+              . Causal.head_
-                  Branch.children
+              . Branch.children
-                  (Map.insert NameSegment.libSegment projectBranchLibObject)
+              . at NameSegment.libSegment
-                  Branch.empty0
+              .~ Just projectBranchLibObject
-
+    Cli.Env {codebase} <- ask
-  Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
+    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
+  pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}
-    reflogDescription =
-      case maybeProjectName of
-        Nothing -> "project.create"
-        Just projectName -> "project.create " <> into @Text projectName
 
 -- 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
+  ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch
-  let oldName = project ^. #name
+  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)

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

@@ -5,11 +5,11 @@ module Unison.Codebase.Editor.HandleInput.ProjectSwitch
 where
 
 import Data.These (These (..))
-import U.Codebase.Sqlite.Project qualified
+import U.Codebase.Sqlite.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.Editor.Output qualified as Output
 import Unison.Prelude
@@ -28,51 +28,46 @@ import Witch (unsafeFrom)
 projectSwitch :: ProjectAndBranchNames -> Cli ()
 projectSwitch projectNames = do
   case projectNames of
-    ProjectAndBranchNames'Ambiguous projectName branchName ->
+    ProjectAndBranchNames'Ambiguous projectName branchName -> do
-      ProjectUtils.getCurrentProjectBranch >>= \case
+      ProjectAndBranch currentProject _currentBranch <- Cli.getCurrentProjectAndBranch
-        Nothing -> switchToProjectAndBranchByTheseNames (This projectName)
+      (projectExists, branchExists) <-
-        Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do
+        Cli.runTransaction do
-          (projectExists, branchExists) <-
+          (,)
-            Cli.runTransaction do
+            <$> Queries.projectExistsByName projectName
-              (,)
+            <*> Queries.projectBranchExistsByName currentProject.projectId branchName
-                <$> Queries.projectExistsByName projectName
+      case (projectExists, branchExists) of
-                <*> Queries.projectBranchExistsByName currentProject.projectId branchName
+        (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
-          case (projectExists, branchExists) of
+        (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
-            (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
+        (True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
-            (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
+        (True, True) ->
-            (True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
+          Cli.respondNumbered $
-            (True, True) ->
+            Output.AmbiguousSwitch
-              Cli.respondNumbered $
+              projectName
-                Output.AmbiguousSwitch
+              (ProjectAndBranch currentProject.name branchName)
-                  projectName
-                  (ProjectAndBranch currentProject.name branchName)
     ProjectAndBranchNames'Unambiguous projectAndBranchNames0 ->
       switchToProjectAndBranchByTheseNames projectAndBranchNames0
 
 switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli ()
 switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
-  branch <-
+  branch <- case projectAndBranchNames0 of
-    case projectAndBranchNames0 of
+    This projectName ->
-      This projectName ->
+      Cli.runTransactionWithRollback \rollback -> do
-        Cli.runTransactionWithRollback \rollback -> do
+        project <-
-          project <-
+          Queries.loadProjectByName projectName & onNothingM do
-            Queries.loadProjectByName projectName & onNothingM do
+            rollback (Output.LocalProjectDoesntExist projectName)
-              rollback (Output.LocalProjectDoesntExist projectName)
+        Queries.loadMostRecentBranch (project ^. #projectId) >>= \case
-          Queries.loadMostRecentBranch project.projectId >>= \case
+          Nothing -> do
-            Nothing -> do
+            let branchName = unsafeFrom @Text "main"
-              let branchName = unsafeFrom @Text "main"
+            branch <-
-              branch <-
+              Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
-                Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
+                rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
-                  rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
+            pure branch
-              Queries.setMostRecentBranch branch.projectId branch.branchId
+          Just branchId -> Queries.expectProjectBranch project.projectId branchId
-              pure branch
+    _ -> do
-            Just branchId -> Queries.expectProjectBranch project.projectId branchId
+      projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
-      _ -> do
+      Cli.runTransactionWithRollback \rollback -> do
-        projectAndBranchNames <- ProjectUtils.hydrateNames projectAndBranchNames0
+        branch <-
-        Cli.runTransactionWithRollback \rollback -> do
+          Queries.loadProjectBranchByNames projectName branchName & onNothingM do
-          branch <-
+            rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
-            Queries.loadProjectBranchByNames projectAndBranchNames.project projectAndBranchNames.branch & onNothingM do
+        pure branch
-              rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
+  Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId))
-          Queries.setMostRecentBranch branch.projectId branch.branchId
-          pure branch
-  Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId))

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

@@ -21,9 +21,9 @@ import Unison.Cli.MergeTypes (MergeSource (..))
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
+import Unison.Cli.NamesUtils qualified as Cli
 import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Cli.Share.Projects qualified as Share
-import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch (Branch (..))
 import Unison.Codebase.Branch qualified as Branch
@@ -34,13 +34,11 @@ import Unison.Codebase.Editor.Input
 import Unison.Codebase.Editor.Input qualified as Input
 import Unison.Codebase.Editor.Output
 import Unison.Codebase.Editor.Output qualified as Output
-import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
 import Unison.Codebase.Editor.Propagate qualified as Propagate
 import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
-import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
 import Unison.Codebase.Patch (Patch (..))
-import Unison.Codebase.Path (Path')
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.CommandLine.InputPattern qualified as InputPattern
 import Unison.CommandLine.InputPatterns qualified as InputPatterns
 import Unison.NameSegment qualified as NameSegment
@@ -76,8 +74,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
 
   when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
 
-  let targetAbsolutePath =
+  let targetProjectPath = PP.projectBranchRoot (ProjectAndBranch target.project target.branch)
-        ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId)
 
   let description =
         Text.unwords
@@ -92,22 +89,18 @@ handlePull unresolvedSourceAndTarget pullMode = do
 
   case pullMode of
     Input.PullWithHistory -> do
-      targetBranchObject <- Cli.getBranch0At targetAbsolutePath
+      targetBranch <- Cli.getBranchFromProjectPath targetProjectPath
 
-      if Branch.isEmpty0 targetBranchObject
+      if Branch.isEmpty0 $ Branch.head targetBranch
         then do
           Cli.Env {codebase} <- ask
           remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
-          void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject)
+          void $ Cli.updateAtM description targetProjectPath (const $ pure remoteBranchObject)
           Cli.respond $ MergeOverEmpty target
         else do
           Cli.respond AboutToMerge
 
-          aliceCausalHash <-
+          let aliceCausalHash = Branch.headHash targetBranch
-            Cli.runTransaction do
-              causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath)
-              pure causal.causalHash
-
           lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)
 
           doMerge
@@ -139,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
       didUpdate <-
         Cli.updateAtM
           description
-          targetAbsolutePath
+          targetProjectPath
           (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject)
 
       Cli.respond
@@ -167,30 +160,29 @@ resolveSourceAndTarget includeSquashed = \case
     pure (source, target)
 
 resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
-resolveImplicitSource includeSquashed =
+resolveImplicitSource includeSquashed = do
-  ProjectUtils.getCurrentProjectBranch >>= \case
+  pp <- Cli.getCurrentProjectPath
-    Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath
+  let localProjectAndBranch = PP.toProjectAndBranch pp
-    Just (localProjectAndBranch, _restPath) -> do
+  (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
-      (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
+    Cli.runTransactionWithRollback \rollback -> do
-        Cli.runTransactionWithRollback \rollback -> do
+      let localProjectId = localProjectAndBranch.project.projectId
-          let localProjectId = localProjectAndBranch.project.projectId
+      let localBranchId = localProjectAndBranch.branch.branchId
-          let localBranchId = localProjectAndBranch.branch.branchId
+      Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
-          Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
+        Just (remoteProjectId, Just remoteBranchId) -> do
-            Just (remoteProjectId, Just remoteBranchId) -> do
+          remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
-              remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
+          remoteBranchName <-
-              remoteBranchName <-
+            Queries.expectRemoteProjectBranchName
-                Queries.expectRemoteProjectBranchName
+              Share.hardCodedUri
-                  Share.hardCodedUri
+              remoteProjectId
-                  remoteProjectId
+              remoteBranchId
-                  remoteBranchId
+          pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
-              pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
+        _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
-            _ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
+  remoteBranch <-
-      remoteBranch <-
+    ProjectUtils.expectRemoteProjectBranchById includeSquashed $
-        ProjectUtils.expectRemoteProjectBranchById includeSquashed $
+      ProjectAndBranch
-          ProjectAndBranch
+        (remoteProjectId, remoteProjectName)
-            (remoteProjectId, remoteProjectName)
+        (remoteBranchId, remoteBranchName)
-            (remoteBranchId, remoteBranchName)
+  pure (ReadShare'ProjectBranch remoteBranch)
-      pure (ReadShare'ProjectBranch remoteBranch)
 
 resolveExplicitSource ::
   Share.IncludeSquashedHead ->
@@ -208,7 +200,7 @@ resolveExplicitSource includeSquashed = \case
         (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
     pure (ReadShare'ProjectBranch remoteProjectBranch)
   ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
-    (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch
+    localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
     let localProjectId = localProjectAndBranch.project.projectId
     let localBranchId = localProjectAndBranch.branch.branchId
     Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
@@ -243,8 +235,7 @@ resolveExplicitSource includeSquashed = \case
 
 resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
 resolveImplicitTarget = do
-  (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
+  PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
-  pure projectAndBranch
 
 -- | supply `dest0` if you want to print diff messages
 --   supply unchangedMessage if you want to display it if merge had no effect
@@ -253,8 +244,8 @@ mergeBranchAndPropagateDefaultPatch ::
   Text ->
   Maybe Output ->
   Branch IO ->
-  Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
+  Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   Cli ()
 mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest =
   ifM
@@ -266,7 +257,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
     mergeBranch =
       Cli.time "mergeBranch" do
         Cli.Env {codebase} <- ask
-        destb <- Cli.getBranchAt dest
+        destb <- Cli.getBranchFromProjectPath dest
         merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb)
         b <- Cli.updateAtM inputDescription dest (const $ pure merged)
         for_ maybeDest0 \dest0 -> do
@@ -276,19 +267,19 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
 
 loadPropagateDiffDefaultPatch ::
   Text ->
-  Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
+  Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   Cli ()
 loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
   Cli.respond Output.AboutToPropagatePatch
   Cli.time "loadPropagateDiffDefaultPatch" do
-    original <- Cli.getBranch0At dest
+    original <- Cli.getBranch0FromProjectPath dest
     patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original
     patchDidChange <- propagatePatch inputDescription patch dest
     when patchDidChange do
       whenJust maybeDest0 \dest0 -> do
         Cli.respond Output.CalculatingDiff
-        patched <- Cli.getBranchAt dest
+        patched <- Cli.getBranchFromProjectPath dest
         let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment])))
         (ppe, diff) <- diffHelper original (Branch.head patched)
         Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff)
@@ -297,10 +288,11 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
 propagatePatch ::
   Text ->
   Patch ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   Cli Bool
 propagatePatch inputDescription patch scopePath = do
   Cli.time "propagatePatch" do
+    rootNames <- Cli.projectBranchNames scopePath.branch
     Cli.stepAt'
       (inputDescription <> " (applying patch)")
-      (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
+      (scopePath, Propagate.propagateAndApply rootNames patch)

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

@@ -9,13 +9,13 @@ import Control.Lens (_1, _2)
 import Data.Set.NonEmpty qualified as Set.NonEmpty
 import Data.Text as Text
 import Data.These (These (..))
-import Data.Void (absurd)
 import System.Console.Regions qualified as Console.Regions
 import Text.Builder qualified
 import U.Codebase.HashTags (CausalHash (..))
 import U.Codebase.Sqlite.DbId
 import U.Codebase.Sqlite.Operations qualified as Operations
 import U.Codebase.Sqlite.Project qualified as Sqlite (Project)
+import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
 import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch)
 import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Cli.Monad (Cli)
@@ -23,7 +23,6 @@ import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
 import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Cli.Share.Projects qualified as Share
-import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils
 import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin
 import Unison.Codebase.Editor.Input
   ( PushRemoteBranchInput (..),
@@ -32,13 +31,6 @@ import Unison.Codebase.Editor.Input
   )
 import Unison.Codebase.Editor.Output
 import Unison.Codebase.Editor.Output qualified as Output
-import Unison.Codebase.Editor.Output.PushPull (PushPull (Push))
-import Unison.Codebase.Editor.RemoteRepo
-  ( WriteRemoteNamespace (..),
-    WriteShareRemoteNamespace (..),
-  )
-import Unison.Codebase.Path qualified as Path
-import Unison.Codebase.PushBehavior (PushBehavior)
 import Unison.Codebase.PushBehavior qualified as PushBehavior
 import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
 import Unison.Hash32 (Hash32)
@@ -67,49 +59,16 @@ handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
 handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
   case sourceTarget of
     -- push <implicit> to <implicit>
-    PushSourceTarget0 ->
+    PushSourceTarget0 -> do
-      ProjectUtils.getCurrentProjectBranch >>= \case
+      localProjectAndBranch <- Cli.getCurrentProjectAndBranch
-        Nothing -> do
+      pushProjectBranchToProjectBranch force localProjectAndBranch Nothing
-          localPath <- Cli.getCurrentPath
-          UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
-            WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
-            WriteRemoteProjectBranch v -> absurd v
-        Just (localProjectAndBranch, _restPath) ->
-          pushProjectBranchToProjectBranch
-            force
-            localProjectAndBranch
-            Nothing
     -- push <implicit> to .some.path (share)
-    PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
-      localPath <- Cli.getCurrentPath
-      pushLooseCodeToShareLooseCode localPath namespace pushBehavior
     -- push <implicit> to @some/project
-    PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) ->
+    PushSourceTarget1 remoteProjectAndBranch0 -> do
-      ProjectUtils.getCurrentProjectBranch >>= \case
+      localProjectAndBranch <- Cli.getCurrentProjectAndBranch
-        Nothing -> do
+      pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
-          localPath <- Cli.getCurrentPath
-          remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
-          pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
-        Just (localProjectAndBranch, _restPath) ->
-          pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
-    -- push .some.path to .some.path (share)
-    PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
-      localPath <- Cli.resolvePath' localPath0
-      pushLooseCodeToShareLooseCode localPath namespace pushBehavior
-    -- push .some.path to @some/project
-    PushSourceTarget2 (PathySource localPath0) (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do
-      localPath <- Cli.resolvePath' localPath0
-      remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
-      pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
-    -- push @some/project to .some.path (share)
-    PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
-      ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
-      pushLooseCodeToShareLooseCode
-        (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
-        namespace
-        pushBehavior
     -- push @some/project to @some/project
-    PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteProjectBranch remoteProjectAndBranch) -> do
+    PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do
       localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
       pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch)
   where
@@ -119,24 +78,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
         PushBehavior.RequireEmpty -> False
         PushBehavior.RequireNonEmpty -> False
 
--- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code").
-pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli ()
-pushLooseCodeToShareLooseCode _ _ _ = do
-  Cli.returnEarly LooseCodePushDeprecated
-
--- Push a local namespace ("loose code") to a remote project branch.
-pushLooseCodeToProjectBranch :: Bool -> Path.Absolute -> ProjectAndBranch ProjectName ProjectBranchName -> Cli ()
-pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch = do
-  _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
-  localBranchHead <-
-    Cli.runTransactionWithRollback \rollback -> do
-      loadCausalHashToPush localPath >>= \case
-        Nothing -> rollback (EmptyLooseCodePush (Path.absoluteToPath' localPath))
-        Just hash -> pure hash
-
-  uploadPlan <- pushToProjectBranch0 force PushingLooseCode localBranchHead remoteProjectAndBranch
-  executeUploadPlan uploadPlan
-
 -- | Push a local project branch to a remote project branch. If the remote project branch is left unspecified, we either
 -- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it).
 pushProjectBranchToProjectBranch ::
@@ -147,14 +88,11 @@ pushProjectBranchToProjectBranch ::
 pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do
   _ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
   let localProjectAndBranchIds = localProjectAndBranch & over #project (view #projectId) & over #branch (view #branchId)
-  let localProjectAndBranchNames = localProjectAndBranch & over #project (view #name) & over #branch (view #name)
 
   -- Load local project and branch from database and get the causal hash to push
   (localProjectAndBranch, localBranchHead) <-
-    Cli.runTransactionWithRollback \rollback -> do
+    Cli.runTransaction do
-      hash <-
+      hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch)
-        loadCausalHashToPush (ProjectUtils.projectBranchPath localProjectAndBranchIds) & onNothingM do
-          rollback (EmptyProjectBranchPush localProjectAndBranchNames)
       localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds
       pure (localProjectAndBranch, hash)
 
@@ -471,7 +409,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do
       Share.TransportError err -> ShareErrorTransport err
   afterUploadAction
   let ProjectAndBranch projectName branchName = remoteBranch
-  Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName)))
+  Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName))
 
 ------------------------------------------------------------------------------------------------------------------------
 -- After upload actions
@@ -563,7 +501,7 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
 
   when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do
     Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
-    Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)))
+    Cli.returnEarly (ViewOnShare (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))
 
   when (not force) do
     whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
@@ -633,14 +571,11 @@ expectProjectAndBranch (ProjectAndBranch projectId branchId) =
     <$> Queries.expectProject projectId
     <*> Queries.expectProjectBranch projectId branchId
 
--- Get the causal hash to push at the given path. Return Nothing if there's no history.
+-- Get the causal hash for the given project branch.
-loadCausalHashToPush :: Path.Absolute -> Sqlite.Transaction (Maybe Hash32)
+expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32
-loadCausalHashToPush path =
+expectCausalHashToPush pb = do
-  Operations.loadCausalHashAtPath Nothing segments <&> \case
+  CausalHash causalHash <- Operations.expectProjectBranchHead (pb ^. #projectId) (pb ^. #branchId)
-    Nothing -> Nothing
+  pure (Hash32.fromHash causalHash)
-    Just (CausalHash hash) -> Just (Hash32.fromHash hash)
-  where
-    segments = Path.toList (Path.unabsolute path)
 
 -- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward?
 wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool

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

@@ -6,8 +6,8 @@ where
 
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
-import Unison.Cli.ProjectUtils qualified as ProjectUtils
+import Unison.Cli.MonadUtils qualified as Cli
-import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), doCreateBranch)
+import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), createBranch)
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Prelude
 import Unison.Project (Semver)
@@ -16,15 +16,15 @@ import Witch (unsafeFrom)
 -- | Handle a @release.draft@ command.
 handleReleaseDraft :: Semver -> Cli ()
 handleReleaseDraft ver = do
-  currentProjectAndBranch <- fst <$> ProjectUtils.expectCurrentProjectBranch
+  currentProjectAndBranch <- Cli.getCurrentProjectAndBranch
 
   let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver)
 
   _ <-
-    doCreateBranch
+    createBranch
-      (CreateFrom'Branch currentProjectAndBranch)
-      (currentProjectAndBranch ^. #project)
-      branchName
       ("release.draft " <> into @Text ver)
+      (CreateFrom'ParentBranch (currentProjectAndBranch ^. #branch))
+      (currentProjectAndBranch ^. #project)
+      (pure branchName)
 
   Cli.respond (Output.DraftingRelease branchName ver)

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

@@ -11,16 +11,14 @@ import U.Codebase.Reference qualified as V2 (Reference)
 import U.Codebase.Referent qualified as V2 (Referent)
 import U.Codebase.Referent qualified as V2.Referent
 import U.Codebase.Sqlite.Project qualified as Project
-import U.Codebase.Sqlite.Project qualified as Sqlite
 import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
-import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
-import Unison.Cli.ProjectUtils qualified as Project
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
 import Unison.ConstructorType qualified as ConstructorType
 import Unison.HashQualified qualified as HQ
@@ -28,8 +26,7 @@ import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.Parser.Ann (Ann (..))
 import Unison.Prelude
-import Unison.Project (ProjectAndBranch)
+import Unison.Project (ProjectAndBranch (ProjectAndBranch))
-import Unison.Project.Util (projectBranchPath)
 import Unison.Referent qualified as Referent
 import Unison.Server.CodebaseServer qualified as Server
 import Unison.Sqlite qualified as Sqlite
@@ -39,39 +36,27 @@ import Web.Browser (openBrowser)
 openUI :: Path.Path' -> Cli ()
 openUI path' = do
   Cli.Env {serverBaseUrl} <- ask
-  currentPath <- Cli.getCurrentPath
+  defnPath <- Cli.resolvePath' path'
-  let absPath = Path.resolve currentPath path'
+  pp <- Cli.getCurrentProjectPath
   whenJust serverBaseUrl \url -> do
-    Project.getProjectBranchForPath absPath >>= \case
+    openUIForProject url pp (defnPath ^. PP.absPath_)
-      Nothing -> openUIForLooseCode url path'
-      Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch
 
-openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli ()
+openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
-openUIForProject url projectAndBranch pathFromProjectRoot = do
+openUIForProject url pp@(PP.ProjectPath project projectBranch perspective) defnPath = do
-  currentPath <- Cli.getCurrentPath
-  perspective <-
-    Project.getProjectBranchForPath currentPath <&> \case
-      Nothing ->
-        -- The current path is outside the project the argument was in. Use the project root
-        -- as the perspective.
-        Path.empty
-      Just (_projectBranch, pathWithinBranch) -> pathWithinBranch
   mayDefinitionRef <- getDefinitionRef perspective
-  let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch
+  let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch)
   _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
   pure ()
   where
-    pathToBranchFromCodebaseRoot :: Path.Absolute
-    pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch)
     -- If the provided ui path matches a definition, find it.
-    getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference))
+    getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference))
     getDefinitionRef perspective = runMaybeT $ do
       Cli.Env {codebase} <- lift ask
-      let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot)
+      (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath
-      (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition
+      let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace
-      namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing)
+      namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath
       fqn <- hoistMaybe $ do
-        pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot)
+        pathFromPerspective <- List.stripPrefix (Path.toList (Path.unabsolute perspective)) (Path.toList $ Path.unabsolute defnPath)
         Path.toName . Path.fromList $ pathFromPerspective
       def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn
       pure def
@@ -89,35 +74,6 @@ getTermOrTypeRef codebase namespaceBranch fqn = runMaybeT $ do
         pure (toTypeReference fqn oneType)
   terms <|> types
 
-openUIForLooseCode :: Server.BaseUrl -> Path.Path' -> Cli ()
-openUIForLooseCode url path' = do
-  Cli.Env {codebase} <- ask
-  currentPath <- Cli.getCurrentPath
-  (perspective, definitionRef) <- getUIUrlParts currentPath path' codebase
-  _success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.LooseCodeUI perspective definitionRef) url
-  pure ()
-
-getUIUrlParts :: Path.Absolute -> Path.Path' -> Codebase m Symbol Ann -> Cli (Path.Absolute, Maybe (Server.DefinitionReference))
-getUIUrlParts startPath definitionPath' codebase = do
-  let absPath = Path.resolve startPath definitionPath'
-  let perspective =
-        if Path.isAbsolute definitionPath'
-          then Path.absoluteEmpty
-          else startPath
-  case Lens.unsnoc absPath of
-    Just (abs, _nameSeg) -> do
-      namespaceBranch <-
-        Cli.runTransaction
-          (Codebase.getShallowBranchAtPath (Path.unabsolute abs) Nothing)
-      mayDefRef <- runMaybeT do
-        name <- hoistMaybe $ Path.toName $ Path.fromPath' definitionPath'
-        MaybeT $ getTermOrTypeRef codebase namespaceBranch name
-      case mayDefRef of
-        Nothing -> pure (absPath, Nothing)
-        Just defRef -> pure (perspective, Just defRef)
-    Nothing ->
-      pure (absPath, Nothing)
-
 toTypeReference :: Name -> V2.Reference -> Server.DefinitionReference
 toTypeReference name reference =
   Server.TypeReference $

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

@@ -22,6 +22,7 @@ import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch (Branch0)
 import Unison.Codebase.Branch qualified as Branch
+import Unison.Codebase.Branch.Names as Branch
 import Unison.Codebase.BranchUtil qualified as BranchUtil
 import Unison.Codebase.Editor.Input
 import Unison.Codebase.Editor.Output
@@ -73,6 +74,7 @@ import Unison.WatchKind (WatchKind)
 handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli ()
 handleUpdate input optionalPatch requestedNames = do
   Cli.Env {codebase} <- ask
+  pp <- Cli.getCurrentProjectPath
   currentPath' <- Cli.getCurrentPath
   let patchPath =
         case optionalPatch of
@@ -171,37 +173,46 @@ handleUpdate input optionalPatch requestedNames = do
     pure (updatePatch ye'ol'Patch, updatePatches, p)
 
   when (Slurp.hasAddsOrUpdates sr) $ do
-    -- take a look at the `updates` from the SlurpResult
+    -- First add the new definitions to the codebase
-    -- and make a patch diff to record a replacement from the old to new references
-    Cli.stepManyAtMNoSync
-      ( [ ( Path.unabsolute currentPath',
-            pure . doSlurpUpdates typeEdits termEdits termDeprecations
-          ),
-          ( Path.unabsolute currentPath',
-            pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr)
-          )
-        ]
-          ++ case patchOps of
-            Nothing -> []
-            Just (_, update, p) -> [(Path.unabsolute p, update)]
-      )
     Cli.runTransaction
       . Codebase.addDefsToCodebase codebase
       . Slurp.filterUnisonFile sr
       $ Slurp.originalFile sr
+  currentBranch <- Cli.getCurrentBranch
+  -- take a look at the `updates` from the SlurpResult
+  -- and make a patch diff to record a replacement from the old to new references
+  updatedBranch <-
+    currentBranch
+      & Branch.stepManyAtM
+        ( [ ( Path.unabsolute currentPath',
+              pure . doSlurpUpdates typeEdits termEdits termDeprecations
+            ),
+            ( Path.unabsolute currentPath',
+              pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr)
+            )
+          ]
+            ++ case patchOps of
+              Nothing -> []
+              Just (_, update, p) -> [(Path.unabsolute p, update)]
+        )
+      & liftIO
+
   let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames
   pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames
   let suffixifiedPPE = PPE.suffixifiedPPE pped
   Cli.respond $ SlurpOutput input suffixifiedPPE sr
-  whenJust patchOps \(updatedPatch, _, _) ->
+  branchWithPropagatedPatch <- case patchOps of
-    void $ propagatePatchNoSync updatedPatch currentPath'
+    Nothing -> pure updatedBranch
-  Cli.syncRoot case patchPath of
+    Just (updatedPatch, _, _) -> do
-    Nothing -> "update.nopatch"
+      propagatePatch updatedPatch (Path.unabsolute currentPath') updatedBranch
-    Just p ->
+  let description = case patchPath of
-      p
+        Nothing -> "update.nopatch"
-        & Path.unsplit'
+        Just p ->
-        & Path.resolve @_ @_ @Path.Absolute currentPath'
+          p
-        & tShow
+            & Path.unsplit'
+            & Path.resolve @_ @_ @Path.Absolute currentPath'
+            & tShow
+  void $ Cli.updateAt description pp (const branchWithPropagatedPatch)
 
 getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult
 getSlurpResultForUpdate requestedNames slurpCheckNames = do
@@ -646,10 +657,11 @@ doSlurpUpdates typeEdits termEdits deprecated b0 =
         split = Path.splitFromName n
 
 -- Returns True if the operation changed the namespace, False otherwise.
-propagatePatchNoSync :: Patch -> Path.Absolute -> Cli Bool
+propagatePatch :: Patch -> Path.Path -> Branch.Branch IO -> Cli (Branch.Branch IO)
-propagatePatchNoSync patch scopePath =
+propagatePatch patch scopePath b = do
   Cli.time "propagatePatchNoSync" do
-    Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
+    let names = Branch.toNames $ Branch.head b
+    Branch.stepManyAtM [(scopePath, Propagate.propagateAndApply names patch)] b
 
 recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])]
 recomponentize =

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

@@ -49,6 +49,7 @@ import Unison.Codebase.Editor.Output (Output)
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPath)
 import Unison.Codebase.Type (Codebase)
 import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
 import Unison.DataDeclaration (DataDeclaration, Decl)
@@ -106,8 +107,8 @@ handleUpdate2 = do
   Cli.Env {codebase, writeSource} <- ask
   tuf <- Cli.expectLatestTypecheckedFile
   let termAndDeclNames = getTermAndDeclNames tuf
-  currentPath <- Cli.getCurrentPath
+  pp <- Cli.getCurrentProjectPath
-  currentBranch0 <- Cli.getBranch0At currentPath
+  currentBranch0 <- Cli.getCurrentBranch0
   let namesIncludingLibdeps = Branch.toNames currentBranch0
   let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
   let ctorNames = forwardCtorNames namesExcludingLibdeps
@@ -141,7 +142,7 @@ handleUpdate2 = do
       then pure tuf
       else do
         Cli.respond Output.UpdateStartTypechecking
-        parsingEnv <- makeParsingEnv currentPath namesIncludingLibdeps
+        parsingEnv <- makeParsingEnv pp namesIncludingLibdeps
         secondTuf <-
           prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do
             scratchFilePath <- fst <$> Cli.expectLatestFile
@@ -185,7 +186,7 @@ prettyParseTypecheck2 prettyUf parsingEnv = do
           Result.Result _notes Nothing -> Left prettyUf
 
 -- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@.
-makeParsingEnv :: Path.Absolute -> Names -> Cli (Parser.ParsingEnv Transaction)
+makeParsingEnv :: ProjectPath -> Names -> Cli (Parser.ParsingEnv Transaction)
 makeParsingEnv path names = do
   Cli.Env {generateUniqueName} <- ask
   uniqueName <- liftIO generateUniqueName
@@ -200,12 +201,12 @@ makeParsingEnv path names = do
 saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
 saveTuf getConstructors tuf = do
   Cli.Env {codebase} <- ask
-  currentPath <- Cli.getCurrentPath
+  pp <- Cli.getCurrentProjectPath
   branchUpdates <-
     Cli.runTransactionWithRollback \abort -> do
       Codebase.addDefsToCodebase codebase tuf
       typecheckedUnisonFileToBranchUpdates abort getConstructors tuf
-  Cli.stepAt "update" (Path.unabsolute currentPath, Branch.batchUpdates branchUpdates)
+  Cli.stepAt "update" (pp, Branch.batchUpdates branchUpdates)
 
 -- @typecheckedUnisonFileToBranchUpdates getConstructors file@ returns a list of branch updates (suitable for passing
 -- along to `batchUpdates` or some "step at" combinator) that corresponds to using all of the contents of @file@.

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

@@ -11,8 +11,6 @@ import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Text.Builder qualified
 import U.Codebase.Sqlite.DbId (ProjectId)
-import U.Codebase.Sqlite.Project qualified
-import U.Codebase.Sqlite.ProjectBranch qualified
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
@@ -20,6 +18,7 @@ import Unison.Cli.ProjectUtils qualified as Cli
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch
+import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (CreateFrom'ParentBranch))
 import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
 import Unison.Codebase.Editor.HandleInput.Update2
   ( addDefinitionsToUnisonFile,
@@ -34,6 +33,7 @@ import Unison.Codebase.Editor.HandleInput.Update2
   )
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.HashQualified' qualified as HQ'
 import Unison.Name (Name)
 import Unison.Name qualified as Name
@@ -46,7 +46,7 @@ import Unison.PrettyPrintEnv qualified as PPE
 import Unison.PrettyPrintEnv.Names qualified as PPE
 import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
 import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
-import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
+import Unison.Project (ProjectBranchName)
 import Unison.Reference (TermReference, TypeReference)
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
@@ -66,13 +66,10 @@ handleUpgrade oldName newName = do
 
   Cli.Env {codebase, writeSource} <- ask
 
-  (projectAndBranch, _path) <- Cli.expectCurrentProjectBranch
+  let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName])
-  let projectId = projectAndBranch.project.projectId
+  let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName])
-  let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId projectAndBranch.branch.branchId)
-  let oldPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldName]))
-  let newPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newName]))
 
-  currentNamespace <- Cli.getBranch0At projectPath
+  currentNamespace <- Cli.getCurrentProjectRoot0
   let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace
   let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld
   let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld
@@ -80,7 +77,7 @@ handleUpgrade oldName newName = do
   let currentLocalConstructorNames = forwardCtorNames currentLocalNames
   let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld
 
-  oldNamespace <- Cli.expectBranch0AtPath' oldPath
+  oldNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' oldPath)
   let oldLocalNamespace = Branch.deleteLibdeps oldNamespace
   let oldLocalTerms = Branch.deepTerms oldLocalNamespace
   let oldLocalTypes = Branch.deepTypes oldLocalNamespace
@@ -88,7 +85,7 @@ handleUpgrade oldName newName = do
   let oldDeepMinusLocalTerms = Branch.deepTerms oldNamespaceMinusLocal
   let oldDeepMinusLocalTypes = Branch.deepTypes oldNamespaceMinusLocal
 
-  newNamespace <- Cli.expectBranch0AtPath' newPath
+  newNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' newPath)
   let newLocalNamespace = Branch.deleteLibdeps newNamespace
   let newLocalTerms = Branch.deepTerms newLocalNamespace
   let newLocalTypes = Branch.deepTypes newLocalNamespace
@@ -152,27 +149,24 @@ handleUpgrade oldName newName = do
             `PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents
         )
 
-  parsingEnv <- makeParsingEnv projectPath currentDeepNamesSansOld
+  pp@(PP.ProjectPath project projectBranch _path) <- Cli.getCurrentProjectPath
+  parsingEnv <- makeParsingEnv pp currentDeepNamesSansOld
   typecheckedUnisonFile <-
     prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do
-      -- Small race condition: since picking a branch name and creating the branch happen in different
+      let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName
-      -- transactions, creating could fail.
+      (_temporaryBranchId, temporaryBranchName) <-
-      temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName projectId oldName newName)
+        HandleInput.Branch.createBranch
-      temporaryBranchId <-
-        HandleInput.Branch.doCreateBranch
-          (HandleInput.Branch.CreateFrom'Branch projectAndBranch)
-          projectAndBranch.project
-          temporaryBranchName
           textualDescriptionOfUpgrade
-      let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
+          (CreateFrom'ParentBranch projectBranch)
-      Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld)
+          project
+          getTemporaryBranchName
       scratchFilePath <-
         Cli.getLatestFile <&> \case
           Nothing -> "scratch.u"
           Just (file, _) -> file
       liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
       Cli.returnEarly $
-        Output.UpgradeFailure projectAndBranch.branch.name temporaryBranchName scratchFilePath oldName newName
+        Output.UpgradeFailure (projectBranch ^. #name) temporaryBranchName scratchFilePath oldName newName
 
   branchUpdates <-
     Cli.runTransactionWithRollback \abort -> do
@@ -183,7 +177,7 @@ handleUpgrade oldName newName = do
         typecheckedUnisonFile
   Cli.stepAt
     textualDescriptionOfUpgrade
-    ( Path.unabsolute projectPath,
+    ( PP.toRoot pp,
       Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates
     )
   Cli.respond (Output.UpgradeSuccess oldName newName)

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -9,9 +9,10 @@ module Unison.Codebase.Editor.Input
     Event (..),
     OutputLocation (..),
     PatchPath,
+    BranchIdG (..),
     BranchId,
     AbsBranchId,
-    LooseCodeOrProject,
+    UnresolvedProjectBranch,
     parseBranchId,
     parseBranchId2,
     parseShortCausalHash,
@@ -31,10 +32,11 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Text qualified as Text
 import Data.These (These)
 import Unison.Codebase.Branch.Merge qualified as Branch
-import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
+import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
 import Unison.Codebase.Path (Path, Path')
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPath)
 import Unison.Codebase.PushBehavior (PushBehavior)
 import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
@@ -60,15 +62,24 @@ type PatchPath = Path.Split'
 data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
   deriving (Eq, Ord, Show)
 
-type BranchId = Either ShortCausalHash Path'
+data BranchIdG p
+  = BranchAtSCH ShortCausalHash
+  | BranchAtPath p
+  | BranchAtProjectPath ProjectPath
+  deriving stock (Eq, Show, Functor, Foldable, Traversable)
 
--- | A lot of commands can take either a loose code path or a project branch in the same argument slot. Usually, those
+instance From p Text => From (BranchIdG p) Text where
--- have distinct syntaxes, but sometimes it's ambiguous, in which case we'd parse a `These`. The command itself can
+  from = \case
--- decide what to do with the ambiguity.
+    BranchAtSCH h -> "#" <> SCH.toText h
-type LooseCodeOrProject =
+    BranchAtPath p -> from p
-  These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
+    BranchAtProjectPath pp -> from pp
 
-type AbsBranchId = Either ShortCausalHash Path.Absolute
+type BranchId = BranchIdG Path'
+
+type AbsBranchId = BranchIdG Path.Absolute
+
+-- | An unambiguous project branch name, use the current project name if not provided.
+type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName
 
 type HashOrHQSplit' = Either ShortHash Path.HQSplit'
 
@@ -79,8 +90,8 @@ data Insistence = Force | Try
 parseBranchId :: String -> Either Text BranchId
 parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
   Nothing -> Left "Invalid hash, expected a base32hex string."
-  Just h -> pure $ Left h
+  Just h -> pure $ BranchAtSCH h
-parseBranchId s = Right <$> Path.parsePath' s
+parseBranchId s = BranchAtPath <$> Path.parsePath' s
 
 parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
 parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of
@@ -106,18 +117,13 @@ data Input
     -- clone w/o merge, error if would clobber
     ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath
   | -- merge first causal into destination
-    MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode
+    MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode
-  | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject
+  | PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath)
   | DiffNamespaceI BranchId BranchId -- old new
   | PullI !PullSourceTarget !PullMode
   | PushRemoteBranchI PushRemoteBranchInput
-  | ResetRootI (Either ShortCausalHash Path')
+  | ResetRootI BranchId
-  | ResetI
+  | ResetI BranchId (Maybe UnresolvedProjectBranch)
-      ( These
-          (Either ShortCausalHash Path')
-          (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
-      )
-      (Maybe LooseCodeOrProject)
   | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
     --          Does it make sense to fork from not-the-root of a Github repo?
     -- used in Welcome module to give directions to user
@@ -237,8 +243,8 @@ data BranchSourceI
     BranchSourceI'CurrentContext
   | -- | Create an empty branch
     BranchSourceI'Empty
-  | -- | Create a branch from this loose-code-or-project
+  | -- | Create a branch from this other branch
-    BranchSourceI'LooseCodeOrProject LooseCodeOrProject
+    BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch
   deriving stock (Eq, Show)
 
 -- | Pull source and target: either neither is specified, or only a source, or both.
@@ -249,15 +255,14 @@ data PullSourceTarget
   deriving stock (Eq, Show)
 
 data PushSource
-  = PathySource Path'
+  = ProjySource (These ProjectName ProjectBranchName)
-  | ProjySource (These ProjectName ProjectBranchName)
   deriving stock (Eq, Show)
 
 -- | Push source and target: either neither is specified, or only a target, or both.
 data PushSourceTarget
   = PushSourceTarget0
-  | PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName))
+  | PushSourceTarget1 (These ProjectName ProjectBranchName)
-  | PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName))
+  | PushSourceTarget2 PushSource (These ProjectName ProjectBranchName)
   deriving stock (Eq, Show)
 
 data PushRemoteBranchInput = PushRemoteBranchInput
@@ -304,7 +309,7 @@ data DeleteTarget
   = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit']
   | DeleteTarget'Term DeleteOutput [Path.HQSplit']
   | DeleteTarget'Type DeleteOutput [Path.HQSplit']
-  | DeleteTarget'Namespace Insistence (Maybe Path.Split)
+  | DeleteTarget'Namespace Insistence (Path.Split)
   | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
   | DeleteTarget'Project ProjectName
   deriving stock (Eq, Show)

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -43,10 +43,11 @@ import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
 import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
 import Unison.Codebase.Path (Path')
 import Unison.Codebase.Path qualified as Path
-import Unison.Codebase.PushBehavior (PushBehavior)
+import Unison.Codebase.ProjectPath (ProjectPath)
 import Unison.Codebase.Runtime qualified as Runtime
 import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
+import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
 import Unison.CommandLine.InputPattern qualified as Input
 import Unison.DataDeclaration qualified as DD
 import Unison.DataDeclaration.ConstructorId (ConstructorId)
@@ -98,25 +99,25 @@ type NumberedArgs = [StructuredArgument]
 type HashLength = Int
 
 data NumberedOutput
-  = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
+  = ShowDiffNamespace (Either ShortCausalHash ProjectPath) (Either ShortCausalHash ProjectPath) PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterMerge
-      (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
+      (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
-      Path.Absolute
+      ProjectPath
       PPE.PrettyPrintEnv
       (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterMergePropagate
-      (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
+      (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
-      Path.Absolute
+      ProjectPath
       Path.Path'
       PPE.PrettyPrintEnv
       (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterMergePreview
-      (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
+      (Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
-      Path.Absolute
+      ProjectPath
       PPE.PrettyPrintEnv
       (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
@@ -149,7 +150,7 @@ data NumberedOutput
   | -- | List all direct dependencies which don't have any names in the current branch
     ListNamespaceDependencies
       PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace.
-      Path.Absolute -- The namespace we're checking dependencies for.
+      ProjectPath -- The namespace we're checking dependencies for.
       (Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
 
 data TodoOutput = TodoOutput
@@ -285,7 +286,7 @@ data Output
     -- and a nicer render.
     BustedBuiltins (Set Reference) (Set Reference)
   | ShareError ShareError
-  | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
+  | ViewOnShare (URI, ProjectName, ProjectBranchName)
   | NoConfiguredRemoteMapping PushPull Path.Absolute
   | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
   | TermMissingType Reference
@@ -303,14 +304,10 @@ data Output
   | AboutToMerge
   | -- | Indicates a trivial merge where the destination was empty and was just replaced.
     MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
-  | MergeAlreadyUpToDate
+  | MergeAlreadyUpToDate BranchRelativePath BranchRelativePath
-      (Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
-      (Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
   | -- This will replace the above once `merge.old` is deleted
     MergeAlreadyUpToDate2 !MergeSourceAndTarget
-  | PreviewMergeAlreadyUpToDate
+  | PreviewMergeAlreadyUpToDate ProjectPath ProjectPath
-      (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
-      (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
   | NotImplemented
   | NoBranchWithHash ShortCausalHash
   | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
@@ -322,10 +319,8 @@ data Output
   | BadName Text
   | CouldntLoadBranch CausalHash
   | HelpMessage Input.InputPattern
-  | NamespaceEmpty (NonEmpty AbsBranchId)
+  | NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath))
   | NoOp
-  | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
-    RefusedToPush PushBehavior (WriteRemoteNamespace Void)
   | -- | @GistCreated repo@ means a causal was just published to @repo@.
     GistCreated (ReadRemoteNamespace Void)
   | -- | Directs the user to URI to begin an authorization flow.
@@ -407,7 +402,6 @@ data Output
   | UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int)
   | UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment
   | UpgradeSuccess !NameSegment !NameSegment
-  | LooseCodePushDeprecated
   | MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName
   | MergeSuccess !MergeSourceAndTarget
   | MergeSuccessFastForward !MergeSourceAndTarget
@@ -443,12 +437,10 @@ data CreatedProjectBranchFrom
 -- | A branch was empty. But how do we refer to that branch?
 data WhichBranchEmpty
   = WhichBranchEmptyHash ShortCausalHash
-  | WhichBranchEmptyPath Path'
+  | WhichBranchEmptyPath ProjectPath
 
 data ShareError
-  = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError
+  = ShareErrorDownloadEntities Share.DownloadEntitiesError
-  | ShareErrorDownloadEntities Share.DownloadEntitiesError
-  | ShareErrorFastForwardPush Sync.FastForwardPushError
   | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError
   | ShareErrorPull Sync.PullError
   | ShareErrorTransport Sync.CodeserverTransportError
@@ -581,7 +573,6 @@ isFailure o = case o of
   TermMissingType {} -> True
   DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
   NamespaceEmpty {} -> True
-  RefusedToPush {} -> True
   GistCreated {} -> False
   InitiateAuthFlow {} -> False
   UnknownCodeServer {} -> True
@@ -645,7 +636,6 @@ isFailure o = case o of
   ProjectHasNoReleases {} -> True
   UpgradeFailure {} -> True
   UpgradeSuccess {} -> False
-  LooseCodePushDeprecated -> True
   MergeFailure {} -> True
   MergeSuccess {} -> False
   MergeSuccessFastForward {} -> False

unison-cli/src/Unison/Codebase/Editor/Propagate.hs

@@ -14,7 +14,6 @@ import U.Codebase.Reference qualified as Reference
 import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
-import Unison.Cli.MonadUtils qualified as Cli
 import Unison.Cli.TypeCheck qualified as Cli (computeTypecheckingEnvironment)
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
@@ -82,11 +81,12 @@ noEdits :: Edits v
 noEdits = Edits mempty mempty mempty mempty mempty mempty mempty
 
 propagateAndApply ::
+  Names ->
   Patch ->
   Branch0 IO ->
   Cli (Branch0 IO)
-propagateAndApply patch branch = do
+propagateAndApply rootNames patch branch = do
-  edits <- propagate patch branch
+  edits <- propagate rootNames patch branch
   let f = applyPropagate patch edits
   (pure . f . applyDeprecations patch) branch
 
@@ -234,15 +234,13 @@ debugMode = False
 --
 -- "dirty" means in need of update
 -- "frontier" means updated definitions responsible for the "dirty"
-propagate :: Patch -> Branch0 IO -> Cli (Edits Symbol)
+propagate :: Names -> Patch -> Branch0 IO -> Cli (Edits Symbol)
-propagate patch b = case validatePatch patch of
+propagate rootNames patch b = case validatePatch patch of
   Nothing -> do
     Cli.respond PatchNeedsToBeConflictFree
     pure noEdits
   Just (initialTermEdits, initialTypeEdits) -> do
     -- TODO: this can be removed once patches have term replacement of type `Referent -> Referent`
-    rootNames <- Branch.toNames <$> Cli.getRootBranch0
-
     let -- TODO: these are just used for tracing, could be deleted if we don't care
         -- about printing meaningful names for definitions during propagation, or if
         -- we want to just remove the tracing.

unison-cli/src/Unison/Codebase/Editor/UriParser.hs

@@ -1,8 +1,7 @@
 module Unison.Codebase.Editor.UriParser
   ( readRemoteNamespaceParser,
-    writeRemoteNamespace,
-    writeRemoteNamespaceWith,
     parseReadShareLooseCode,
+    writeRemoteNamespace,
   )
 where
 
@@ -17,8 +16,6 @@ import Unison.Codebase.Editor.RemoteRepo
     ReadShareLooseCode (..),
     ShareCodeserver (DefaultCodeserver),
     ShareUserHandle (..),
-    WriteRemoteNamespace (..),
-    WriteShareRemoteNamespace (..),
   )
 import Unison.Codebase.Path qualified as Path
 import Unison.NameSegment (NameSegment)
@@ -53,25 +50,9 @@ parseReadShareLooseCode label input =
 
 -- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
 -- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
-writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
+writeRemoteNamespace :: P (These ProjectName ProjectBranchName)
 writeRemoteNamespace =
-  writeRemoteNamespaceWith
+  (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
-    (projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
-
-writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
-writeRemoteNamespaceWith projectBranchParser =
-  WriteRemoteProjectBranch <$> projectBranchParser
-    <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
-
--- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
--- Just (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})
-writeShareRemoteNamespace :: P WriteShareRemoteNamespace
-writeShareRemoteNamespace =
-  P.label "write share remote namespace" $
-    WriteShareRemoteNamespace
-      <$> pure DefaultCodeserver
-      <*> shareUserHandle
-      <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
 
 -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
 -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4"

unison-cli/src/Unison/Codebase/TranscriptParser.hs

@@ -32,7 +32,6 @@ import Data.Map qualified as Map
 import Data.Text qualified as Text
 import Data.These (These (..))
 import Data.UUID.V4 qualified as UUID
-import Ki qualified
 import Network.HTTP.Client qualified as HTTP
 import System.Directory (doesFileExist)
 import System.Environment (lookupEnv)
@@ -41,7 +40,6 @@ import System.IO qualified as IO
 import System.IO.Error (catchIOError)
 import Text.Megaparsec qualified as P
 import U.Codebase.Sqlite.DbId qualified as Db
-import U.Codebase.Sqlite.Operations qualified as Operations
 import U.Codebase.Sqlite.Project (Project (..))
 import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
 import U.Codebase.Sqlite.Queries qualified as Q
@@ -51,15 +49,14 @@ import Unison.Auth.Tokens qualified as AuthN
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
-import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Editor.HandleInput qualified as HandleInput
 import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Editor.UCMVersion (UCMVersion)
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
-import Unison.Codebase.Path.Parse qualified as Path
 import Unison.Codebase.Runtime qualified as Runtime
 import Unison.Codebase.Verbosity (Verbosity, isSilent)
 import Unison.Codebase.Verbosity qualified as Verbosity
@@ -68,10 +65,11 @@ import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName))
 import Unison.CommandLine.InputPatterns (validInputs)
 import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
 import Unison.CommandLine.Welcome (asciiartUnison)
+import Unison.Core.Project (ProjectBranchName, ProjectName (..))
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.PrettyTerminal
-import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous), ProjectBranchName, ProjectName)
+import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous))
 import Unison.Runtime.Interface qualified as RTI
 import Unison.Server.Backend qualified as Backend
 import Unison.Server.CodebaseServer qualified as Server
@@ -110,8 +108,7 @@ data UcmLine
 
 -- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>).
 data UcmContext
-  = UcmContextLooseCode Path.Absolute
+  = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
-  | UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
 
 data APIRequest
   = GetRequest Text
@@ -133,9 +130,7 @@ instance Show UcmLine where
     UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
     UcmComment txt -> "--" ++ Text.unpack txt
     where
-      showContext = \case
+      showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
-        UcmContextLooseCode path -> show path
-        UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch)
 
 instance Show Stanza where
   show s = case s of
@@ -248,9 +243,14 @@ run ::
   UCMVersion ->
   Text ->
   IO (Either TranscriptError Text)
-run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try $ Ki.scoped \scope -> do
+run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try do
   httpManager <- HTTP.newManager HTTP.defaultManagerSettings
-  let initialPath = Path.absoluteEmpty
+  (initialPP, emptyCausalHashId) <- Codebase.runTransaction codebase do
+    (_, emptyCausalHashId) <- Codebase.emptyCausalHash
+    initialPP <- Codebase.expectCurrentProjectPath
+    pure (initialPP, emptyCausalHashId)
+
+  projectRootVar <- newTMVarIO Branch.empty
   unless (isSilent verbosity) . putPrettyLn $
     Pretty.lines
       [ asciiartUnison,
@@ -258,11 +258,6 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
         "Running the provided transcript file...",
         ""
       ]
-  initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash
-  rootVar <- newEmptyTMVarIO
-  void $ Ki.fork scope do
-    root <- Codebase.getRootBranch codebase
-    atomically $ putTMVar rootVar root
   mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey
   credMan <- AuthN.newCredentialManager
   let tokenProvider :: AuthN.TokenProvider
@@ -346,15 +341,11 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
                 liftIO (output ("\n" <> show p))
                 awaitInput
               p@(UcmCommand context lineTxt) -> do
-                curPath <- Cli.getCurrentPath
+                curPath <- Cli.getCurrentProjectPath
                 -- We're either going to run the command now (because we're in the right context), else we'll switch to
                 -- the right context first, then run the command next.
                 maybeSwitchCommand <-
                   case context of
-                    UcmContextLooseCode path ->
-                      if curPath == path
-                        then pure Nothing
-                        else pure $ Just (SwitchBranchI (Path.absoluteToPath' path))
                     UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do
                       Project {projectId, name = projectName} <-
                         Q.loadProjectByName projectName
@@ -369,12 +360,12 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
                           Nothing -> do
                             branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
                             let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName}
-                            Q.insertProjectBranch projectBranch
+                            Q.insertProjectBranch "Branch Created" emptyCausalHashId projectBranch
                             pure projectBranch
                           Just projBranch -> pure projBranch
                       let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId
                       pure
-                        if curPath == ProjectUtils.projectBranchPath projectAndBranchIds
+                        if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds
                           then Nothing
                           else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName)))
                 case maybeSwitchCommand of
@@ -387,7 +378,8 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
                       args -> do
                         liftIO (output ("\n" <> show p <> "\n"))
                         numberedArgs <- use #numberedArgs
-                        liftIO (parseInput codebase curPath numberedArgs patternMap args) >>= \case
+                        let getProjectRoot = atomically $ readTMVar projectRootVar
+                        liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args) >>= \case
                           -- invalid command is treated as a failure
                           Left msg -> do
                             liftIO $ writeIORef hasErrors True
@@ -580,7 +572,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
             texts <- readIORef out
             pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
 
-  loop (Cli.loopState0 initialRootCausalHash rootVar initialPath)
+  loop (Cli.loopState0 projectRootVar (PP.toIds initialPP))
 
 transcriptFailure :: IORef (Seq String) -> Text -> IO b
 transcriptFailure out msg = do
@@ -605,9 +597,8 @@ ucmLine = ucmCommand <|> ucmComment
         P.try do
           contextString <- P.takeWhile1P Nothing (/= '>')
           context <-
-            case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of
+            case (tryFrom @Text contextString) of
-              (Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch))
+              (Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
-              (Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs)
               _ -> fail "expected project/branch or absolute path"
           void $ lineToken $ word ">"
           pure context

unison-cli/src/Unison/CommandLine.hs

@@ -26,6 +26,7 @@ module Unison.CommandLine
 where
 
 import Control.Concurrent (forkIO, killThread)
+import Control.Lens hiding (aside)
 import Control.Monad.Except
 import Control.Monad.Trans.Except
 import Data.Configurator (autoConfig, autoReload)
@@ -42,12 +43,11 @@ import Data.Vector qualified as Vector
 import System.FilePath (takeFileName)
 import Text.Regex.TDFA ((=~))
 import Unison.Codebase (Codebase)
-import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch (Branch0)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Editor.Input (Event (..), Input (..))
 import Unison.Codebase.Editor.Output (NumberedArgs)
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Watch qualified as Watch
 import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
 import Unison.CommandLine.FuzzySelect qualified as Fuzzy
@@ -55,7 +55,6 @@ import Unison.CommandLine.InputPattern (InputPattern (..))
 import Unison.CommandLine.InputPattern qualified as InputPattern
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
-import Unison.Project.Util (ProjectContext, projectContextFromPath)
 import Unison.Symbol (Symbol)
 import Unison.Util.ColorText qualified as CT
 import Unison.Util.Monoid (foldMapM)
@@ -121,8 +120,9 @@ nothingTodo = emojiNote "😶"
 
 parseInput ::
   Codebase IO Symbol Ann ->
-  -- | Current path from root
+  -- | Current location
-  Path.Absolute ->
+  PP.ProjectPath ->
+  IO (Branch.Branch IO) ->
   -- | Numbered arguments
   NumberedArgs ->
   -- | Input Pattern Map
@@ -132,10 +132,11 @@ parseInput ::
   -- Returns either an error message or the fully expanded arguments list and parsed input.
   -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c)
   IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input)))
-parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
+parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do
   let getCurrentBranch0 :: IO (Branch0 IO)
-      getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath
+      getCurrentBranch0 = do
-  let projCtx = projectContextFromPath currentPath
+        projRoot <- currentProjectRoot
+        pure . Branch.head $ Branch.getAt' (projPath ^. PP.path_) projRoot
 
   case segments of
     [] -> throwE ""
@@ -144,7 +145,7 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
         let expandedNumbers :: InputPattern.Arguments
             expandedNumbers =
               foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args
-        lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case
+        lift (fzfResolve codebase projPath getCurrentBranch0 pat expandedNumbers) >>= \case
           Left (NoFZFResolverForArgumentType _argDesc) -> throwError help
           Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc)
           Left FZFCancelled -> pure Nothing
@@ -192,8 +193,8 @@ data FZFResolveFailure
   | NoFZFOptions Text {- argument description -}
   | FZFCancelled
 
-fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
+fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
-fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
+fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do
   -- We resolve args in two steps, first we check that all arguments that will require a fzf
   -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search.
   -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver
@@ -214,7 +215,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
     fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments
     fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do
       currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch
-      options <- liftIO $ getOptions codebase projCtx currentBranch
+      options <- liftIO $ getOptions codebase ppCtx currentBranch
       when (null options) $ throwError $ NoFZFOptions argDesc
       liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc)
       results <-

unison-cli/src/Unison/CommandLine/BranchRelativePath.hs

@@ -2,9 +2,9 @@ module Unison.CommandLine.BranchRelativePath
   ( BranchRelativePath (..),
     parseBranchRelativePath,
     branchRelativePathParser,
-    ResolvedBranchRelativePath (..),
     parseIncrementalBranchRelativePath,
     IncrementalBranchRelativePath (..),
+    toText,
   )
 where
 
@@ -14,10 +14,9 @@ import Data.These (These (..))
 import Text.Builder qualified
 import Text.Megaparsec qualified as Megaparsec
 import Text.Megaparsec.Char qualified as Megaparsec
-import U.Codebase.Sqlite.Project qualified as Sqlite
-import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPathG (..))
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import Unison.Project qualified as Project
@@ -25,8 +24,11 @@ import Unison.Util.ColorText qualified as CT
 import Unison.Util.Pretty qualified as P
 
 data BranchRelativePath
-  = BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative)
+  = -- | A path rooted at some specified branch/project
-  | LoosePath Path.Path'
+    BranchPathInCurrentProject ProjectBranchName Path.Absolute
+  | QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute
+  | -- | A path which is relative to the user's current location.
+    UnqualifiedPath Path.Path'
   deriving stock (Eq, Show)
 
 -- | Strings without colons are parsed as loose code paths. A path with a colon may specify:
@@ -52,56 +54,37 @@ parseBranchRelativePath str =
     Left e -> Left (P.string (Megaparsec.errorBundlePretty e))
     Right x -> Right x
 
+-- |
+-- >>> from @BranchRelativePath @Text (BranchPathInCurrentProject "foo" (Path.absoluteEmpty "bar"))
 instance From BranchRelativePath Text where
   from = \case
-    BranchRelative brArg -> case brArg of
+    BranchPathInCurrentProject branch path ->
-      This eitherProj ->
+      Text.Builder.run $
-        Text.Builder.run
+        Text.Builder.char '/'
-          ( Text.Builder.text (eitherProjToText eitherProj)
+          <> Text.Builder.text (into @Text branch)
-              <> Text.Builder.char ':'
+          <> Text.Builder.char ':'
-          )
+          <> Text.Builder.text (Path.absToText path)
-      That path ->
+    QualifiedBranchPath proj branch path ->
-        Text.Builder.run
+      Text.Builder.run $
-          ( Text.Builder.char ':'
+        Text.Builder.text (into @Text proj)
-              <> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
+          <> Text.Builder.char '/'
-          )
+          <> Text.Builder.text (into @Text branch)
-      These eitherProj path ->
+          <> Text.Builder.char ':'
-        Text.Builder.run
+          <> Text.Builder.text (Path.absToText path)
-          ( Text.Builder.text (eitherProjToText eitherProj)
+    UnqualifiedPath path ->
-              <> Text.Builder.char ':'
+      Path.toText' path
-              <> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
-          )
-    LoosePath path -> Path.toText' path
-    where
-      eitherProjToText = \case
-        Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName)
-        Right (projName, branchName) -> into @Text (These projName branchName)
-
-data ResolvedBranchRelativePath
-  = ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative)
-  | ResolvedLoosePath Path.Absolute
-
-instance From ResolvedBranchRelativePath BranchRelativePath where
-  from = \case
-    ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of
-      Nothing -> BranchRelative (This (Right (view #name proj, view #name branch)))
-      Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel)
-    ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p)
-
-instance From ResolvedBranchRelativePath Text where
-  from = from . into @BranchRelativePath
 
 data IncrementalBranchRelativePath
-  = -- | no dots, slashes, or colons
+  = -- | no dots, slashes, or colons, so could be a project name or a single path segment
-    ProjectOrRelative Text Path.Path'
+    ProjectOrPath' Text Path.Path'
-  | -- | dots, no slashes or colons
+  | -- | dots, no slashes or colons, must be a relative or absolute path
-    LooseCode Path.Path'
+    OnlyPath' Path.Path'
   | -- | valid project, no slash
     IncompleteProject ProjectName
   | -- | valid project/branch, slash, no colon
     IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName)
   | -- | valid project/branch, with colon
-    IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative)
+    IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Absolute)
   | PathRelativeToCurrentBranch Path.Relative
   deriving stock (Show)
 
@@ -158,9 +141,9 @@ incrementalBranchRelativePathParser =
                 pure (IncompleteProject projectName)
            in end <|> startingAtSlash (Just projectName)
         -- The string doesn't parse as a project name but does parse as a path
-        That (_, path) -> pure (LooseCode path)
+        That (_, path) -> pure (OnlyPath' path)
         -- The string parses both as a project name and a path
-        These _ (_, path) -> ProjectOrRelative <$> Megaparsec.takeRest <*> pure path
+        These _ (_, path) -> ProjectOrPath' <$> Megaparsec.takeRest <*> pure path
 
     startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath
     startingAtBranch mproj =
@@ -180,7 +163,7 @@ incrementalBranchRelativePathParser =
       Megaparsec.Parsec Void Text IncrementalBranchRelativePath
     startingAtColon projStuff = do
       _ <- Megaparsec.char ':'
-      p <- optionalEof relPath
+      p <- optionalEof absPath
       pure (IncompletePath projStuff p)
 
     pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath
@@ -190,18 +173,25 @@ incrementalBranchRelativePathParser =
       pure (PathRelativeToCurrentBranch p)
 
     optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a)
-    optionalEof pa = Just <$> pa <|> Nothing <$ Megaparsec.eof
+    optionalEof pa = Just <$> pa <|> (Nothing <$ Megaparsec.eof)
 
     optionalBranch :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName)
     optionalBranch = optionalEof branchNameParser
 
     branchNameParser = Project.projectBranchNameParser False
 
+    relPath :: Megaparsec.Parsec Void Text Path.Relative
     relPath = do
       offset <- Megaparsec.getOffset
       path' >>= \(Path.Path' inner) -> case inner of
         Left _ -> failureAt offset "Expected a relative path but found an absolute path"
         Right x -> pure x
+    absPath :: Megaparsec.Parsec Void Text Path.Absolute
+    absPath = do
+      offset <- Megaparsec.getOffset
+      path' >>= \(Path.Path' inner) -> case inner of
+        Left p -> pure p
+        Right _ -> failureAt offset "Expected an absolute path but found a relative path. Try adding a leading '.' to your path"
     path' = Megaparsec.try do
       offset <- Megaparsec.getOffset
       pathStr <- Megaparsec.takeRest
@@ -234,16 +224,20 @@ incrementalBranchRelativePathParser =
 branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
 branchRelativePathParser =
   incrementalBranchRelativePathParser >>= \case
-    ProjectOrRelative _txt path -> pure (LoosePath path)
+    ProjectOrPath' _txt path -> pure (UnqualifiedPath path)
-    LooseCode path -> pure (LoosePath path)
+    OnlyPath' path -> pure (UnqualifiedPath path)
     IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here."
     IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here."
-    PathRelativeToCurrentBranch p -> pure (BranchRelative (That p))
+    PathRelativeToCurrentBranch p -> pure (UnqualifiedPath (Path.RelativePath' p))
     IncompletePath projStuff mpath ->
       case projStuff of
-        Left (ProjectAndBranch projName branchName) -> case mpath of
+        Left (ProjectAndBranch projName branchName) ->
-          Nothing -> pure (BranchRelative (This (Right (projName, branchName))))
+          pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath)
-          Just path -> pure (BranchRelative (These (Right (projName, branchName)) path))
+        Right branch ->
-        Right branch -> case mpath of
+          pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath)
-          Nothing -> pure (BranchRelative (This (Left branch)))
+
-          Just path -> pure (BranchRelative (These (Left branch) path))
+toText :: BranchRelativePath -> Text
+toText = \case
+  BranchPathInCurrentProject pbName absPath -> ProjectPath () pbName absPath & into @Text
+  QualifiedBranchPath projName pbName absPath -> ProjectPath projName pbName absPath & into @Text
+  UnqualifiedPath path' -> Path.toText' path'

unison-cli/src/Unison/CommandLine/Completion.hs

@@ -20,9 +20,8 @@ module Unison.CommandLine.Completion
   )
 where
 
-import Control.Lens (ifoldMap)
+import Control.Lens
 import Control.Lens qualified as Lens
-import Control.Lens.Cons (unsnoc)
 import Data.Aeson qualified as Aeson
 import Data.List (isPrefixOf)
 import Data.List qualified as List
@@ -48,6 +47,7 @@ import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
 import Unison.CommandLine.InputPattern qualified as IP
 import Unison.HashQualified' qualified as HQ'
@@ -73,9 +73,9 @@ haskelineTabComplete ::
   Map String IP.InputPattern ->
   Codebase m v a ->
   AuthenticatedHttpClient ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   Line.CompletionFunc m
-haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.completeWordWithPrev Nothing " " $ \prev word ->
+haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWordWithPrev Nothing " " $ \prev word ->
   -- User hasn't finished a command name, complete from command names
   if null prev
     then pure . exactComplete word $ Map.keys patterns
@@ -84,7 +84,7 @@ haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.compl
       h : t -> fromMaybe (pure []) $ do
         p <- Map.lookup h patterns
         argType <- IP.argType p (length t)
-        pure $ IP.suggestions argType word codebase authedHTTPClient currentPath
+        pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx
       _ -> pure []
 
 -- | Things which we may want to complete for.
@@ -101,7 +101,7 @@ noCompletions ::
   String ->
   Codebase m v a ->
   AuthenticatedHttpClient ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   m [System.Console.Haskeline.Completion.Completion]
 noCompletions _ _ _ _ = pure []
 
@@ -141,11 +141,11 @@ completeWithinNamespace ::
   NESet CompletionType ->
   -- | The portion of this are that the user has already typed.
   String ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
-completeWithinNamespace compTypes query currentPath = do
+completeWithinNamespace compTypes query ppCtx = do
   shortHashLen <- Codebase.hashLength
-  b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing
+  b <- Codebase.getShallowBranchAtProjectPath queryProjectPath
   currentBranchSuggestions <- do
     nib <- namesInBranch shortHashLen b
     nib
@@ -168,8 +168,8 @@ completeWithinNamespace compTypes query currentPath = do
     queryPathPrefix :: Path.Path'
     querySuffix :: Text
     (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query)
-    absQueryPath :: Path.Absolute
+    queryProjectPath :: PP.ProjectPath
-    absQueryPath = Path.resolve currentPath queryPathPrefix
+    queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix
     getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
     getChildSuggestions shortHashLen b
       | Text.null querySuffix = pure []
@@ -274,35 +274,35 @@ parseLaxPath'Query txt =
 -- | Completes a namespace argument by prefix-matching against the query.
 prefixCompleteNamespace ::
   String ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   Sqlite.Transaction [Line.Completion]
 prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion)
 
 -- | Completes a term or type argument by prefix-matching against the query.
 prefixCompleteTermOrType ::
   String ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   Sqlite.Transaction [Line.Completion]
 prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion]))
 
 -- | Completes a term argument by prefix-matching against the query.
 prefixCompleteTerm ::
   String ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   Sqlite.Transaction [Line.Completion]
 prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion)
 
 -- | Completes a term or type argument by prefix-matching against the query.
 prefixCompleteType ::
   String ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   Sqlite.Transaction [Line.Completion]
 prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion)
 
 -- | Completes a patch argument by prefix-matching against the query.
 prefixCompletePatch ::
   String ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   Sqlite.Transaction [Line.Completion]
 prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion)
 

unison-cli/src/Unison/CommandLine/FZFResolvers.hs

@@ -37,13 +37,13 @@ import Unison.Codebase.Branch (Branch0)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Path (Path, Path' (..))
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Name qualified as Name
 import Unison.NameSegment qualified as NameSegment
 import Unison.Names qualified as Names
 import Unison.Parser.Ann (Ann)
 import Unison.Position qualified as Position
 import Unison.Prelude
-import Unison.Project.Util (ProjectContext (..))
 import Unison.Symbol (Symbol)
 import Unison.Syntax.HashQualified qualified as HQ (toText)
 import Unison.Syntax.NameSegment qualified as NameSegment
@@ -51,7 +51,7 @@ import Unison.Util.Monoid (foldMapM)
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Relation qualified as Relation
 
-type OptionFetcher = Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text]
+type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text]
 
 data FZFResolver = FZFResolver
   { getOptions :: OptionFetcher
@@ -121,7 +121,7 @@ fuzzySelectFromList options =
 -- | Combine multiple option fetchers into one resolver.
 multiResolver :: [OptionFetcher] -> FZFResolver
 multiResolver resolvers =
-  let getOptions :: Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text]
+  let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text]
       getOptions codebase projCtx searchBranch0 = do
         List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers
    in (FZFResolver {getOptions})
@@ -177,11 +177,8 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do
 -- E.g. '@unison/base/main'
 projectBranchOptionsWithinCurrentProject :: OptionFetcher
 projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
-  case projCtx of
+  Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing)
-    LooseCodePath _ -> pure []
+    <&> fmap (into @Text . snd)
-    ProjectBranchPath currentProjectId _projectBranchId _path -> do
-      Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith currentProjectId Nothing)
-        <&> fmap (into @Text . snd)
 
 -- | Exported from here just so the debug command and actual implementation can use the same
 -- messaging.

unison-cli/src/Unison/CommandLine/InputPattern.hs

@@ -28,7 +28,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
 import Unison.Codebase (Codebase)
 import Unison.Codebase.Editor.Input (Input (..))
 import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
-import Unison.Codebase.Path as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.CommandLine.FZFResolvers (FZFResolver (..))
 import Unison.Prelude
 import Unison.Util.ColorText qualified as CT
@@ -78,7 +78,7 @@ data ArgumentType = ArgumentType
       String ->
       Codebase m v a ->
       AuthenticatedHttpClient ->
-      Path.Absolute -> -- Current path
+      PP.ProjectPath ->
       m [Line.Completion],
     -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if
     -- available.
@@ -157,14 +157,14 @@ unionSuggestions ::
   [ ( String ->
       Codebase m v a ->
       AuthenticatedHttpClient ->
-      Path.Absolute ->
+      PP.ProjectPath ->
       m [Line.Completion]
     )
   ] ->
   ( String ->
     Codebase m v a ->
     AuthenticatedHttpClient ->
-    Path.Absolute ->
+    PP.ProjectPath ->
     m [Line.Completion]
   )
 unionSuggestions suggesters inp codebase httpClient path = do
@@ -179,14 +179,14 @@ suggestionFallbacks ::
   [ ( String ->
       Codebase m v a ->
       AuthenticatedHttpClient ->
-      Path.Absolute ->
+      PP.ProjectPath ->
       m [Line.Completion]
     )
   ] ->
   ( String ->
     Codebase m v a ->
     AuthenticatedHttpClient ->
-    Path.Absolute ->
+    PP.ProjectPath ->
     m [Line.Completion]
   )
 suggestionFallbacks suggesters inp codebase httpClient path = go suggesters

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -138,7 +138,6 @@ module Unison.CommandLine.InputPatterns
   )
 where
 
-import Control.Lens (preview, review)
 import Control.Lens.Cons qualified as Cons
 import Data.Bitraversable (bitraverse)
 import Data.List (intercalate)
@@ -168,14 +167,13 @@ import Unison.Cli.Pretty
     prettySlashProjectBranchName,
     prettyURI,
   )
-import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch.Merge qualified as Branch
-import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input)
+import Unison.Codebase.Editor.Input (BranchIdG (..), DeleteOutput (..), DeleteTarget (..), Input)
 import Unison.Codebase.Editor.Input qualified as Input
 import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
-import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
+import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
 import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
 import Unison.Codebase.Editor.SlurpResult qualified as SR
 import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
@@ -185,6 +183,8 @@ import Unison.Codebase.Editor.UriParser qualified as UriParser
 import Unison.Codebase.Path (Path, Path')
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPath)
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.PushBehavior qualified as PushBehavior
 import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
@@ -213,7 +213,6 @@ import Unison.Project
     Semver,
     branchWithOptionalProjectParser,
   )
-import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
 import Unison.Referent qualified as Referent
 import Unison.Server.Backend (ShallowListEntry (..))
 import Unison.Server.Backend qualified as Backend
@@ -249,8 +248,13 @@ formatStructuredArgument schLength = \case
     -- prefixBranchId ".base" "List.map" -> ".base.List.map"
     prefixBranchId :: Input.AbsBranchId -> Name -> Text
     prefixBranchId branchId name = case branchId of
-      Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
+      BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
-      Right pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
+      BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
+      BranchAtProjectPath pp ->
+        pp
+          & PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
+          & PP.toNames
+          & into @Text
 
     entryToHQText :: Path' -> ShallowListEntry v Ann -> Text
     entryToHQText pathArg =
@@ -365,15 +369,6 @@ handleProjectArg =
       SA.Project project -> pure project
       otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType
 
-handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject
-handleLooseCodeOrProjectArg =
-  either
-    (maybe (Left $ P.text "invalid path or project branch") pure . parseLooseCodeOrProject)
-    \case
-      SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path
-      SA.ProjectBranch pb -> pure $ That pb
-      otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType
-
 handleMaybeProjectBranchArg ::
   I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
 handleMaybeProjectBranchArg =
@@ -468,8 +463,8 @@ handleSplit'Arg =
     (first P.text . Path.parseSplit')
     \case
       SA.Name name -> pure $ Path.splitFromName' name
-      SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name
+      SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name
-      SA.NameWithBranchPrefix (Right prefix) name ->
+      SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
         pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
       otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg
 
@@ -486,27 +481,34 @@ handleBranchIdArg =
   either
     (first P.text . Input.parseBranchId)
     \case
-      SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path
+      SA.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path
-      SA.Name name -> pure . pure $ Path.fromName' name
+      SA.Name name -> pure . BranchAtPath $ Path.fromName' name
       SA.NameWithBranchPrefix mprefix name ->
-        pure . pure . Path.fromName' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') name mprefix
+        pure $ case mprefix of
-      SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
+          BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name
+          BranchAtPath prefix -> BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
+          BranchAtProjectPath pp ->
+            pp
+              & PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
+              & BranchAtProjectPath
+      SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash
       otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
 
-handleBranchIdOrProjectArg ::
+-- | TODO: Maybe remove?
+_handleBranchIdOrProjectArg ::
   I.Argument ->
   Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
-handleBranchIdOrProjectArg =
+_handleBranchIdOrProjectArg =
   either
     (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject)
     \case
-      SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash
+      SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash
-      SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path
+      SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path
-      SA.Name name -> pure . This . pure $ Path.fromName' name
+      SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name
+      SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Right prefix) name ->
+      SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
-        pure . This . pure . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
+        pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
-      SA.ProjectBranch pb -> pure $ pure pb
+      SA.ProjectBranch pb -> pure $ That pb
       otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType
   where
     branchIdOrProject ::
@@ -533,13 +535,15 @@ handleBranchId2Arg =
     Input.parseBranchId2
     \case
       SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
-      SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path
+      SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path
-      SA.Name name -> pure . pure . LoosePath $ Path.fromName' name
+      SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name
+      SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Right prefix) name ->
+      SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
-        pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
+        pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
       SA.ProjectBranch (ProjectAndBranch mproject branch) ->
-        pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
+        case mproject of
+          Just proj -> pure . pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
+          Nothing -> pure . pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
       otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
 
 handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath
@@ -547,13 +551,15 @@ handleBranchRelativePathArg =
   either
     parseBranchRelativePath
     \case
-      SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path
+      SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path
-      SA.Name name -> pure . LoosePath $ Path.fromName' name
+      SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name
+      SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name
-      SA.NameWithBranchPrefix (Right prefix) name ->
+      SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
-        pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
+        pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
       SA.ProjectBranch (ProjectAndBranch mproject branch) ->
-        pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
+        case mproject of
+          Just proj -> pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
+          Nothing -> pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
       otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
 
 hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit'
@@ -585,8 +591,8 @@ handleHashQualifiedSplit'Arg =
     \case
       SA.Name name -> pure $ Path.hqSplitFromName' name
       hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name
-      SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname
+      SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname
-      SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
+      SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
         pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
       SA.ShallowListEntry prefix entry ->
         pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@@ -608,8 +614,8 @@ handleHashQualifiedSplitArg =
           pure
           $ Path.hqSplitFromName' name
       hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name
-      SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname
+      SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname
-      SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
+      SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
         pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
       SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry
       sr@(SA.SearchResult mpath result) ->
@@ -631,8 +637,8 @@ handleShortHashOrHQSplit'Arg =
     (first P.text . Path.parseShortHashOrHQSplit')
     \case
       SA.HashQualified name -> pure $ hqNameToSplit' name
-      SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname
+      SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname
-      SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
+      SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
         pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname)
       SA.ShallowListEntry prefix entry ->
         pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@@ -653,11 +659,11 @@ handleNameArg =
     (first P.text . Name.parseTextEither . Text.pack)
     \case
       SA.Name name -> pure name
-      SA.NameWithBranchPrefix (Left _) name -> pure name
+      SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name
-      SA.NameWithBranchPrefix (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
+      SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
       SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname
-      SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname
+      SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname
-      SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
+      SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
         pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname
       SA.ShallowListEntry prefix entry ->
         pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@@ -681,11 +687,11 @@ handlePullSourceArg =
       otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg
 
 handlePushTargetArg ::
-  I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName))
+  I.Argument -> Either (P.Pretty CT.ColorText) (These ProjectName ProjectBranchName)
 handlePushTargetArg =
   either
     (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget)
-    $ fmap RemoteRepo.WriteRemoteProjectBranch . \case
+    $ \case
       SA.Project project -> pure $ This project
       SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch
       otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
@@ -695,11 +701,6 @@ handlePushSourceArg =
   either
     (maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource)
     \case
-      SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path
-      SA.Name name -> pure . Input.PathySource $ Path.fromName' name
-      SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name
-      SA.NameWithBranchPrefix (Right prefix) name ->
-        pure . Input.PathySource . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
       SA.Project project -> pure . Input.ProjySource $ This project
       SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch
       otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
@@ -1539,8 +1540,7 @@ deleteNamespaceForce =
 
 deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input
 deleteNamespaceParser helpText insistence = \case
-  [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
+  [p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> handleSplitArg p
-  [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p
   _ -> Left helpText
 
 renameBranch :: InputPattern
@@ -1573,7 +1573,7 @@ history =
     )
     \case
       [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src
-      [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath)
+      [] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.currentPath)
       _ -> Left (I.help history)
 
 forkLocal :: InputPattern
@@ -1649,8 +1649,8 @@ reset =
         ]
     )
     \case
-      [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing
+      [arg0] -> Input.ResetI <$> handleBranchIdArg arg0 <*> pure Nothing
-      [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1)
+      [arg0, arg1] -> Input.ResetI <$> handleBranchIdArg arg0 <*> fmap pure (handleMaybeProjectBranchArg arg1)
       _ -> Left $ I.help reset
   where
     config =
@@ -2052,10 +2052,15 @@ mergeOldSquashInputPattern =
             <> "The resulting `dest` will have (at most) 1"
             <> "additional history entry.",
       parse = \case
+        [src] ->
+          Input.MergeLocalBranchI
+            <$> handleBranchRelativePathArg src
+            <*> pure Nothing
+            <*> pure Branch.SquashMerge
         [src, dest] ->
           Input.MergeLocalBranchI
-            <$> handleLooseCodeOrProjectArg src
+            <$> handleBranchRelativePathArg src
-            <*> handleLooseCodeOrProjectArg dest
+            <*> (Just <$> handleBranchRelativePathArg dest)
             <*> pure Branch.SquashMerge
         _ -> Left $ I.help mergeOldSquashInputPattern
     }
@@ -2088,25 +2093,19 @@ mergeOldInputPattern =
           ),
           ( makeExample mergeOldInputPattern ["/topic", "foo/main"],
             "merges the branch `topic` of the current project into the `main` branch of the project 'foo`"
-          ),
-          ( makeExample mergeOldInputPattern [".src"],
-            "merges `.src` namespace into the current namespace"
-          ),
-          ( makeExample mergeOldInputPattern [".src", ".dest"],
-            "merges `.src` namespace into the `dest` namespace"
           )
         ]
     )
     ( \case
         [src] ->
           Input.MergeLocalBranchI
-            <$> handleLooseCodeOrProjectArg src
+            <$> handleBranchRelativePathArg src
-            <*> pure (This Path.relativeEmpty')
+            <*> pure Nothing
             <*> pure Branch.RegularMerge
         [src, dest] ->
           Input.MergeLocalBranchI
-            <$> handleLooseCodeOrProjectArg src
+            <$> handleBranchRelativePathArg src
-            <*> handleLooseCodeOrProjectArg dest
+            <*> (Just <$> handleBranchRelativePathArg dest)
             <*> pure Branch.RegularMerge
         _ -> Left $ I.help mergeOldInputPattern
     )
@@ -2185,17 +2184,6 @@ mergeCommitInputPattern =
         _ -> Left (I.help mergeCommitInputPattern)
     }
 
-parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject
-parseLooseCodeOrProject inputString =
-  case (asLooseCode, asBranch) of
-    (Right path, Left _) -> Just (This path)
-    (Left _, Right branch) -> Just (That branch)
-    (Right path, Right branch) -> Just (These path branch)
-    (Left _, Left _) -> Nothing
-  where
-    asLooseCode = Path.parsePath' inputString
-    asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString)
-
 diffNamespace :: InputPattern
 diffNamespace =
   InputPattern
@@ -2214,7 +2202,7 @@ diffNamespace =
     )
     ( \case
         [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after
-        [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath)
+        [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (BranchAtPath Path.currentPath)
         _ -> Left $ I.help diffNamespace
     )
   where
@@ -2242,9 +2230,9 @@ mergeOldPreviewInputPattern =
         ]
     )
     ( \case
-        [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty')
+        [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing
         [src, dest] ->
-          Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest
+          Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest)
         _ -> Left $ I.help mergeOldPreviewInputPattern
     )
   where
@@ -3139,13 +3127,12 @@ branchInputPattern =
       help =
         P.wrapColumn2
           [ ("`branch foo`", "forks the current project branch to a new branch `foo`"),
-            ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"),
+            ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`")
-            ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`")
           ],
       parse = \case
         [source0, name] ->
-          Input.BranchI . Input.BranchSourceI'LooseCodeOrProject
+          Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch
-            <$> handleLooseCodeOrProjectArg source0
+            <$> handleMaybeProjectBranchArg source0
             <*> handleMaybeProjectBranchArg name
         [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name
         _ -> Left $ showPatternHelp branchInputPattern
@@ -3513,7 +3500,7 @@ namespaceOrProjectBranchArg config =
   ArgumentType
     { typeName = "namespace or branch",
       suggestions =
-        let namespaceSuggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p)
+        let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp)
          in unionSuggestions
               [ projectAndOrBranchSuggestions config,
                 namespaceSuggestions
@@ -3539,8 +3526,8 @@ dependencyArg :: ArgumentType
 dependencyArg =
   ArgumentType
     { typeName = "project dependency",
-      suggestions = \q cb _http p -> Codebase.runTransaction cb do
+      suggestions = \q cb _http pp -> Codebase.runTransaction cb do
-        prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
+        prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
       fzfResolver = Just Resolvers.projectDependencyResolver
     }
 
@@ -3599,14 +3586,14 @@ projectAndOrBranchSuggestions ::
   String ->
   Codebase m v a ->
   AuthenticatedHttpClient ->
-  Path.Absolute -> -- Current path
+  ProjectPath ->
   m [Line.Completion]
-projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
+projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do
   case Text.uncons input of
     -- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
     -- handle "/<TAB>" and "/@<TAB>" inputs, which aren't valid branch names, but are valid branch prefixes. So,
     -- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix.
-    Just ('/', input1) -> handleBranchesComplete input1 codebase path
+    Just ('/', input1) -> handleBranchesComplete input1 codebase pp
     _ ->
       case tryInto @ProjectAndBranchNames input of
         -- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
@@ -3627,12 +3614,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
                 Nothing -> pure []
                 Just project -> do
                   let projectId = project ^. #projectId
-                  fmap (filterBranches config path) do
+                  fmap (filterBranches config pp) do
                     Queries.loadAllProjectBranchesBeginningWith projectId Nothing
           pure (map (projectBranchToCompletion projectName) branches)
         -- This branch is probably dead due to intercepting inputs that begin with "/" above
         Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
-          handleBranchesComplete (into @Text branchName) codebase path
+          handleBranchesComplete (into @Text branchName) codebase pp
         Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
           branches <-
             Codebase.runTransaction codebase do
@@ -3640,16 +3627,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
                 Nothing -> pure []
                 Just project -> do
                   let projectId = project ^. #projectId
-                  fmap (filterBranches config path) do
+                  fmap (filterBranches config pp) do
                     Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
           pure (map (projectBranchToCompletion projectName) branches)
   where
     input = Text.strip . Text.pack $ inputStr
 
-    (mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of
-      LooseCodePath {} -> (Nothing, Nothing)
-      ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
-
     handleAmbiguousComplete ::
       (MonadIO m) =>
       Text ->
@@ -3659,14 +3642,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
       (branches, projects) <-
         Codebase.runTransaction codebase do
           branches <-
-            case mayCurrentProjectId of
+            fmap (filterBranches config pp) do
-              Nothing -> pure []
+              Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
-              Just currentProjectId ->
+          projects <- case projectInclusion config of
-                fmap (filterBranches config path) do
+            OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
-                  Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
-          projects <- case (projectInclusion config, mayCurrentProjectId) of
-            (OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
-            (OnlyWithinCurrentProject, Nothing) -> pure []
             _ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
           pure (branches, projects)
       let branchCompletions = map currentProjectBranchToCompletion branches
@@ -3740,28 +3719,28 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
           then projectCompletions
           else branchCompletions ++ projectCompletions
 
-    handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion]
+    -- Complete the text into a branch name within the provided project
-    handleBranchesComplete branchName codebase path = do
+    handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
+    handleBranchesComplete branchName codebase pp = do
+      let projId = pp ^. #project . #projectId
       branches <-
-        case preview ProjectUtils.projectBranchPathPrism path of
+        Codebase.runTransaction codebase do
-          Nothing -> pure []
+          fmap (filterBranches config pp) do
-          Just (ProjectAndBranch currentProjectId _, _) ->
+            Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
-            Codebase.runTransaction codebase do
-              fmap (filterBranches config path) do
-                Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
       pure (map currentProjectBranchToCompletion branches)
 
     filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
     filterProjects projects =
-      case (mayCurrentProjectId, projectInclusion config) of
+      case (projectInclusion config) of
-        (_, AllProjects) -> projects
+        AllProjects -> projects
-        (Nothing, _) -> projects
+        OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
-        (Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
+        OnlyWithinCurrentProject ->
-        (Just currentBranchId, OnlyWithinCurrentProject) ->
           projects
-            & List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
+            & List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
             & maybeToList
 
+    PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp
+
 projectToCompletion :: Sqlite.Project -> Completion
 projectToCompletion project =
   Completion
@@ -3785,28 +3764,22 @@ handleBranchesComplete ::
   ProjectBranchSuggestionsConfig ->
   Text ->
   Codebase m v a ->
-  Path.Absolute ->
+  PP.ProjectPath ->
   m [Completion]
-handleBranchesComplete config branchName codebase path = do
+handleBranchesComplete config branchName codebase pp = do
   branches <-
-    case preview ProjectUtils.projectBranchPathPrism path of
+    Codebase.runTransaction codebase do
-      Nothing -> pure []
+      fmap (filterBranches config pp) do
-      Just (ProjectAndBranch currentProjectId _, _) ->
+        Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName)
-        Codebase.runTransaction codebase do
-          fmap (filterBranches config path) do
-            Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
   pure (map currentProjectBranchToCompletion branches)
 
-filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
+filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
-filterBranches config path branches =
+filterBranches config pp branches =
-  case (mayCurrentBranchId, branchInclusion config) of
+  case (branchInclusion config) of
-    (_, AllBranches) -> branches
+    AllBranches -> branches
-    (Nothing, _) -> branches
+    ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
-    (Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
   where
-    (_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of
+    currentBranchId = pp ^. #branch . #branchId
-      LooseCodePath {} -> (Nothing, Nothing)
-      ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
 
 currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
 currentProjectBranchToCompletion (_, branchName) =
@@ -3822,22 +3795,22 @@ branchRelativePathSuggestions ::
   String ->
   Codebase m v a ->
   AuthenticatedHttpClient ->
-  Path.Absolute -> -- Current path
+  PP.ProjectPath ->
   m [Line.Completion]
-branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do
+branchRelativePathSuggestions config inputStr codebase _httpClient pp = do
   case parseIncrementalBranchRelativePath inputStr of
     Left _ -> pure []
     Right ibrp -> case ibrp of
-      BranchRelativePath.ProjectOrRelative _txt _path -> do
+      BranchRelativePath.ProjectOrPath' _txt _path -> do
-        namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
+        namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
         projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
         pure (namespaceSuggestions ++ projectSuggestions)
-      BranchRelativePath.LooseCode _path ->
+      BranchRelativePath.OnlyPath' _path ->
-        Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
+        Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
       BranchRelativePath.IncompleteProject _proj ->
         projectNameSuggestions WithSlash inputStr codebase
       BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
-        Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath
+        Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp
         Just projectName -> do
           branches <-
             Codebase.runTransaction codebase do
@@ -3845,44 +3818,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath =
                 Nothing -> pure []
                 Just project -> do
                   let projectId = project ^. #projectId
-                  fmap (filterBranches config currentPath) do
+                  fmap (filterBranches config pp) do
                     Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
           pure (map (projectBranchToCompletionWithSep projectName) branches)
       BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
-        mprojectBranch <- runMaybeT do
+        -- TODO: Verify this works as intended, might need to use an absolute path instead.
-          (projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId)
+        map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) pp
-          MaybeT (Queries.loadProjectBranch projectId branchId)
-        case mprojectBranch of
-          Nothing -> pure []
-          Just projectBranch -> do
-            let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
-                projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
-            map prefixPathSep
-              <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath
       BranchRelativePath.IncompletePath projStuff mpath -> do
         Codebase.runTransaction codebase do
-          mprojectBranch <- runMaybeT do
+          map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp
-            case projStuff of
-              Left names@(ProjectAndBranch projectName branchName) -> do
-                (,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName)
-              Right branchName -> do
-                currentProjectId <- MaybeT (pure mayCurrentProjectId)
-                projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName)
-                pure (projectBranch, Right (projectBranch ^. #name))
-          case mprojectBranch of
-            Nothing -> pure []
-            Just (projectBranch, prefix) -> do
-              let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
-                  projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
-              map (addBranchPrefix prefix)
-                <$> prefixCompleteNamespace
-                  (maybe "" (Text.unpack . Path.toText' . Path.RelativePath') mpath)
-                  branchPath
   where
-    (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of
-      LooseCodePath {} -> (Nothing, Nothing)
-      ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
-
     projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
     projectBranchToCompletionWithSep projectName (_, branchName) =
       Completion
@@ -4007,12 +3952,11 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do
 parsePushSource :: String -> Maybe Input.PushSource
 parsePushSource sourceStr =
   fixup Input.ProjySource (tryFrom $ Text.pack sourceStr)
-    <|> fixup Input.PathySource (Path.parsePath' sourceStr)
   where
     fixup = either (const Nothing) . (pure .)
 
 -- | Parse a push target.
-parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName))
+parsePushTarget :: String -> Maybe (These ProjectName ProjectBranchName)
 parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack
 
 parseHashQualifiedName ::

unison-cli/src/Unison/CommandLine/Main.hs

@@ -6,10 +6,12 @@ where
 import Compat (withInterruptHandler)
 import Control.Concurrent.Async qualified as Async
 import Control.Exception (catch, displayException, finally, mask)
-import Control.Lens (preview, (?~))
+import Control.Lens ((?~))
+import Control.Lens.Lens
 import Crypto.Random qualified as Random
 import Data.Configurator.Types (Config)
 import Data.IORef
+import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
 import Ki qualified
@@ -19,23 +21,22 @@ import System.Console.Haskeline.History qualified as Line
 import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin)
 import System.IO.Error (isDoesNotExistError)
 import U.Codebase.HashTags (CausalHash)
-import U.Codebase.Sqlite.Operations qualified as Operations
-import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Auth.CredentialManager (newCredentialManager)
 import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
 import Unison.Auth.HTTPClient qualified as AuthN
 import Unison.Auth.Tokens qualified as AuthN
 import Unison.Cli.Monad qualified as Cli
-import Unison.Cli.Pretty (prettyProjectAndBranchName)
+import Unison.Cli.Pretty qualified as P
-import Unison.Cli.ProjectUtils (projectBranchPathPrism)
+import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Branch (Branch)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Editor.HandleInput qualified as HandleInput
 import Unison.Codebase.Editor.Input (Event, Input (..))
 import Unison.Codebase.Editor.Output (NumberedArgs, Output)
 import Unison.Codebase.Editor.UCMVersion (UCMVersion)
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Runtime qualified as Runtime
 import Unison.CommandLine
 import Unison.CommandLine.Completion (haskelineTabComplete)
@@ -46,7 +47,6 @@ import Unison.CommandLine.Welcome qualified as Welcome
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.PrettyTerminal
-import Unison.Project (ProjectAndBranch (..))
 import Unison.Runtime.IOSource qualified as IOSource
 import Unison.Server.CodebaseServer qualified as Server
 import Unison.Symbol (Symbol)
@@ -60,10 +60,11 @@ import UnliftIO.STM
 getUserInput ::
   Codebase IO Symbol Ann ->
   AuthenticatedHttpClient ->
-  Path.Absolute ->
+  PP.ProjectPath ->
+  IO (Branch IO) ->
   NumberedArgs ->
   IO Input
-getUserInput codebase authHTTPClient currentPath numberedArgs =
+getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs =
   Line.runInputT
     settings
     (haskelineCtrlCHandling go)
@@ -78,23 +79,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
         Just a -> pure a
     go :: Line.InputT IO Input
     go = do
-      promptString <-
+      let promptString = P.prettyProjectPath pp
-        case preview projectBranchPathPrism currentPath of
-          Nothing -> pure ((P.green . P.shown) currentPath)
-          Just (ProjectAndBranch projectId branchId, restPath) -> do
-            lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case
-              -- If the project branch has been deleted from sqlite, just show a borked prompt
-              Nothing -> P.red "???"
-              Just (projectName, branchName) ->
-                P.sep
-                  " "
-                  ( catMaybes
-                      [ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)),
-                        case restPath of
-                          Path.Empty -> Nothing
-                          _ -> (Just . P.green . P.shown) restPath
-                      ]
-                  )
       let fullPrompt = P.toANSI 80 (promptString <> fromString prompt)
       line <- Line.getInputLine fullPrompt
       case line of
@@ -102,7 +87,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
         Just l -> case words l of
           [] -> go
           ws -> do
-            liftIO (parseInput codebase currentPath numberedArgs IP.patternMap ws) >>= \case
+            liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case
               Left msg -> do
                 -- We still add history that failed to parse so the user can easily reload
                 -- the input and fix it.
@@ -126,12 +111,20 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
           historyFile = Just ".unisonHistory",
           autoAddHistory = False
         }
-    tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
+    tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient pp
+
+loopStateProjectPath ::
+  Codebase IO Symbol Ann ->
+  Cli.LoopState ->
+  IO PP.ProjectPath
+loopStateProjectPath codebase loopState = do
+  let ppIds = NEL.head $ Cli.projectPathStack loopState
+  ppIds & PP.projectAndBranch_ %%~ \pabIds -> liftIO . Codebase.runTransaction codebase $ ProjectUtils.expectProjectAndBranchByIds pabIds
 
 main ::
   FilePath ->
   Welcome.Welcome ->
-  Path.Absolute ->
+  PP.ProjectPathIds ->
   Config ->
   [Either Event Input] ->
   Runtime.Runtime Symbol ->
@@ -141,25 +134,24 @@ main ::
   Maybe Server.BaseUrl ->
   UCMVersion ->
   (CausalHash -> STM ()) ->
-  (Path.Absolute -> STM ()) ->
+  (PP.ProjectPath -> STM ()) ->
   ShouldWatchFiles ->
   IO ()
-main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do
+main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do
   rootVar <- newEmptyTMVarIO
-  initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash
   _ <- Ki.fork scope do
-    root <- Codebase.getRootBranch codebase
+    projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch
     atomically do
       -- Try putting the root, but if someone else as already written over the root, don't
       -- overwrite it.
-      void $ tryPutTMVar rootVar root
+      void $ tryPutTMVar rootVar projectRoot
     -- Start forcing thunks in a background thread.
     -- This might be overly aggressive, maybe we should just evaluate the top level but avoid
     -- recursive "deep*" things.
     UnliftIO.concurrently_
-      (UnliftIO.evaluate root)
+      (UnliftIO.evaluate projectRoot)
       (UnliftIO.evaluate IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup
-  let initialState = Cli.loopState0 initialRootCausalHash rootVar initialPath
+  let initialState = Cli.loopState0 rootVar ppIds
   Ki.fork_ scope do
     let loop lastRoot = do
           -- This doesn't necessarily notify on _every_ update, but the LSP only needs the
@@ -187,10 +179,13 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
       getInput loopState = do
         currentEcho <- hGetEcho stdin
         liftIO $ restoreEcho currentEcho
+        let getProjectRoot = atomically $ readTMVar rootVar
+        pp <- loopStateProjectPath codebase loopState
         getUserInput
           codebase
           authHTTPClient
-          (loopState ^. #currentPath)
+          pp
+          getProjectRoot
           (loopState ^. #numberedArgs)
   let loadSourceFile :: Text -> IO Cli.LoadSourceResult
       loadSourceFile fname =
@@ -284,7 +279,9 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
               Text.hPutStrLn stderr ("Encountered exception:\n" <> Text.pack (displayException e))
               loop0 s0
             Right (Right (result, s1)) -> do
-              when ((s0 ^. #currentPath) /= (s1 ^. #currentPath :: Path.Absolute)) (atomically . notifyPathChange $ s1 ^. #currentPath)
+              oldPP <- loopStateProjectPath codebase s0
+              newPP <- loopStateProjectPath codebase s1
+              when (oldPP /= newPP) (atomically . notifyPathChange $ newPP)
               case result of
                 Cli.Success () -> loop0 s1
                 Cli.Continue -> loop0 s1

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -42,7 +42,6 @@ import Unison.Auth.Types qualified as Auth
 import Unison.Builtin.Decls qualified as DD
 import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
 import Unison.Cli.Pretty
-import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
 import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
 import Unison.Codebase.Editor.Input qualified as Input
@@ -60,15 +59,12 @@ import Unison.Codebase.Editor.Output
 import Unison.Codebase.Editor.Output qualified as E
 import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD
 import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
-import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..))
-import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
 import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
 import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
 import Unison.Codebase.Editor.StructuredArgument qualified as SA
 import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
 import Unison.Codebase.Patch qualified as Patch
 import Unison.Codebase.Path qualified as Path
-import Unison.Codebase.PushBehavior qualified as PushBehavior
 import Unison.Codebase.Runtime qualified as Runtime
 import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
@@ -90,7 +86,6 @@ import Unison.LabeledDependency as LD
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment qualified as NameSegment
-import Unison.NameSegment.Internal (NameSegment (NameSegment))
 import Unison.Names (Names (..))
 import Unison.Names qualified as Names
 import Unison.NamesWithHistory qualified as Names
@@ -153,6 +148,7 @@ import Unison.Var (Var)
 import Unison.Var qualified as Var
 import Unison.WatchKind qualified as WK
 import Witch (unsafeFrom)
+import Unison.Codebase.Editor.Input (BranchIdG(..))
 
 reportBugURL :: Pretty
 reportBugURL = "https://github.com/unisonweb/unison/issues/new"
@@ -172,7 +168,7 @@ renderFileName dir = P.group . P.blue . fromString <$> shortenDirectory dir
 notifyNumbered :: NumberedOutput -> (Pretty, NumberedArgs)
 notifyNumbered = \case
   ShowDiffNamespace oldPrefix newPrefix ppe diffOutput ->
-    showDiffNamespace ShowNumbers ppe oldPrefix newPrefix diffOutput
+    showDiffNamespace ShowNumbers ppe (either BranchAtSCH BranchAtProjectPath oldPrefix) (either BranchAtSCH BranchAtProjectPath newPrefix) diffOutput
   ShowDiffAfterDeleteDefinitions ppe diff ->
     first
       ( \p ->
@@ -231,7 +227,7 @@ notifyNumbered = \case
                   <> " to undo the results of this merge."
             ]
       )
-      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
+      (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
   ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput ->
     first
       ( \p ->
@@ -258,7 +254,7 @@ notifyNumbered = \case
                   <> " to undo the results of this merge."
             ]
       )
-      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
+      (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
   ShowDiffAfterMergePreview dest' destAbs ppe diffOutput ->
     first
       ( \p ->
@@ -268,7 +264,7 @@ notifyNumbered = \case
               p
             ]
       )
-      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
+      (showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
   ShowDiffAfterUndo ppe diffOutput ->
     first
       (\p -> P.lines ["Here are the changes I undid", "", p])
@@ -473,7 +469,7 @@ notifyNumbered = \case
     )
     where
       switch = IP.makeExample IP.projectSwitch
-  AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) ->
+  AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) ->
     ( P.wrap
         ( openingLine
             <> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
@@ -513,10 +509,10 @@ notifyNumbered = \case
         E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
       reset = IP.makeExample IP.reset
       relPath0 = prettyPath path
-      absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path)
+      absPath0 = Path.Absolute path
   ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
   ListNamespaceDependencies ppe path' externalDependencies ->
-    ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
+    ( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyProjectPath path') $
         List.intersperse spacer (externalDepsTable externalDependencies),
       numberedArgs
     )
@@ -558,7 +554,7 @@ notifyNumbered = \case
           & fmap (\name -> formatNum (getNameNumber name) <> prettyName name)
           & P.lines
   where
-    absPathToBranchId = Right
+    absPathToBranchId = BranchAtPath
 
 undoTip :: P.Pretty P.ColorText
 undoTip =
@@ -602,13 +598,13 @@ notifyUser dir = \case
         pure
           . P.warnCallout
           $ "The namespace "
-            <> prettyBranchId p0
+            <> either prettySCH prettyProjectPath p0
             <> " is empty. Was there a typo?"
       ps ->
         pure
           . P.warnCallout
           $ "The namespaces "
-            <> P.commas (prettyBranchId <$> ps)
+            <> P.commas (either prettySCH prettyProjectPath <$> ps)
             <> " are empty. Was there a typo?"
   LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
     pure $
@@ -801,7 +797,7 @@ notifyUser dir = \case
       prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
   CreatedNewBranch path ->
     pure $
-      "☝️  The namespace " <> prettyAbsoluteStripProject path <> " is empty."
+      "☝️  The namespace " <> prettyAbsolute path <> " is empty."
   -- RenameOutput rootPath oldName newName r -> do
   --   nameChange "rename" "renamed" oldName newName r
   -- AliasOutput rootPath existingName newName r -> do
@@ -1329,9 +1325,9 @@ notifyUser dir = \case
   MergeAlreadyUpToDate src dest ->
     pure . P.callout "😶" $
       P.wrap $
-        either prettyPath' prettyProjectAndBranchName dest
+        prettyBranchRelativePath dest
           <> "was already up-to-date with"
-          <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".")
+          <> P.group (prettyBranchRelativePath src <> ".")
   MergeAlreadyUpToDate2 aliceAndBob ->
     pure . P.callout "😶" $
       P.wrap $
@@ -1476,9 +1472,9 @@ notifyUser dir = \case
   PreviewMergeAlreadyUpToDate src dest ->
     pure . P.callout "😶" $
       P.wrap $
-        prettyNamespaceKey dest
+        prettyProjectPath dest
           <> "is already up-to-date with"
-          <> P.group (prettyNamespaceKey src <> ".")
+          <> P.group (prettyProjectPath src)
   DumpNumberedArgs schLength args ->
     pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
   HelpMessage pat -> pure $ IP.showPatternHelp pat
@@ -1533,11 +1529,6 @@ notifyUser dir = \case
         <> ( terms <&> \(n, r) ->
                prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r)
            )
-  RefusedToPush pushBehavior path ->
-    (pure . P.warnCallout) case pushBehavior of
-      PushBehavior.ForcePush -> error "impossible: refused to push due to ForcePush?"
-      PushBehavior.RequireEmpty -> expectedEmptyPushDest path
-      PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path
   GistCreated remoteNamespace ->
     pure $
       P.lines
@@ -1599,10 +1590,7 @@ notifyUser dir = \case
   PrintVersion ucmVersion -> pure (P.text ucmVersion)
   ShareError shareError -> pure (prettyShareError shareError)
   ViewOnShare shareRef ->
-    pure $
+    pure $ "View it here: " <> prettyRemoteBranchInfo shareRef
-      "View it here: " <> case shareRef of
-        Left repoPath -> prettyShareLink repoPath
-        Right branchInfo -> prettyRemoteBranchInfo branchInfo
   IntegrityCheck result -> pure $ case result of
     NoIntegrityErrors -> "🎉 No issues detected 🎉"
     IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
@@ -2068,16 +2056,6 @@ notifyUser dir = \case
         <> P.group (P.text (NameSegment.toEscapedText new) <> ",")
         <> "and removed"
         <> P.group (P.text (NameSegment.toEscapedText old) <> ".")
-  LooseCodePushDeprecated ->
-    pure . P.warnCallout $
-      P.lines $
-        [ P.wrap $ "Unison Share's projects are now the new preferred way to store code, and storing code outside of a project has been deprecated.",
-          "",
-          P.wrap $ "Learn how to convert existing code into a project using this guide: ",
-          "https://www.unison-lang.org/docs/tooling/projects-library-migration/",
-          "",
-          "Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`"
-        ]
   MergeFailure path aliceAndBob temp ->
     pure $
       P.lines $
@@ -2150,39 +2128,16 @@ notifyUser dir = \case
   NoMergeInProgress ->
     pure . P.wrap $ "It doesn't look like there's a merge in progress."
 
-expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
-expectedEmptyPushDest namespace =
-  P.lines
-    [ "The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is not empty.",
-      "",
-      "Did you mean to use " <> IP.makeExample' IP.push <> " instead?"
-    ]
-
-expectedNonEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
-expectedNonEmptyPushDest namespace =
-  P.lines
-    [ P.wrap ("The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is empty."),
-      "",
-      P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?")
-    ]
-
 prettyShareError :: ShareError -> Pretty
 prettyShareError =
   P.fatalCallout . \case
-    ShareErrorCheckAndSetPush err -> prettyCheckAndSetPushError err
     ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err
-    ShareErrorFastForwardPush err -> prettyFastForwardPushError err
     ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err
     ShareErrorPull err -> prettyPullError err
     ShareErrorTransport err -> prettyTransportError err
     ShareErrorUploadEntities err -> prettyUploadEntitiesError err
     ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team."
 
-prettyCheckAndSetPushError :: Share.CheckAndSetPushError -> Pretty
-prettyCheckAndSetPushError = \case
-  Share.CheckAndSetPushError'UpdatePath repoInfo err -> prettyUpdatePathError repoInfo err
-  Share.CheckAndSetPushError'UploadEntities err -> prettyUploadEntitiesError err
-
 prettyDownloadEntitiesError :: Share.DownloadEntitiesError -> Pretty
 prettyDownloadEntitiesError = \case
   Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo
@@ -2191,27 +2146,6 @@ prettyDownloadEntitiesError = \case
   Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project
   Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationFailure err
 
-prettyFastForwardPathError :: Share.Path -> Share.FastForwardPathError -> Pretty
-prettyFastForwardPathError path = \case
-  Share.FastForwardPathError'InvalidParentage Share.InvalidParentage {child, parent} ->
-    P.lines
-      [ "The server detected an error in the history being pushed, please report this as a bug in ucm.",
-        "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent
-      ]
-  Share.FastForwardPathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
-  Share.FastForwardPathError'MissingDependencies dependencies -> needDependencies dependencies
-  Share.FastForwardPathError'NoHistory -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare path)
-  Share.FastForwardPathError'NoWritePermission path -> noWritePermissionForPath path
-  Share.FastForwardPathError'NotFastForward _hashJwt -> notFastForward path
-  Share.FastForwardPathError'UserNotFound -> shareUserNotFound (Share.pathRepoInfo path)
-
-prettyFastForwardPushError :: Share.FastForwardPushError -> Pretty
-prettyFastForwardPushError = \case
-  Share.FastForwardPushError'FastForwardPath path err -> prettyFastForwardPathError path err
-  Share.FastForwardPushError'GetCausalHash err -> prettyGetCausalHashByPathError err
-  Share.FastForwardPushError'NotFastForward path -> notFastForward path
-  Share.FastForwardPushError'UploadEntities err -> prettyUploadEntitiesError err
-
 prettyGetCausalHashByPathError :: Share.GetCausalHashByPathError -> Pretty
 prettyGetCausalHashByPathError = \case
   Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath
@@ -2225,21 +2159,6 @@ prettyPullError = \case
   Share.PullError'NoHistoryAtPath sharePath ->
     P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath
 
-prettyUpdatePathError :: Share.RepoInfo -> Share.UpdatePathError -> Pretty
-prettyUpdatePathError repoInfo = \case
-  Share.UpdatePathError'HashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash} ->
-    case (expectedHash, actualHash) of
-      (Nothing, Just _) -> expectedEmptyPushDest (sharePathToWriteRemotePathShare sharePath)
-      _ ->
-        P.wrap $
-          P.text "It looks like someone modified"
-            <> prettySharePath sharePath
-            <> P.text "an instant before you. Pull and try again? 🤞"
-  Share.UpdatePathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
-  Share.UpdatePathError'MissingDependencies dependencies -> needDependencies dependencies
-  Share.UpdatePathError'NoWritePermission path -> noWritePermissionForPath path
-  Share.UpdatePathError'UserNotFound -> shareUserNotFound repoInfo
-
 prettyUploadEntitiesError :: Share.UploadEntitiesError -> Pretty
 prettyUploadEntitiesError = \case
   Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr
@@ -2437,17 +2356,6 @@ shareUserNotFound :: Share.RepoInfo -> Pretty
 shareUserNotFound repoInfo =
   P.wrap ("User" <> prettyRepoInfo repoInfo <> "does not exist.")
 
-sharePathToWriteRemotePathShare :: Share.Path -> WriteRemoteNamespace void
-sharePathToWriteRemotePathShare sharePath =
-  -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share
-  -- client code that doesn't know about WriteRemotePath
-  WriteRemoteNamespaceShare
-    WriteShareRemoteNamespace
-      { server = RemoteRepo.DefaultCodeserver,
-        repo = ShareUserHandle $ Share.unRepoInfo (Share.pathRepoInfo sharePath),
-        path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath))
-      }
-
 formatMissingStuff ::
   (Show tm, Show typ) =>
   [(HQ.HashQualified Name, tm)] ->

unison-cli/src/Unison/LSP.hs

@@ -29,7 +29,7 @@ import System.Environment (lookupEnv)
 import System.IO (hPutStrLn)
 import U.Codebase.HashTags
 import Unison.Codebase
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Runtime (Runtime)
 import Unison.Debug qualified as Debug
 import Unison.LSP.CancelRequest (cancelRequestHandler)
@@ -61,8 +61,14 @@ getLspPort :: IO String
 getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT"
 
 -- | Spawn an LSP server on the configured port.
-spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM CausalHash -> STM (Path.Absolute) -> IO ()
+spawnLsp ::
-spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
+  LspFormattingConfig ->
+  Codebase IO Symbol Ann ->
+  Runtime Symbol ->
+  STM CausalHash ->
+  STM PP.ProjectPath ->
+  IO ()
+spawnLsp lspFormattingConfig codebase runtime latestProjectRootHash latestPath =
   ifEnabled . TCP.withSocketsDo $ do
     lspPort <- getLspPort
     UnliftIO.handleIO (handleFailure lspPort) $ do
@@ -82,7 +88,7 @@ spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
           -- different un-saved state for the same file.
           initVFS $ \vfs -> do
             vfsVar <- newMVar vfs
-            void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath)
+            void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestProjectRootHash latestPath)
   where
     handleFailure :: String -> IOException -> IO ()
     handleFailure lspPort ioerr =
@@ -114,15 +120,15 @@ serverDefinition ::
   Runtime Symbol ->
   Ki.Scope ->
   STM CausalHash ->
-  STM (Path.Absolute) ->
+  STM PP.ProjectPath ->
   ServerDefinition Config
-serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath =
+serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestProjectRootHash latestPath =
   ServerDefinition
     { defaultConfig = defaultLSPConfig,
       configSection = "unison",
       parseConfig = Config.parseConfig,
       onConfigChange = Config.updateConfig,
-      doInitialize = lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath,
+      doInitialize = lspDoInitialize vfsVar codebase runtime scope latestProjectRootHash latestPath,
       staticHandlers = lspStaticHandlers lspFormattingConfig,
       interpretHandler = lspInterpretHandler,
       options = lspOptions
@@ -135,7 +141,7 @@ lspDoInitialize ::
   Runtime Symbol ->
   Ki.Scope ->
   STM CausalHash ->
-  STM (Path.Absolute) ->
+  STM PP.ProjectPath ->
   LanguageContextEnv Config ->
   Msg.TMessage 'Msg.Method_Initialize ->
   IO (Either Msg.ResponseError Env)
@@ -152,7 +158,7 @@ lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspConte
         Env
           { ppedCache = atomically $ readTMVar ppedCacheVar,
             currentNamesCache = atomically $ readTMVar currentNamesCacheVar,
-            currentPathCache = atomically $ readTMVar currentPathCacheVar,
+            currentProjectPathCache = atomically $ readTMVar currentPathCacheVar,
             nameSearchCache = atomically $ readTMVar nameSearchCacheVar,
             ..
           }

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -77,7 +77,7 @@ import Witherable
 -- | Lex, parse, and typecheck a file.
 checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis)
 checkFile doc = runMaybeT do
-  currentPath <- lift getCurrentPath
+  pp <- lift getCurrentProjectPath
   let fileUri = doc ^. uri
   (fileVersion, contents) <- VFS.getFileContents fileUri
   parseNames <- lift getCurrentNames
@@ -90,7 +90,7 @@ checkFile doc = runMaybeT do
   let parsingEnv =
         Parser.ParsingEnv
           { uniqueNames = uniqueName,
-            uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath,
+            uniqueTypeGuid = Cli.loadUniqueTypeGuid pp,
             names = parseNames
           }
   (notes, parsedFile, typecheckedFile) <- do

unison-cli/src/Unison/LSP/Formatting.hs

@@ -8,6 +8,7 @@ import Language.LSP.Protocol.Lens
 import Language.LSP.Protocol.Message qualified as Msg
 import Language.LSP.Protocol.Types
 import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Formatting
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.LSP.Conversions (lspToURange, uToLspRange)
 import Unison.LSP.FileAnalysis (getFileAnalysis)
 import Unison.LSP.FileAnalysis qualified as FileAnalysis
@@ -30,10 +31,10 @@ formatDefs :: Uri -> Maybe (Set Range {- the ranges to format, if Nothing then f
 formatDefs fileUri mayRangesToFormat =
   fromMaybe [] <$> runMaybeT do
     FileAnalysis {parsedFile = mayParsedFile, typecheckedFile = mayTypecheckedFile} <- getFileAnalysis fileUri
-    currentPath <- lift getCurrentPath
+    pp <- lift getCurrentProjectPath
     Config {formattingWidth} <- lift getConfig
     MaybeT $
-      Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth currentPath mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat)
+      Formatting.formatFile (\uf tf -> FileAnalysis.ppedForFileHelper uf tf) formattingWidth (pp ^. PP.absPath_) mayParsedFile mayTypecheckedFile (Set.map lspToURange <$> mayRangesToFormat)
         <&> (fmap . fmap) uTextReplacementToLSP
   where
     uTextReplacementToLSP :: Formatting.TextReplacement -> TextEdit

unison-cli/src/Unison/LSP/Types.hs

@@ -24,7 +24,7 @@ import Language.LSP.Server
 import Language.LSP.Server qualified as LSP
 import Language.LSP.VFS
 import Unison.Codebase
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Runtime (Runtime)
 import Unison.Debug qualified as Debug
 import Unison.LSP.Orphans ()
@@ -72,7 +72,7 @@ data Env = Env
     currentNamesCache :: IO Names,
     ppedCache :: IO PrettyPrintEnvDecl,
     nameSearchCache :: IO (NameSearch Sqlite.Transaction),
-    currentPathCache :: IO Path.Absolute,
+    currentProjectPathCache :: IO PP.ProjectPath,
     vfsVar :: MVar VFS,
     runtime :: Runtime Symbol,
     -- The information we have for each file.
@@ -129,8 +129,8 @@ data FileAnalysis = FileAnalysis
   }
   deriving stock (Show)
 
-getCurrentPath :: Lsp Path.Absolute
+getCurrentProjectPath :: Lsp PP.ProjectPath
-getCurrentPath = asks currentPathCache >>= liftIO
+getCurrentProjectPath = asks currentProjectPathCache >>= liftIO
 
 getCodebaseCompletions :: Lsp CompletionTree
 getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar

unison-cli/src/Unison/LSP/UCMWorker.hs

@@ -1,19 +1,17 @@
 module Unison.LSP.UCMWorker where
 
-import Control.Monad (guard)
-import Control.Monad.State (liftIO)
-import Control.Monad.Reader.Class (ask)
-import Data.Functor (void)
 import U.Codebase.HashTags
+import Control.Monad.Reader
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath (ProjectPath)
 import Unison.Debug qualified as Debug
 import Unison.LSP.Completion
 import Unison.LSP.Types
 import Unison.LSP.VFS qualified as VFS
 import Unison.Names (Names)
+import Unison.Prelude
 import Unison.PrettyPrintEnv.Names qualified as PPE
 import Unison.PrettyPrintEnvDecl
 import Unison.PrettyPrintEnvDecl.Names qualified as PPED
@@ -27,21 +25,22 @@ ucmWorker ::
   TMVar PrettyPrintEnvDecl ->
   TMVar Names ->
   TMVar (NameSearch Sqlite.Transaction) ->
-  TMVar Path.Absolute ->
+  TMVar ProjectPath ->
   STM CausalHash ->
-  STM Path.Absolute ->
+  STM ProjectPath ->
   Lsp ()
-ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do
+ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestProjectRootHash getLatestProjectPath = do
   Env {codebase, completionsVar} <- ask
-  let loop :: (CausalHash, Path.Absolute) -> Lsp a
+  let loop :: CausalHash -> ProjectPath -> Lsp a
-      loop (currentRoot, currentPath) = do
+      loop currentProjectRootHash currentProjectPath = do
-        Debug.debugM Debug.LSP "LSP path: " currentPath
+        currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch . #projectId) (currentProjectPath ^. #branch . #branchId)
-        currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath)
+        Debug.debugM Debug.LSP "LSP path: " currentProjectPath
+        let currentBranch0 = Branch.head currentBranch
         let currentNames = Branch.toNames currentBranch0
         hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
         let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames)
         atomically $ do
-          writeTMVar currentPathVar currentPath
+          writeTMVar currentPathVar currentProjectPath
           writeTMVar currentNamesVar currentNames
           writeTMVar ppedVar pped
           writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames)
@@ -50,18 +49,18 @@ ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoo
         atomically do
           writeTMVar completionsVar (namesToCompletionTree currentNames)
         Debug.debugLogM Debug.LSP "LSP Initialized"
-        latest <- atomically $ do
+        (latestRootHash, latestProjectPath) <- atomically $ do
-          latestRoot <- getLatestRoot
+          latestRootHash <- getLatestProjectRootHash
-          latestPath <- getLatestPath
+          latestPath <- getLatestProjectPath
-          guard $ (currentRoot /= latestRoot || currentPath /= latestPath)
+          guard $ (currentProjectRootHash /= latestRootHash || currentProjectPath /= latestPath)
-          pure (latestRoot, latestPath)
+          pure (latestRootHash, latestPath)
         Debug.debugLogM Debug.LSP "LSP Change detected"
-        loop latest
+        loop latestRootHash latestProjectPath
-  (rootBranch, currentPath) <- atomically $ do
+  (currentProjectRootHash, currentProjectPath) <- atomically $ do
-    rootBranch <- getLatestRoot
+    latestProjectRootHash <- getLatestProjectRootHash
-    currentPath <- getLatestPath
+    currentProjectPath <- getLatestProjectPath
-    pure (rootBranch, currentPath)
+    pure (latestProjectRootHash, currentProjectPath)
-  loop (rootBranch, currentPath)
+  loop currentProjectRootHash currentProjectPath
   where
     -- This is added in stm-2.5.1, remove this if we upgrade.
     writeTMVar :: TMVar a -> a -> STM ()

unison-cli/src/Unison/Main.hs

@@ -48,6 +48,7 @@ import System.Directory
   )
 import System.Environment (getExecutablePath, getProgName, withArgs)
 import System.Exit qualified as Exit
+import System.Exit qualified as System
 import System.FilePath
   ( replaceExtension,
     takeDirectory,
@@ -61,7 +62,9 @@ import System.IO.Error (catchIOError)
 import System.IO.Temp qualified as Temp
 import System.Path qualified as Path
 import U.Codebase.HashTags (CausalHash)
+import U.Codebase.Sqlite.Operations qualified as SqliteOps
 import U.Codebase.Sqlite.Queries qualified as Queries
+import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Codebase (Codebase, CodebasePath)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Editor.Input qualified as Input
@@ -70,6 +73,7 @@ import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResul
 import Unison.Codebase.Init qualified as CodebaseInit
 import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
 import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Runtime qualified as Rt
 import Unison.Codebase.SqliteCodebase qualified as SC
 import Unison.Codebase.TranscriptParser qualified as TR
@@ -174,7 +178,7 @@ main version = do
                         let noOpRootNotifier _ = pure ()
                         let noOpPathNotifier _ = pure ()
                         let serverUrl = Nothing
-                        let startPath = Nothing
+                        startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
                         launch
                           version
                           currentDir
@@ -185,7 +189,7 @@ main version = do
                           theCodebase
                           [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
                           serverUrl
-                          startPath
+                          (PP.toIds startProjectPath)
                           initRes
                           noOpRootNotifier
                           noOpPathNotifier
@@ -201,7 +205,7 @@ main version = do
                     let noOpRootNotifier _ = pure ()
                     let noOpPathNotifier _ = pure ()
                     let serverUrl = Nothing
-                    let startPath = Nothing
+                    startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
                     launch
                       version
                       currentDir
@@ -212,7 +216,7 @@ main version = do
                       theCodebase
                       [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
                       serverUrl
-                      startPath
+                      (PP.toIds startProjectPath)
                       initRes
                       noOpRootNotifier
                       noOpPathNotifier
@@ -286,33 +290,44 @@ main version = do
             case mrtsStatsFp of
               Nothing -> action
               Just fp -> recordRtsStats fp action
-          Launch isHeadless codebaseServerOpts mayStartingPath shouldWatchFiles -> do
+          Launch isHeadless codebaseServerOpts mayStartingProject shouldWatchFiles -> do
             getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
               withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do
-                startingPath <- case isHeadless of
+                startingProjectPath <- do
-                  WithCLI -> do
+                  -- If the user didn't provide a starting path on the command line, put them in the most recent
-                    -- If the user didn't provide a starting path on the command line, put them in the most recent
+                  -- path they cd'd to
-                    -- path they cd'd to
+                  case mayStartingProject of
-                    case mayStartingPath of
+                    Just startingProject -> do
-                      Just startingPath -> pure startingPath
+                      Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case
-                      Nothing -> do
+                        Nothing -> do
-                        segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace
+                          PT.putPrettyLn $
-                        pure (Path.Absolute (Path.fromList segments))
+                            P.callout
-                  Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath
+                              "❓"
-                rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash)
+                              ( P.lines
-                rootCausalHashVar <- newTVarIO rootCausalHash
+                                  [ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject)
-                pathVar <- newTVarIO startingPath
+                                  ]
+                              )
+                          System.exitFailure
+                        Just pab -> do
+                          pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty
+                    Nothing -> do
+                      Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
+                currentProjectRootCH <- Codebase.runTransaction theCodebase do
+                  currentPP <- Codebase.expectCurrentProjectPath
+                  SqliteOps.expectProjectBranchHead (currentPP.project.projectId) (currentPP.branch.branchId)
+                projectRootHashVar <- newTVarIO currentProjectRootCH
+                projectPathVar <- newTVarIO startingProjectPath
                 let notifyOnRootChanges :: CausalHash -> STM ()
                     notifyOnRootChanges b = do
-                      writeTVar rootCausalHashVar b
+                      writeTVar projectRootHashVar b
-                let notifyOnPathChanges :: Path.Absolute -> STM ()
+                let notifyOnPathChanges :: PP.ProjectPath -> STM ()
-                    notifyOnPathChanges = writeTVar pathVar
+                    notifyOnPathChanges = writeTVar projectPathVar
                 -- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever
                 -- when waiting for input on handles, so if we listen for LSP connections it will
                 -- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on
                 -- Windows when we move to GHC 9.*
                 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224
-                void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar)
+                void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar projectRootHashVar) (readTVar projectPathVar)
                 Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do
                   case exitOption of
                     DoNotExit -> do
@@ -346,7 +361,7 @@ main version = do
                             theCodebase
                             []
                             (Just baseUrl)
-                            (Just startingPath)
+                            (PP.toIds startingProjectPath)
                             initRes
                             notifyOnRootChanges
                             notifyOnPathChanges
@@ -512,9 +527,6 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba
             )
   when (not completed) $ Exit.exitWith (Exit.ExitFailure 1)
 
-defaultInitialPath :: Path.Absolute
-defaultInitialPath = Path.absoluteEmpty
-
 launch ::
   Version ->
   FilePath ->
@@ -525,13 +537,13 @@ launch ::
   Codebase.Codebase IO Symbol Ann ->
   [Either Input.Event Input.Input] ->
   Maybe Server.BaseUrl ->
-  Maybe Path.Absolute ->
+  PP.ProjectPathIds ->
   InitResult ->
   (CausalHash -> STM ()) ->
-  (Path.Absolute -> STM ()) ->
+  (PP.ProjectPath -> STM ()) ->
   CommandLine.ShouldWatchFiles ->
   IO ()
-launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do
+launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult notifyRootChange notifyProjPathChange shouldWatchFiles = do
   showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist
   let isNewCodebase = case initResult of
         CreatedCodebase -> NewlyCreatedCodebase
@@ -541,7 +553,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
    in CommandLine.main
         dir
         welcome
-        (fromMaybe defaultInitialPath mayStartingPath)
+        startingPath
         config
         inputs
         runtime
@@ -551,7 +563,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
         serverBaseUrl
         ucmVersion
         notifyRootChange
-        notifyPathChange
+        notifyProjPathChange
         shouldWatchFiles
 
 newtype MarkdownFile = MarkdownFile FilePath
@@ -571,7 +583,8 @@ getConfigFilePath mcodepath = (</> ".unisonConfig") <$> Codebase.getCodebaseDir
 getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
 getCodebaseOrExit codebasePathOption migrationStrategy action = do
   initOptions <- argsToCodebaseInitOptions codebasePathOption
-  result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions SC.DoLock migrationStrategy \case
+  let cbInit = SC.init
+  result <- CodebaseInit.withOpenOrCreateCodebase cbInit "main" initOptions SC.DoLock migrationStrategy \case
     cbInit@(CreatedCodebase, dir, _) -> do
       pDir <- prettyDir dir
       PT.putPrettyLn' ""

unison-cli/src/Unison/Share/Sync.hs

@@ -6,14 +6,10 @@ module Unison.Share.Sync
     getCausalHashByPath,
     GetCausalHashByPathError (..),
 
-    -- ** Push
+    -- ** Upload
-    checkAndSetPush,
-    CheckAndSetPushError (..),
-    fastForwardPush,
-    FastForwardPushError (..),
     uploadEntities,
 
-    -- ** Pull
+    -- ** Pull/Download
     pull,
     PullError (..),
     downloadEntities,
@@ -26,16 +22,10 @@ import Control.Monad.Except
 import Control.Monad.Reader (ask)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Control.Monad.Trans.Reader qualified as Reader
-import Data.Foldable qualified as Foldable (find)
-import Data.List.NonEmpty (pattern (:|))
-import Data.List.NonEmpty qualified as List (NonEmpty)
-import Data.List.NonEmpty qualified as List.NonEmpty
 import Data.Map qualified as Map
 import Data.Map.NonEmpty (NEMap)
 import Data.Map.NonEmpty qualified as NEMap
 import Data.Proxy
-import Data.Sequence.NonEmpty (NESeq ((:<||)))
-import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|))
 import Data.Set qualified as Set
 import Data.Set.NonEmpty (NESet)
 import Data.Set.NonEmpty qualified as NESet
@@ -65,7 +55,7 @@ import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expect
 import Unison.Share.Sync.Types
 import Unison.Sqlite qualified as Sqlite
 import Unison.Sync.API qualified as Share (API)
-import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash)
+import Unison.Sync.Common (entityToTempEntity, expectEntity, hash32ToCausalHash)
 import Unison.Sync.EntityValidation qualified as EV
 import Unison.Sync.Types qualified as Share
 import Unison.Util.Monoid (foldMapM)
@@ -98,300 +88,6 @@ syncChunkSize = unsafePerformIO $ do
     Nothing -> 50
 {-# NOINLINE syncChunkSize #-}
 
-------------------------------------------------------------------------------------------------------------------------
--- Push
-
--- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the
--- server is missing, too) to Unison Share.
---
--- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation
--- is off, we won't proceed with the push.
-checkAndSetPush ::
-  -- | The Unison Share URL.
-  BaseUrl ->
-  -- | The repo+path to push to.
-  Share.Path ->
-  -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error.
-  -- This prevents accidentally pushing over data that we didn't know was there.
-  Maybe Hash32 ->
-  -- | The hash of our local causal to push.
-  CausalHash ->
-  -- | Callback that's given a number of entities we just uploaded.
-  (Int -> IO ()) ->
-  Cli (Either (SyncError CheckAndSetPushError) ())
-checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do
-  Cli.Env {authHTTPClient} <- ask
-
-  Cli.label \done -> do
-    let failed :: SyncError CheckAndSetPushError -> Cli void
-        failed = done . Left
-
-    let updatePathError :: Share.UpdatePathError -> Cli void
-        updatePathError err =
-          failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err))
-
-    let updatePath :: Cli Share.UpdatePathResponse
-        updatePath = do
-          liftIO request & onLeftM \err -> failed (TransportError err)
-          where
-            request :: IO (Either CodeserverTransportError Share.UpdatePathResponse)
-            request =
-              httpUpdatePath
-                authHTTPClient
-                unisonShareUrl
-                Share.UpdatePathRequest
-                  { path,
-                    expectedHash,
-                    newHash = causalHashToHash32 causalHash
-                  }
-
-    -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it
-    -- needs this causal (UpdatePathMissingDependencies).
-    dependencies <-
-      updatePath >>= \case
-        Share.UpdatePathSuccess -> done (Right ())
-        Share.UpdatePathFailure err ->
-          case err of
-            Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies
-            _ -> updatePathError err
-
-    -- Upload the causal and all of its dependencies.
-    uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err ->
-      failed (CheckAndSetPushError'UploadEntities <$> err)
-
-    -- After uploading the causal and all of its dependencies, try setting the remote path again.
-    updatePath >>= \case
-      Share.UpdatePathSuccess -> pure (Right ())
-      Share.UpdatePathFailure err -> updatePathError err
-
--- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the
--- server is missing, too) to Unison Share.
---
--- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired
--- state.
-fastForwardPush ::
-  -- | The Unison Share URL.
-  BaseUrl ->
-  -- | The repo+path to push to.
-  Share.Path ->
-  -- | The hash of our local causal to push.
-  CausalHash ->
-  -- | Callback that's given a number of entities we just uploaded.
-  (Int -> IO ()) ->
-  Cli (Either (SyncError FastForwardPushError) ())
-fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
-  Cli.label \done -> do
-    let succeeded :: Cli void
-        succeeded =
-          done (Right ())
-
-    let failed :: SyncError FastForwardPushError -> Cli void
-        failed = done . Left
-
-    let fastForwardPathError :: Share.FastForwardPathError -> Cli void
-        fastForwardPathError err =
-          failed (SyncError (FastForwardPushError'FastForwardPath path err))
-
-    remoteHeadHash <-
-      getCausalHashByPath unisonShareUrl path >>= \case
-        Left err -> failed (FastForwardPushError'GetCausalHash <$> err)
-        Right Nothing -> fastForwardPathError Share.FastForwardPathError'NoHistory
-        Right (Just remoteHeadHash) -> pure (Share.hashJWTHash remoteHeadHash)
-
-    let doLoadCausalSpineBetween = do
-          -- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
-          -- actual path.
-          let isBefore :: Sqlite.Transaction Bool
-              isBefore = do
-                maybeHashIds <-
-                  runMaybeT $
-                    (,)
-                      <$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
-                      <*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
-                case maybeHashIds of
-                  Nothing -> pure False
-                  Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
-          isBefore >>= \case
-            False -> pure Nothing
-            True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
-
-    let doUpload :: List.NonEmpty CausalHash -> Cli ()
-        -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes",
-        -- but we don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure
-        -- the server doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server
-        -- needs.
-        doUpload (headHash :| _tailHashes) =
-          request & onLeftM \err -> failed (FastForwardPushError'UploadEntities <$> err)
-          where
-            request =
-              uploadEntities
-                unisonShareUrl
-                (Share.pathRepoInfo path)
-                (NESet.singleton (causalHashToHash32 headHash))
-                uploadedCallback
-
-    localInnerHashes <-
-      Cli.runTransaction doLoadCausalSpineBetween >>= \case
-        -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a
-        -- fast-forward push, so we don't bother trying - just report the error now.
-        Nothing -> failed (SyncError (FastForwardPushError'NotFastForward path))
-        -- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push.
-        Just [] -> succeeded
-        -- drop remote hash
-        Just (_ : localInnerHashes) -> pure (map hash32ToCausalHash localInnerHashes)
-
-    doUpload (localHeadHash :| localInnerHashes)
-
-    let doFastForwardPath :: Cli Share.FastForwardPathResponse
-        doFastForwardPath = do
-          Cli.Env {authHTTPClient} <- ask
-          let request =
-                httpFastForwardPath
-                  authHTTPClient
-                  unisonShareUrl
-                  Share.FastForwardPathRequest
-                    { expectedHash = remoteHeadHash,
-                      hashes =
-                        causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]),
-                      path
-                    }
-          liftIO request & onLeftM \err -> failed (TransportError err)
-
-    doFastForwardPath >>= \case
-      Share.FastForwardPathSuccess -> succeeded
-      Share.FastForwardPathFailure err -> fastForwardPathError err
-
--- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments,
--- excluding the newest hash (second argument).
-loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32])
-loadCausalSpineBetween earlierHash laterHash =
-  dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash
-
-data Step a
-  = DeadEnd
-  | KeepSearching (List.NonEmpty a)
-  | FoundGoal a
-
--- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each
--- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True).
---
--- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because
--- it was provided as an input ;))
---
--- For example, when searching a tree that looks like
---
---                    1
---                   / \
---                  2   3
---                 / \   \
---                4  [5]  6
---
--- (where the goal is marked [5]), we'd return
---
---                Just [5,2]
---
--- And (as another example), if the root node is the goal,
---
---                   [1]
---                   / \
---                  2   3
---                 / \   \
---                4   5   6
---
--- we'd return
---
---                Just []
-dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a])
-dagbfs goal children =
-  let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied,
-      -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet.
-      -- (Otherwise, we wouldn't still be in this loop, we'd return!).
-      --
-      -- For example, say we are exploring the tree
-      --
-      --                    1
-      --                   / \
-      --                  2   3
-      --                 / \   \
-      --                4   5   6
-      --
-      -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below
-      -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children,
-      -- and maybe it doesn't).
-      --
-      -- The loop state, in this case, would be these three paths:
-      --
-      --   [ 4, 2 ]
-      --   [ 5, 2 ]
-      --   [ 6, 3 ]
-      --
-      -- (Note, again, that we do not include the root).
-      go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a))
-      go (path :<|| paths) =
-        -- Step forward from the first path in our loop state (in the example above, [4, 2]).
-        step (List.NonEmpty.head path) >>= \case
-          -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep
-          -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because
-          -- this was the only remaining path.
-          DeadEnd ->
-            case NESeq.nonEmptySeq paths of
-              Nothing -> pure Nothing
-              Just paths' -> go paths'
-          -- If node 4 did have children, then maybe the search tree now looks like this.
-          --
-          --                1
-          --               / \
-          --              2   3
-          --             / \   \
-          --            4   5   6
-          --           / \
-          --          7   8
-          --
-          -- There are two cases to handle:
-          --
-          --   1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path
-          --
-          --        [ 7, 4, 2 ]
-          --
-          --   2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end
-          --      of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four
-          --      paths:
-          --
-          --        [ 5, 2 ]      \ these two are are variable 'paths', the tail of the loop state.
-          --        [ 6, 3 ]      /
-          --        [ 7, 4, 2 ]   \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children
-          --        [ 8, 4, 2 ]   / to itself, making two new paths to search
-          KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys))
-          FoundGoal y -> pure (Just (List.NonEmpty.cons y path))
-
-      -- Step forward from a single node. There are 3 possible outcomes:
-      --
-      --   1. We discover it has no children. (return DeadEnd)
-      --   2. We discover is has children, none of which are a goal. (return KeepSearching)
-      --   3. We discover it has children, (at least) one of which is a goal. (return FoundGoal)
-      step :: a -> m (Step a)
-      step x = do
-        ys0 <- children x
-        pure case List.NonEmpty.nonEmpty ys0 of
-          Nothing -> DeadEnd
-          Just ys ->
-            case Foldable.find goal ys of
-              Nothing -> KeepSearching ys
-              Just y -> FoundGoal y
-   in \root ->
-        if goal root
-          then pure (Just [])
-          else
-            step root >>= \case
-              DeadEnd -> pure Nothing
-              -- lts-18.28 doesn't have List.NonEmpty.singleton
-              KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs))
-              FoundGoal x -> pure (Just [x])
-  where
-    -- Concatenate a seq and a non-empty seq.
-    append :: Seq x -> NESeq x -> NESeq x
-    append = (NESeq.><|)
-
 ------------------------------------------------------------------------------------------------------------------------
 -- Pull
 
@@ -977,16 +673,6 @@ httpGetCausalHashByPath ::
   BaseUrl ->
   Share.GetCausalHashByPathRequest ->
   IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse)
-httpFastForwardPath ::
-  Auth.AuthenticatedHttpClient ->
-  BaseUrl ->
-  Share.FastForwardPathRequest ->
-  IO (Either CodeserverTransportError Share.FastForwardPathResponse)
-httpUpdatePath ::
-  Auth.AuthenticatedHttpClient ->
-  BaseUrl ->
-  Share.UpdatePathRequest ->
-  IO (Either CodeserverTransportError Share.UpdatePathResponse)
 httpDownloadEntities ::
   Auth.AuthenticatedHttpClient ->
   BaseUrl ->
@@ -998,14 +684,10 @@ httpUploadEntities ::
   Share.UploadEntitiesRequest ->
   IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
 ( httpGetCausalHashByPath,
-  httpFastForwardPath,
-  httpUpdatePath,
   httpDownloadEntities,
   httpUploadEntities
   ) =
     let ( httpGetCausalHashByPath
-            Servant.:<|> httpFastForwardPath
-            Servant.:<|> httpUpdatePath
             Servant.:<|> httpDownloadEntities
             Servant.:<|> httpUploadEntities
           ) =
@@ -1013,8 +695,6 @@ httpUploadEntities ::
                 pp = Proxy
              in Servant.hoistClient pp hoist (Servant.client pp)
      in ( go httpGetCausalHashByPath,
-          go httpFastForwardPath,
-          go httpUpdatePath,
           go httpDownloadEntities,
           go httpUploadEntities
         )

unison-cli/src/Unison/Share/Sync/Types.hs

@@ -1,8 +1,6 @@
 -- | Types used by the UCM client during sync.
 module Unison.Share.Sync.Types
-  ( CheckAndSetPushError (..),
+  ( CodeserverTransportError (..),
-    CodeserverTransportError (..),
-    FastForwardPushError (..),
     GetCausalHashByPathError (..),
     PullError (..),
     SyncError (..),
@@ -13,29 +11,6 @@ import Servant.Client qualified as Servant
 import Unison.Prelude
 import Unison.Sync.Types qualified as Share
 
--- | Error used by the client when pushing code to Unison Share.
-data CheckAndSetPushError
-  = CheckAndSetPushError'UpdatePath
-      -- The repo we are pushing to. This is only necessary because an UpdatePathError does not have enough context to
-      -- print the entire error message we want to print, but it really should, at which point maybe this can go away.
-      Share.RepoInfo
-      Share.UpdatePathError
-  | CheckAndSetPushError'UploadEntities Share.UploadEntitiesError
-  deriving stock (Show)
-
--- | An error occurred while fast-forward pushing code to Unison Share.
-data FastForwardPushError
-  = FastForwardPushError'FastForwardPath
-      -- The path we are fast forwarding. This is only necessary because a FastForwardPathError does not have enough
-      -- context to print the entire error message we want to print, but it really should, at which point maybe this can
-      -- go away.
-      Share.Path
-      Share.FastForwardPathError
-  | FastForwardPushError'GetCausalHash GetCausalHashByPathError
-  | FastForwardPushError'NotFastForward Share.Path
-  | FastForwardPushError'UploadEntities Share.UploadEntitiesError
-  deriving stock (Show)
-
 -- | An error occurred while pulling code from Unison Share.
 data PullError
   = PullError'DownloadEntities Share.DownloadEntitiesError

unison-cli/unison-cli.cabal

@@ -47,7 +47,6 @@ library
       Unison.Cli.Share.Projects.Types
       Unison.Cli.TypeCheck
       Unison.Cli.UniqueTypeGuidLookup
-      Unison.Cli.UnisonConfigUtils
       Unison.Codebase.Editor.AuthorInfo
       Unison.Codebase.Editor.HandleInput
       Unison.Codebase.Editor.HandleInput.AddRun

unison-core/src/Unison/Project.hs

@@ -17,6 +17,7 @@ module Unison.Project
     ProjectBranchSpecifier (..),
     ProjectAndBranch (..),
     projectAndBranchNamesParser,
+    fullyQualifiedProjectAndBranchNamesParser,
     projectAndOptionalBranchParser,
     branchWithOptionalProjectParser,
     ProjectAndBranchNames (..),
@@ -414,6 +415,20 @@ projectAndBranchNamesParser specifier = do
             Just branch -> These project branch
         else pure (This project)
 
+-- | Parse a fully specified myproject/mybranch name.
+--
+-- >>> import Text.Megaparsec (parseMaybe)
+-- >>> parseMaybe fullyQualifiedProjectAndBranchNamesParser ("myproject/mybranch" :: Text)
+-- Just (ProjectAndBranch {project = UnsafeProjectName "myproject", branch = UnsafeProjectBranchName "mybranch"})
+fullyQualifiedProjectAndBranchNamesParser :: Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName ProjectBranchName)
+fullyQualifiedProjectAndBranchNamesParser = do
+  (project, hadSlash) <- projectNameParser
+  if hadSlash
+    then pure ()
+    else void $ Megaparsec.char '/'
+  branch <- projectBranchNameParser False
+  pure (ProjectAndBranch project branch)
+
 -- | @project/branch@ syntax, where the branch is optional.
 instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
   from = \case

unison-share-api/src/Unison/Server/Backend.hs

@@ -38,7 +38,7 @@ module Unison.Server.Backend
     lsAtPath,
     lsBranch,
     mungeSyntaxText,
-    resolveCausalHashV2,
+    Codebase.expectCausalBranchByCausalHash,
     resolveRootBranchHashV2,
     namesAtPathFromRootBranchHash,
     termEntryDisplayName,
@@ -58,7 +58,6 @@ module Unison.Server.Backend
     renderDocRefs,
     docsForDefinitionName,
     normaliseRootCausalHash,
-    causalHashForProjectBranchName,
 
     -- * Unused, could remove?
     resolveRootBranchHash,
@@ -101,16 +100,12 @@ import U.Codebase.Branch qualified as V2Branch
 import U.Codebase.Causal qualified as V2Causal
 import U.Codebase.HashTags (BranchHash, CausalHash (..))
 import U.Codebase.Referent qualified as V2Referent
-import U.Codebase.Sqlite.Operations qualified as Operations
 import U.Codebase.Sqlite.Operations qualified as Ops
-import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
-import U.Codebase.Sqlite.Queries qualified as Q
 import Unison.ABT qualified as ABT
 import Unison.Builtin qualified as B
 import Unison.Builtin.Decls qualified as Decls
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
-import Unison.Codebase qualified as UCodebase
 import Unison.Codebase.Branch (Branch)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch
@@ -148,8 +143,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE
 import Unison.PrettyPrintEnv.Util qualified as PPE
 import Unison.PrettyPrintEnvDecl qualified as PPED
 import Unison.PrettyPrintEnvDecl.Names qualified as PPED
-import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
+import Unison.Project (ProjectBranchName, ProjectName)
-import Unison.Project.Util qualified as ProjectUtils
 import Unison.Reference (Reference, TermReference, TypeReference)
 import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
@@ -370,12 +364,12 @@ lsAtPath ::
   (MonadIO m) =>
   Codebase m Symbol Ann ->
   -- The root to follow the path from.
-  Maybe (V2Branch.Branch Sqlite.Transaction) ->
+  V2Branch.Branch Sqlite.Transaction ->
   -- Path from the root to the branch to 'ls'
   Path.Absolute ->
   m [ShallowListEntry Symbol Ann]
-lsAtPath codebase mayRootBranch absPath = do
+lsAtPath codebase rootBranch absPath = do
-  b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) mayRootBranch)
+  b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) rootBranch)
   lsBranch codebase b
 
 findDocInBranch ::
@@ -700,14 +694,12 @@ expandShortCausalHash hash = do
 
 -- | Efficiently resolve a root hash and path to a shallow branch's causal.
 getShallowCausalAtPathFromRootHash ::
-  Maybe CausalHash ->
+  CausalHash ->
   Path ->
   Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-getShallowCausalAtPathFromRootHash mayRootHash path = do
+getShallowCausalAtPathFromRootHash rootHash path = do
-  shallowRoot <- case mayRootHash of
+  shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash
-    Nothing -> Codebase.getShallowRootCausal
+  Codebase.getShallowCausalAtPath path shallowRoot
-    Just h -> Codebase.expectCausalBranchByCausalHash h
-  Codebase.getShallowCausalAtPath path (Just shallowRoot)
 
 formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
 formatType' ppe w =
@@ -987,16 +979,12 @@ namesAtPathFromRootBranchHash ::
   forall m n v a.
   (MonadIO m) =>
   Codebase m v a ->
-  Maybe (V2Branch.CausalBranch n) ->
+  V2Branch.CausalBranch n ->
   Path ->
   Backend m (Names, PPED.PrettyPrintEnvDecl)
-namesAtPathFromRootBranchHash codebase mbh path = do
+namesAtPathFromRootBranchHash codebase cb path = do
   shouldUseNamesIndex <- asks useNamesIndex
-  (rootBranchHash, rootCausalHash) <- case mbh of
+  let (rootBranchHash, rootCausalHash) = (V2Causal.valueHash cb, V2Causal.causalHash cb)
-    Just cb -> pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
-    Nothing -> lift $ do
-      cb <- Codebase.runTransaction codebase Operations.expectRootCausal
-      pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
   haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash)
   hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength
   names <-
@@ -1005,47 +993,34 @@ namesAtPathFromRootBranchHash codebase mbh path = do
         when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash
         lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path
       else do
-        Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash (Just rootCausalHash) codebase
+        Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash rootCausalHash codebase
   let pped = PPED.makePPED (PPE.hqNamer hashLen names) (PPE.suffixifyByHash names)
   pure (names, pped)
 
 resolveCausalHash ::
-  (Monad m) => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m)
+  (Monad m) => CausalHash -> Codebase m v a -> Backend m (Branch m)
-resolveCausalHash h codebase = case h of
+resolveCausalHash bhash codebase = do
-  Nothing -> lift (Codebase.getRootBranch codebase)
+  mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
-  Just bhash -> do
+  whenNothing mayBranch (throwError $ NoBranchForHash bhash)
-    mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
-    whenNothing mayBranch (throwError $ NoBranchForHash bhash)
-
-resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-resolveCausalHashV2 h = case h of
-  Nothing -> Codebase.getShallowRootCausal
-  Just ch -> Codebase.expectCausalBranchByCausalHash ch
 
 resolveRootBranchHash ::
-  (MonadIO m) => Maybe ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
+  (MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
-resolveRootBranchHash mayRoot codebase = case mayRoot of
+resolveRootBranchHash sch codebase = do
-  Nothing ->
+  h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
-    lift (Codebase.getRootBranch codebase)
+  resolveCausalHash h codebase
-  Just sch -> do
-    h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
-    resolveCausalHash (Just h) codebase
 
 resolveRootBranchHashV2 ::
-  Maybe ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
+  ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-resolveRootBranchHashV2 mayRoot = case mayRoot of
+resolveRootBranchHashV2 sch = do
-  Nothing -> lift Codebase.getShallowRootCausal
+  h <- expandShortCausalHash sch
-  Just sch -> do
+  lift (Codebase.expectCausalBranchByCausalHash h)
-    h <- expandShortCausalHash sch
-    lift (resolveCausalHashV2 (Just h))
 
-normaliseRootCausalHash :: Maybe (Either ShortCausalHash CausalHash) -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
+normaliseRootCausalHash :: Either ShortCausalHash CausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-normaliseRootCausalHash mayCh = case mayCh of
+normaliseRootCausalHash = \case
-  Nothing -> lift $ resolveCausalHashV2 Nothing
+  (Left sch) -> do
-  Just (Left sch) -> do
     ch <- expandShortCausalHash sch
-    lift $ resolveCausalHashV2 (Just ch)
+    lift $ Codebase.expectCausalBranchByCausalHash ch
-  Just (Right ch) -> lift $ resolveCausalHashV2 (Just ch)
+  (Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch
 
 -- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?)
 --
@@ -1271,15 +1246,3 @@ loadTypeDisplayObject c = \case
   Reference.DerivedId id ->
     maybe (MissingObject $ Reference.idToShortHash id) UserObject
       <$> Codebase.getTypeDeclaration c id
-
--- | Get the causal hash a given project branch points to
-causalHashForProjectBranchName :: (MonadIO m) => ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe CausalHash)
-causalHashForProjectBranchName (ProjectAndBranch projectName branchName) = do
-  Q.loadProjectBranchByNames projectName branchName >>= \case
-    Nothing -> pure Nothing
-    Just ProjectBranch {projectId, branchId} -> do
-      let path = ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId)
-      -- Use the default codebase root
-      let codebaseRoot = Nothing
-      mayCausal <- UCodebase.getShallowCausalFromRoot codebaseRoot (Path.unabsolute path)
-      pure . Just $ V2Causal.causalHash mayCausal

unison-share-api/src/Unison/Server/CodebaseServer.hs

@@ -84,6 +84,8 @@ import System.Environment (getExecutablePath)
 import System.FilePath ((</>))
 import System.FilePath qualified as FilePath
 import System.Random.MWC (createSystemRandom)
+import U.Codebase.Branch qualified as V2
+import U.Codebase.Causal qualified as Causal
 import U.Codebase.HashTags (CausalHash)
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
@@ -117,16 +119,13 @@ import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, List
 import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer)
 import Unison.Server.NameSearch (NameSearch (..))
 import Unison.Server.NameSearch.FromNames qualified as Names
-import Unison.Server.Types (TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl)
+import Unison.Server.Types (RequiredQueryParam, TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl)
 import Unison.ShortHash qualified as ShortHash
 import Unison.Sqlite qualified as Sqlite
 import Unison.Symbol (Symbol)
 import Unison.Syntax.NameSegment qualified as NameSegment
 import Unison.Util.Pretty qualified as Pretty
 
--- | Fail the route with a reasonable error if the query param is missing.
-type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict]
-
 -- HTML content type
 data HTML = HTML
 
@@ -236,7 +235,7 @@ data DefinitionReference
 data Service
   = LooseCodeUI Path.Absolute (Maybe DefinitionReference)
   | -- (Project branch names, perspective within project, definition reference)
-    ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference)
+    ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference)
   | Api
   deriving stock (Show)
 
@@ -296,13 +295,13 @@ urlFor :: Service -> BaseUrl -> Text
 urlFor service baseUrl =
   case service of
     LooseCodeUI perspective def ->
-      tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path (Path.unabsolute perspective) def)
+      tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path perspective def)
     ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def ->
       tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def)
     Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"]
   where
-    path :: Path.Path -> Maybe DefinitionReference -> [URISegment]
+    path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment]
-    path ns def =
+    path (Path.Absolute ns) def =
       let nsPath = namespacePath ns
        in case definitionPath def of
             Just defPath -> case nsPath of
@@ -565,12 +564,12 @@ serveLooseCode ::
   Rt.Runtime Symbol ->
   ServerT LooseCodeAPI (Backend IO)
 serveLooseCode codebase rt =
-  (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left <$> root) rel name)
+  (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left root) rel name)
-    :<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left <$> mayRoot) renderWidth)
+    :<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left mayRoot) renderWidth)
-    :<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left <$> mayRoot) relativePath rawHqns renderWidth suff)
+    :<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left mayRoot) relativePath rawHqns renderWidth suff)
-    :<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left <$> mayRoot) relativePath limit renderWidth query)
+    :<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left mayRoot) relativePath limit renderWidth query)
-    :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
+    :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
-    :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
+    :<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
 
 serveProjectsCodebaseServerAPI ::
   Codebase IO Symbol Ann ->
@@ -588,34 +587,38 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do
   where
     projectAndBranchName = ProjectAndBranch projectName branchName
     namespaceListingEndpoint _rootParam rel name = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name
+      setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name
     namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth
+      setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth
 
     serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff
+      setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff
 
     serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query
+      setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query
 
     serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
+      setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth
 
     serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
-      root <- resolveProjectRoot codebase projectAndBranchName
+      root <- resolveProjectRootHash codebase projectAndBranchName
-      setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
+      setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth
 
-resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash
+resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO (V2.CausalBranch Sqlite.Transaction)
 resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do
-  mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName
+  mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName
-  case mayCH of
+  case mayCB of
     Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName)
-    Just ch -> pure ch
+    Just cb -> pure cb
+
+resolveProjectRootHash :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash
+resolveProjectRootHash codebase projectAndBranchName = do
+  resolveProjectRoot codebase projectAndBranchName <&> Causal.causalHash
 
 serveProjectDiffTermsEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse
 serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do
@@ -638,7 +641,7 @@ serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef
 
 contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction)
 contextForProjectBranch codebase projectName branchName = do
-  projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName)
+  projectRootHash <- resolveProjectRootHash codebase (ProjectAndBranch projectName branchName)
   projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash
   hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
   let names = Branch.toNames (Branch.head projectRootBranch)

unison-share-api/src/Unison/Server/Local/Definitions.hs

@@ -81,7 +81,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings
   -- ppe which returns names fully qualified to the current perspective,  not to the codebase root.
   let biases = maybeToList $ HQ.toName query
   hqLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
-  (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase (Just shallowRoot) namesRoot
+  (localNamesOnly, unbiasedPPED) <- namesAtPathFromRootBranchHash codebase shallowRoot namesRoot
   let pped = PPED.biasTo biases unbiasedPPED
   let nameSearch = makeNameSearch hqLength localNamesOnly
   (DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do

unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs

@@ -7,17 +7,12 @@ import Data.Aeson
 import Data.OpenApi (ToSchema (..))
 import Servant ((:>))
 import Servant.Docs (ToSample (..))
-import U.Codebase.Sqlite.DbId
-import U.Codebase.Sqlite.Project qualified as Project
-import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
-import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Path qualified as Path
-import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
+import Unison.Codebase.ProjectPath qualified as PP
-import Unison.NameSegment (NameSegment)
+import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
 import Unison.Prelude
-import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment)
 import Unison.Server.Backend
 import Unison.Server.Types (APIGet)
 
@@ -39,7 +34,7 @@ instance ToSample Current where
         Current
           (Just $ UnsafeProjectName "@unison/base")
           (Just $ UnsafeProjectBranchName "main")
-          (Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1")
+          (Path.Absolute $ Path.unsafeParseText ".my.namespace")
       )
     ]
 
@@ -56,26 +51,6 @@ serveCurrent = lift . getCurrentProjectBranch
 
 getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current
 getCurrentProjectBranch codebase = do
-  segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace
+  pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath
-  let absolutePath = toPath segments
+  let (PP.ProjectPath projName branchName path) = PP.toNames pp
-  case toIds segments of
+  pure $ Current (Just projName) (Just branchName) path
-    ProjectAndBranch (Just projectId) branchId ->
-      Codebase.runTransaction codebase do
-        project <- Queries.expectProject projectId
-        branch <- traverse (Queries.expectProjectBranch projectId) branchId
-        pure $ Current (Just $ Project.name project) (ProjectBranch.name <$> branch) absolutePath
-    ProjectAndBranch _ _ ->
-      pure $ Current Nothing Nothing absolutePath
-  where
-    toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId)
-    toIds segments =
-      case segments of
-        ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ ->
-          ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId}
-        ProjectsNameSegment : UUIDNameSegment projectId : _ ->
-          ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing}
-        _ ->
-          ProjectAndBranch {project = Nothing, branch = Nothing}
-
-    toPath :: [NameSegment] -> Path.Absolute
-    toPath = Path.Absolute . Path.fromList

unison-share-api/src/Unison/Server/Local/Endpoints/DefinitionSummary.hs

@@ -48,6 +48,7 @@ import Unison.Server.Backend qualified as Backend
 import Unison.Server.Syntax (SyntaxText)
 import Unison.Server.Types
   ( APIGet,
+    RequiredQueryParam,
     TermTag (..),
     TypeTag,
     mayDefaultWidth,
@@ -67,7 +68,7 @@ type TermSummaryAPI =
     -- It's propagated through to the response as-is.
     -- If missing, the short hash will be used instead.
     :> QueryParam "name" Name
-    :> QueryParam "rootBranch" ShortCausalHash
+    :> RequiredQueryParam "rootBranch" ShortCausalHash
     :> QueryParam "relativeTo" Path.Path
     :> QueryParam "renderWidth" Width
     :> APIGet TermSummary
@@ -98,11 +99,11 @@ serveTermSummary ::
   Codebase IO Symbol Ann ->
   Referent ->
   Maybe Name ->
-  Maybe (Either ShortCausalHash CausalHash) ->
+  Either ShortCausalHash CausalHash ->
   Maybe Path.Path ->
   Maybe Width ->
   Backend IO TermSummary
-serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do
+serveTermSummary codebase referent mayName root relativeTo mayWidth = do
   let shortHash = Referent.toShortHash referent
   let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName
   let relativeToPath = fromMaybe Path.empty relativeTo
@@ -111,7 +112,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do
 
   (root, sig) <-
     Backend.hoistBackend (Codebase.runTransaction codebase) do
-      root <- Backend.normaliseRootCausalHash mayRoot
+      root <- Backend.normaliseRootCausalHash root
       sig <- lift (Backend.loadReferentType codebase referent)
       pure (root, sig)
   case sig of
@@ -126,7 +127,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do
               namesPerspective <- Ops.namesPerspectiveForRootAndPath (V2Causal.valueHash root) (coerce . Path.toList $ fromMaybe Path.Empty relativeTo)
               PPESqlite.ppedForReferences namesPerspective deps
           False -> do
-            (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just root) relativeToPath
+            (_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase root relativeToPath
             pure ppe
       let formattedTermSig = Backend.formatSuffixedType ppe width typeSig
       let summary = mkSummary termReference formattedTermSig
@@ -150,7 +151,7 @@ type TypeSummaryAPI =
     -- It's propagated through to the response as-is.
     -- If missing, the short hash will be used instead.
     :> QueryParam "name" Name
-    :> QueryParam "rootBranch" ShortCausalHash
+    :> RequiredQueryParam "rootBranch" ShortCausalHash
     :> QueryParam "relativeTo" Path.Path
     :> QueryParam "renderWidth" Width
     :> APIGet TypeSummary
@@ -181,7 +182,7 @@ serveTypeSummary ::
   Codebase IO Symbol Ann ->
   Reference ->
   Maybe Name ->
-  Maybe (Either ShortCausalHash CausalHash) ->
+  Either ShortCausalHash CausalHash ->
   Maybe Path.Path ->
   Maybe Width ->
   Backend IO TypeSummary

unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs

@@ -37,6 +37,7 @@ import Unison.Server.Types
     HashQualifiedName,
     NamedTerm,
     NamedType,
+    RequiredQueryParam,
     UnisonName,
     mayDefaultWidth,
   )
@@ -46,7 +47,7 @@ import Unison.Util.Pretty (Width)
 
 type FuzzyFindAPI =
   "find"
-    :> QueryParam "rootBranch" SCH.ShortCausalHash
+    :> RequiredQueryParam "rootBranch" SCH.ShortCausalHash
     :> QueryParam "relativeTo" Path.Path
     :> QueryParam "limit" Int
     :> QueryParam "renderWidth" Width
@@ -141,18 +142,18 @@ serveFuzzyFind ::
   forall m.
   (MonadIO m) =>
   Codebase m Symbol Ann ->
-  Maybe (Either SCH.ShortCausalHash CausalHash) ->
+  Either SCH.ShortCausalHash CausalHash ->
   Maybe Path.Path ->
   Maybe Int ->
   Maybe Width ->
   Maybe String ->
   Backend.Backend m [(FZF.Alignment, FoundResult)]
-serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do
+serveFuzzyFind codebase root relativeTo limit typeWidth query = do
   let path = fromMaybe Path.empty relativeTo
   rootCausal <-
     Backend.hoistBackend (Codebase.runTransaction codebase) do
-      Backend.normaliseRootCausalHash mayRoot
+      Backend.normaliseRootCausalHash root
-  (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path
+  (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal path
   let alignments ::
         ( [ ( FZF.Alignment,
               UnisonName,

unison-share-api/src/Unison/Server/Local/Endpoints/GetDefinitions.hs

@@ -35,6 +35,7 @@ import Unison.Server.Local.Definitions qualified as Local
 import Unison.Server.Types
   ( APIGet,
     DefinitionDisplayResults,
+    RequiredQueryParam,
     Suffixify (..),
     defaultWidth,
   )
@@ -44,7 +45,7 @@ import Unison.Util.Pretty (Width)
 
 type DefinitionsAPI =
   "getDefinition"
-    :> QueryParam "rootBranch" ShortCausalHash
+    :> RequiredQueryParam "rootBranch" ShortCausalHash
     :> QueryParam "relativeTo" Path.Path
     :> QueryParams "names" (HQ.HashQualified Name)
     :> QueryParam "renderWidth" Width
@@ -96,7 +97,7 @@ instance ToParam (QueryParam "namespace" Path.Path) where
       )
       Normal
 
-instance ToParam (QueryParam "rootBranch" ShortCausalHash) where
+instance ToParam (RequiredQueryParam "rootBranch" ShortCausalHash) where
   toParam _ =
     DocQueryParam
       "rootBranch"
@@ -120,15 +121,15 @@ instance ToSample DefinitionDisplayResults where
 serveDefinitions ::
   Rt.Runtime Symbol ->
   Codebase IO Symbol Ann ->
-  Maybe (Either ShortCausalHash CausalHash) ->
+  Either ShortCausalHash CausalHash ->
   Maybe Path.Path ->
   [HQ.HashQualified Name] ->
   Maybe Width ->
   Maybe Suffixify ->
   Backend.Backend IO DefinitionDisplayResults
-serveDefinitions rt codebase mayRoot relativePath hqns width suff =
+serveDefinitions rt codebase root relativePath hqns width suff =
   do
-    rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ mayRoot
+    rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ root
     hqns
       & foldMapM
         ( Local.prettyDefinitionsForHQName