mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 02:55:19 +03:00
Solve conflicts
This commit is contained in:
commit
5f78557170
930
Sync.hs
Normal file
930
Sync.hs
Normal file
@ -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
|
@ -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 mayRootCausalHash =
|
||||
loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
|
||||
loadCausalHashAtPath rootCausalHash =
|
||||
let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
|
||||
go hashId = \case
|
||||
[] -> lift (Q.expectCausalHash hashId)
|
||||
@ -258,15 +251,13 @@ loadCausalHashAtPath mayRootCausalHash =
|
||||
(_, hashId') <- MaybeT (pure (Map.lookup tid children))
|
||||
go hashId' ts
|
||||
in \path -> do
|
||||
hashId <- case mayRootCausalHash of
|
||||
Nothing -> Q.expectNamespaceRoot
|
||||
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
|
||||
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
|
||||
runMaybeT (go hashId path)
|
||||
|
||||
-- | Expect the causal hash at the given path from the provided root, if Nothing, use the
|
||||
-- codebase root.
|
||||
expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash
|
||||
expectCausalHashAtPath mayRootCausalHash =
|
||||
expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash
|
||||
expectCausalHashAtPath rootCausalHash =
|
||||
let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
|
||||
go hashId = \case
|
||||
[] -> Q.expectCausalHash hashId
|
||||
@ -276,23 +267,21 @@ expectCausalHashAtPath mayRootCausalHash =
|
||||
let (_, hashId') = children Map.! tid
|
||||
go hashId' ts
|
||||
in \path -> do
|
||||
hashId <- case mayRootCausalHash of
|
||||
Nothing -> Q.expectNamespaceRoot
|
||||
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
|
||||
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
|
||||
go hashId path
|
||||
|
||||
loadCausalBranchAtPath ::
|
||||
Maybe CausalHash ->
|
||||
CausalHash ->
|
||||
[NameSegment] ->
|
||||
Transaction (Maybe (C.Branch.CausalBranch Transaction))
|
||||
loadCausalBranchAtPath maybeRootCausalHash path =
|
||||
loadCausalHashAtPath maybeRootCausalHash path >>= \case
|
||||
loadCausalBranchAtPath rootCausalHash path =
|
||||
loadCausalHashAtPath rootCausalHash path >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
|
||||
|
||||
loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
|
||||
loadBranchAtPath maybeRootCausalHash path =
|
||||
loadCausalBranchAtPath maybeRootCausalHash path >>= \case
|
||||
loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
|
||||
loadBranchAtPath rootCausalHash path =
|
||||
loadCausalBranchAtPath rootCausalHash path >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just causal -> Just <$> C.Causal.value causal
|
||||
|
||||
@ -613,16 +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
|
||||
|
@ -14,5 +14,5 @@ data Project = Project
|
||||
{ projectId :: !ProjectId,
|
||||
name :: !ProjectName
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
deriving stock (Generic, Show, Eq)
|
||||
deriving anyclass (ToRow, FromRow)
|
||||
|
33
codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs
Normal file
33
codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs
Normal file
@ -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 {..}
|
@ -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
|
||||
expectMostRecentNamespace,
|
||||
setMostRecentNamespace,
|
||||
-- * current project path
|
||||
expectCurrentProjectPath,
|
||||
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 ()
|
||||
createSchema = do
|
||||
runCreateSql :: Transaction ()
|
||||
runCreateSql =
|
||||
executeStatements $(embedProjectStringFile "sql/create.sql")
|
||||
addTempEntityTables
|
||||
addNamespaceStatsTables
|
||||
addReflogTable
|
||||
fixScopedNameLookupTables
|
||||
addProjectTables
|
||||
addMostRecentBranchTable
|
||||
addNameLookupMountTables
|
||||
addMostRecentNamespaceTable
|
||||
execute insertSchemaVersionSql
|
||||
addSquashResultTable
|
||||
where
|
||||
insertSchemaVersionSql =
|
||||
[sql|
|
||||
INSERT INTO schema_version (version)
|
||||
VALUES (:currentSchemaVersion)
|
||||
|]
|
||||
|
||||
addTempEntityTables :: Transaction ()
|
||||
addTempEntityTables =
|
||||
@ -444,6 +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 (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
||||
insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
|
||||
insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
||||
-- Ensure we never point at a causal we don't have the branch for.
|
||||
_ <- expectBranchObjectIdByCausalHashId causalHashId
|
||||
|
||||
execute
|
||||
[sql|
|
||||
INSERT INTO project_branch (project_id, branch_id, name)
|
||||
VALUES (:projectId, :branchId, :branchName)
|
||||
INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
|
||||
VALUES (:projectId, :branchId, :branchName, :causalHashId)
|
||||
|]
|
||||
whenJust maybeParentBranchId \parentBranchId ->
|
||||
execute
|
||||
@ -3816,6 +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]
|
||||
expectMostRecentNamespace =
|
||||
queryOneColCheck
|
||||
expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
|
||||
expectCurrentProjectPath =
|
||||
queryOneRowCheck
|
||||
[sql|
|
||||
SELECT namespace
|
||||
FROM most_recent_namespace
|
||||
SELECT project_id, branch_id, path
|
||||
FROM current_project_path
|
||||
|]
|
||||
check
|
||||
where
|
||||
check :: Text -> Either JsonParseFailure [NameSegment]
|
||||
check bytes =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
|
||||
Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
|
||||
Right namespace -> Right (map NameSegment namespace)
|
||||
check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
|
||||
check (projId, branchId, pathText) =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of
|
||||
Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure}
|
||||
Right namespace -> Right (projId, branchId, map NameSegment namespace)
|
||||
|
||||
-- | Set the most recent namespace the user has visited.
|
||||
setMostRecentNamespace :: [NameSegment] -> Transaction ()
|
||||
setMostRecentNamespace namespace =
|
||||
setCurrentProjectPath ::
|
||||
ProjectId ->
|
||||
ProjectBranchId ->
|
||||
[NameSegment] ->
|
||||
Transaction ()
|
||||
setCurrentProjectPath projId branchId path = do
|
||||
execute
|
||||
[sql| DELETE FROM current_project_path |]
|
||||
execute
|
||||
[sql|
|
||||
UPDATE most_recent_namespace
|
||||
SET namespace = :json
|
||||
INSERT INTO current_project_path(project_id, branch_id, path)
|
||||
VALUES (:projId, :branchId, :jsonPath)
|
||||
|]
|
||||
where
|
||||
json :: Text
|
||||
json =
|
||||
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace)
|
||||
jsonPath :: Text
|
||||
jsonPath =
|
||||
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path)
|
||||
|
||||
-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
|
||||
-- at some point in the past.
|
||||
|
@ -27,6 +27,7 @@ dependencies:
|
||||
- nonempty-containers
|
||||
- safe
|
||||
- text
|
||||
- time
|
||||
- transformers
|
||||
- unison-codebase
|
||||
- unison-codebase-sync
|
||||
|
@ -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;
|
@ -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
|
||||
);
|
||||
|
@ -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;
|
@ -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
|
||||
|
@ -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) ->
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
6
other-thing.md
Normal file
6
other-thing.md
Normal file
@ -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
|
||||
```
|
23
other-thing.output.md
Normal file
23
other-thing.output.md
Normal file
@ -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.
|
||||
|
||||
```
|
@ -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,
|
||||
getShallowRootBranch,
|
||||
getShallowRootCausal,
|
||||
getShallowCausalAtPathFromRootHash,
|
||||
getShallowProjectBranchRoot,
|
||||
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 ::
|
||||
-- Optional root branch, if Nothing use the codebase's root branch.
|
||||
Maybe CausalHash ->
|
||||
getShallowCausalAtPathFromRootHash ::
|
||||
-- Causal to start at, if Nothing use the codebase's root branch.
|
||||
CausalHash ->
|
||||
Path.Path ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalFromRoot mayRootHash p = do
|
||||
rootCausal <- case mayRootHash of
|
||||
Nothing -> getShallowRootCausal
|
||||
Just ch -> Operations.expectCausalBranchByCausalHash ch
|
||||
getShallowCausalAtPath p (Just rootCausal)
|
||||
|
||||
-- | Get the shallow representation of the root branches without loading the children or
|
||||
-- history.
|
||||
getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
||||
getShallowRootBranch = do
|
||||
getShallowRootCausal >>= V2Causal.value
|
||||
|
||||
-- | Get the shallow representation of the root branches without loading the children or
|
||||
-- history.
|
||||
getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction)
|
||||
getShallowRootCausal = do
|
||||
hash <- Operations.expectRootCausalHash
|
||||
Operations.expectCausalBranchByCausalHash hash
|
||||
getShallowCausalAtPathFromRootHash rootCausalHash p = do
|
||||
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
|
||||
getShallowCausalAtPath p rootCausal
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowCausalAtPath ::
|
||||
Path ->
|
||||
Maybe (V2Branch.CausalBranch Sqlite.Transaction) ->
|
||||
(V2Branch.CausalBranch Sqlite.Transaction) ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalAtPath path mayCausal = do
|
||||
causal <- whenNothing mayCausal getShallowRootCausal
|
||||
getShallowCausalAtPath path causal = do
|
||||
case path of
|
||||
Path.Empty -> pure causal
|
||||
ns Path.:< p -> do
|
||||
b <- V2Causal.value causal
|
||||
case V2Branch.childAt ns b of
|
||||
Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
|
||||
Just childCausal -> getShallowCausalAtPath p (Just childCausal)
|
||||
Just childCausal -> getShallowCausalAtPath p childCausal
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowBranchAtPath ::
|
||||
Path ->
|
||||
Maybe (V2Branch.Branch Sqlite.Transaction) ->
|
||||
V2Branch.Branch Sqlite.Transaction ->
|
||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowBranchAtPath path mayBranch = do
|
||||
branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
|
||||
getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getMaybeShallowBranchAtPath ::
|
||||
Path ->
|
||||
V2Branch.Branch Sqlite.Transaction ->
|
||||
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getMaybeShallowBranchAtPath path branch = do
|
||||
case path of
|
||||
Path.Empty -> pure branch
|
||||
Path.Empty -> pure $ Just branch
|
||||
ns Path.:< p -> do
|
||||
case V2Branch.childAt ns branch of
|
||||
Nothing -> pure V2Branch.empty
|
||||
Nothing -> pure Nothing
|
||||
Just childCausal -> do
|
||||
childBranch <- V2Causal.value childCausal
|
||||
getShallowBranchAtPath p (Just childBranch)
|
||||
getMaybeShallowBranchAtPath p childBranch
|
||||
|
||||
-- | Get a v1 branch from the root following the given path.
|
||||
getBranchAtPath ::
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowBranchAtProjectPath ::
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getMaybeShallowBranchAtProjectPath ::
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
|
||||
getShallowProjectBranchRoot projectBranch >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
||||
|
||||
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
||||
getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do
|
||||
ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName
|
||||
causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- lift $ Q.expectCausalHash causalHashId
|
||||
lift $ Operations.expectCausalBranchByCausalHash causalHash
|
||||
|
||||
expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m)
|
||||
expectProjectBranchRoot codebase projectId branchId = do
|
||||
causalHash <- runTransaction codebase $ do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
Q.expectCausalHash causalHashId
|
||||
expectBranchForHash codebase causalHash
|
||||
|
||||
expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- Q.expectCausalHash causalHashId
|
||||
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
||||
|
||||
getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- Q.expectCausalHash causalHashId
|
||||
Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value
|
||||
|
||||
getBranchAtProjectPath ::
|
||||
(MonadIO m) =>
|
||||
Codebase m v a ->
|
||||
Path.Absolute ->
|
||||
m (Branch m)
|
||||
getBranchAtPath codebase path = do
|
||||
V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing
|
||||
expectBranchForHash codebase causalHash
|
||||
PP.ProjectPath ->
|
||||
m (Maybe (Branch m))
|
||||
getBranchAtProjectPath codebase pp = runMaybeT do
|
||||
rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId
|
||||
hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch
|
||||
|
||||
-- | Like 'getBranchForHash', but for when the hash is known to be in the codebase.
|
||||
expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m)
|
||||
@ -347,9 +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.typeOfTerms tl) $> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl) $> ()
|
||||
( Map.lookup r (TL.dataDecls tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.typeOfTerms tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl)
|
||||
$> ()
|
||||
)
|
||||
|
||||
toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
||||
@ -509,3 +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))
|
||||
|
@ -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)
|
||||
|
@ -1,8 +1,5 @@
|
||||
module Unison.Codebase.Editor.RemoteRepo where
|
||||
|
||||
import Control.Lens (Lens')
|
||||
import Control.Lens qualified as Lens
|
||||
import Data.Void (absurd)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path =
|
||||
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
|
||||
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
|
||||
|
||||
writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void
|
||||
writeNamespaceToRead = \case
|
||||
WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} ->
|
||||
ReadShare'LooseCode ReadShareLooseCode {server, repo, path}
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
-- | print remote namespace
|
||||
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
|
||||
printReadRemoteNamespace printProject = \case
|
||||
@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case
|
||||
ReadShare'ProjectBranch project -> printProject project
|
||||
|
||||
-- | Render a 'WriteRemoteNamespace' as text.
|
||||
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||
printWriteRemoteNamespace = \case
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
|
||||
displayShareCodeserver server repo path
|
||||
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
|
||||
printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||
printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
|
||||
|
||||
maybePrintPath :: Path -> Text
|
||||
maybePrintPath path =
|
||||
@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} =
|
||||
case path of
|
||||
(segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
|
||||
_ -> False
|
||||
|
||||
data WriteRemoteNamespace a
|
||||
= WriteRemoteNamespaceShare !WriteShareRemoteNamespace
|
||||
| WriteRemoteProjectBranch a
|
||||
deriving stock (Eq, Functor, Show)
|
||||
|
||||
-- | A lens which focuses the path of a remote namespace.
|
||||
remotePath_ :: Lens' (WriteRemoteNamespace Void) Path
|
||||
remotePath_ = Lens.lens getter setter
|
||||
where
|
||||
getter = \case
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
setter remote path =
|
||||
case remote of
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) ->
|
||||
WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
data WriteShareRemoteNamespace = WriteShareRemoteNamespace
|
||||
{ server :: !ShareCodeserver,
|
||||
repo :: !ShareUserHandle,
|
||||
path :: !Path
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
@ -6,19 +6,23 @@
|
||||
module Unison.Codebase.Execute where
|
||||
|
||||
import Control.Exception (finally)
|
||||
import Control.Monad.Except (throwError, runExceptT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Except
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.MainTerm (getMainTerm)
|
||||
import Unison.Codebase.MainTerm qualified as MainTerm
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
@ -27,15 +31,22 @@ import Unison.Util.Pretty qualified as P
|
||||
execute ::
|
||||
Codebase.Codebase IO Symbol Ann ->
|
||||
Runtime Symbol ->
|
||||
HQ.HashQualified Name ->
|
||||
PP.ProjectPathNames ->
|
||||
IO (Either Runtime.Error ())
|
||||
execute codebase runtime mainName =
|
||||
execute codebase runtime mainPath =
|
||||
(`finally` Runtime.terminate runtime) . runExceptT $ do
|
||||
root <- liftIO $ Codebase.getRootBranch codebase
|
||||
let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
|
||||
loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||
(project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do
|
||||
project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project))
|
||||
branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch))
|
||||
pure . Right $ (project, branch)
|
||||
projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId
|
||||
let loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||
let mainType = Runtime.mainType runtime
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
|
||||
mainName <- case Path.toName (mainPath ^. PP.path_) of
|
||||
Just n -> pure (HQ.NameOnly n)
|
||||
Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath)))
|
||||
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType
|
||||
case mt of
|
||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s))
|
||||
MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()")
|
||||
|
@ -5,7 +5,9 @@ module Unison.Codebase.Path
|
||||
Path' (..),
|
||||
Absolute (..),
|
||||
pattern AbsolutePath',
|
||||
absPath_,
|
||||
Relative (..),
|
||||
relPath_,
|
||||
pattern RelativePath',
|
||||
Resolve (..),
|
||||
pattern Empty,
|
||||
@ -30,6 +32,8 @@ module Unison.Codebase.Path
|
||||
prefixNameIfRel,
|
||||
unprefixName,
|
||||
HQSplit,
|
||||
HQSplitAbsolute,
|
||||
AbsSplit,
|
||||
Split,
|
||||
Split',
|
||||
HQSplit',
|
||||
@ -58,6 +62,8 @@ module Unison.Codebase.Path
|
||||
toName',
|
||||
toText,
|
||||
toText',
|
||||
absToText,
|
||||
relToText,
|
||||
unsplit,
|
||||
unsplit',
|
||||
unsplitAbsolute,
|
||||
@ -113,12 +119,19 @@ instance GHC.IsList Path where
|
||||
toList (Path segs) = Foldable.toList segs
|
||||
fromList = Path . Seq.fromList
|
||||
|
||||
-- | A namespace path that starts from the root.
|
||||
-- | An absolute from the current project root
|
||||
newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord)
|
||||
|
||||
absPath_ :: Lens' Absolute Path
|
||||
absPath_ = lens unabsolute (\_ new -> Absolute new)
|
||||
|
||||
-- | A namespace path that doesn’t necessarily start from the root.
|
||||
-- Typically refers to a path from the current namespace.
|
||||
newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord)
|
||||
|
||||
relPath_ :: Lens' Relative Path
|
||||
relPath_ = lens unrelative (\_ new -> Relative new)
|
||||
|
||||
-- | A namespace that may be either absolute or relative, This is the most general type that should be used.
|
||||
newtype Path' = Path' {unPath' :: Either Absolute Relative}
|
||||
deriving (Eq, Ord)
|
||||
@ -148,14 +161,14 @@ absoluteToPath' = AbsolutePath'
|
||||
|
||||
instance Show Path' where
|
||||
show = \case
|
||||
AbsolutePath' abs -> show abs
|
||||
RelativePath' rel -> show rel
|
||||
AbsolutePath' abs -> Text.unpack $ absToText abs
|
||||
RelativePath' rel -> Text.unpack $ relToText rel
|
||||
|
||||
instance Show Absolute where
|
||||
show s = "." ++ show (unabsolute s)
|
||||
show s = Text.unpack $ absToText s
|
||||
|
||||
instance Show Relative where
|
||||
show = show . unrelative
|
||||
show = Text.unpack . relToText
|
||||
|
||||
unsplit' :: Split' -> Path'
|
||||
unsplit' = \case
|
||||
@ -175,6 +188,8 @@ nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative)
|
||||
nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
|
||||
nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
|
||||
|
||||
type AbsSplit = (Absolute, NameSegment)
|
||||
|
||||
type Split = (Path, NameSegment)
|
||||
|
||||
type HQSplit = (Path, HQ'.HQSegment)
|
||||
@ -368,11 +383,29 @@ empty = Path mempty
|
||||
instance Show Path where
|
||||
show = Text.unpack . toText
|
||||
|
||||
instance From Path Text where
|
||||
from = toText
|
||||
|
||||
instance From Absolute Text where
|
||||
from = absToText
|
||||
|
||||
instance From Relative Text where
|
||||
from = relToText
|
||||
|
||||
instance From Path' Text where
|
||||
from = toText'
|
||||
|
||||
-- | Note: This treats the path as relative.
|
||||
toText :: Path -> Text
|
||||
toText =
|
||||
maybe Text.empty Name.toText . toName
|
||||
|
||||
absToText :: Absolute -> Text
|
||||
absToText abs = "." <> toText (unabsolute abs)
|
||||
|
||||
relToText :: Relative -> Text
|
||||
relToText rel = toText (unrelative rel)
|
||||
|
||||
unsafeParseText :: Text -> Path
|
||||
unsafeParseText = \case
|
||||
"" -> empty
|
||||
@ -509,6 +542,9 @@ instance Resolve Absolute Relative Absolute where
|
||||
instance Resolve Absolute Relative Path' where
|
||||
resolve l r = AbsolutePath' (resolve l r)
|
||||
|
||||
instance Resolve Absolute Path Absolute where
|
||||
resolve (Absolute l) r = Absolute (resolve l r)
|
||||
|
||||
instance Resolve Path' Path' Path' where
|
||||
resolve _ a@(AbsolutePath' {}) = a
|
||||
resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
|
||||
|
136
parser-typechecker/src/Unison/Codebase/ProjectPath.hs
Normal file
136
parser-typechecker/src/Unison/Codebase/ProjectPath.hs
Normal file
@ -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
|
@ -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
|
@ -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
|
||||
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
|
||||
CodebaseOps.createSchema
|
||||
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,
|
||||
|
@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase
|
||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6)
|
||||
@ -30,27 +31,28 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2
|
||||
import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath)
|
||||
import Unison.Codebase.Type (LocalOrRemote (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sqlite.Connection qualified as Sqlite.Connection
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import UnliftIO qualified
|
||||
|
||||
-- | Mapping from schema version to the migration required to get there.
|
||||
-- E.g. The migration at index 2 must be run on a codebase at version 1.
|
||||
migrations ::
|
||||
(MVar Region.ConsoleRegion) ->
|
||||
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
|
||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||
TVar (Map Hash Ops2.TermBufferEntry) ->
|
||||
TVar (Map Hash Ops2.DeclBufferEntry) ->
|
||||
CodebasePath ->
|
||||
Map SchemaVersion (Sqlite.Transaction ())
|
||||
migrations getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
Map SchemaVersion (Sqlite.Connection -> IO ())
|
||||
migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
Map.fromList
|
||||
[ (2, migrateSchema1To2 getDeclType termBuffer declBuffer),
|
||||
[ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer),
|
||||
-- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this
|
||||
-- caused an issue:
|
||||
--
|
||||
@ -67,30 +69,34 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
-- This migration drops all the v1 hash objects to avoid this issue, since these hash objects
|
||||
-- weren't being used for anything anyways.
|
||||
sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)),
|
||||
(4, migrateSchema3To4),
|
||||
(4, runT (migrateSchema3To4 *> runIntegrityChecks regionVar)),
|
||||
-- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
|
||||
sqlMigration 5 Q.addTempEntityTables,
|
||||
(6, migrateSchema5To6 rootCodebasePath),
|
||||
(7, migrateSchema6To7),
|
||||
(8, migrateSchema7To8),
|
||||
(6, runT $ migrateSchema5To6 rootCodebasePath),
|
||||
(7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)),
|
||||
(8, runT migrateSchema7To8),
|
||||
-- Recreates the name lookup tables because the primary key was missing the root hash id.
|
||||
sqlMigration 9 Q.fixScopedNameLookupTables,
|
||||
sqlMigration 10 Q.addProjectTables,
|
||||
sqlMigration 11 Q.addMostRecentBranchTable,
|
||||
(12, migrateSchema11To12),
|
||||
(12, runT migrateSchema11To12),
|
||||
sqlMigration 13 Q.addMostRecentNamespaceTable,
|
||||
sqlMigration 14 Q.addSquashResultTable,
|
||||
sqlMigration 15 Q.addSquashResultTableIfNotExists,
|
||||
sqlMigration 16 Q.cdToProjectRoot
|
||||
sqlMigration 16 Q.cdToProjectRoot,
|
||||
(17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn)
|
||||
]
|
||||
where
|
||||
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ())
|
||||
runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()
|
||||
runT t conn = Sqlite.runWriteTransaction conn (\run -> run t)
|
||||
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ())
|
||||
sqlMigration ver migration =
|
||||
( ver,
|
||||
do
|
||||
Q.expectSchemaVersion (ver - 1)
|
||||
migration
|
||||
Q.setSchemaVersion ver
|
||||
\conn -> Sqlite.runWriteTransaction conn \run -> run
|
||||
do
|
||||
Q.expectSchemaVersion (ver - 1)
|
||||
migration
|
||||
Q.setSchemaVersion ver
|
||||
)
|
||||
|
||||
data CodebaseVersionStatus
|
||||
@ -140,7 +146,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
|
||||
Region.displayConsoleRegions do
|
||||
(`UnliftIO.finally` finalizeRegion) do
|
||||
let migs = migrations getDeclType termBuffer declBuffer root
|
||||
let migs = migrations regionVar getDeclType termBuffer declBuffer root
|
||||
-- The highest schema that this ucm knows how to migrate to.
|
||||
let highestKnownSchemaVersion = fst . head $ Map.toDescList migs
|
||||
currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion
|
||||
@ -149,11 +155,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
when shouldPrompt do
|
||||
putStrLn "Press <enter> to start the migration once all other ucm processes are shutdown..."
|
||||
void $ liftIO getLine
|
||||
ranMigrations <-
|
||||
Sqlite.runWriteTransaction conn \run -> do
|
||||
ranMigrations <- do
|
||||
currentSchemaVersion <- Sqlite.runTransaction conn $ do
|
||||
-- Get the schema version again now that we're in a transaction.
|
||||
currentSchemaVersion <- run Q.schemaVersion
|
||||
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
||||
Q.schemaVersion
|
||||
-- This is a bit of a hack, hopefully we can remove this when we have a more
|
||||
-- reliable way to freeze old migration code in time.
|
||||
-- The problem is that 'saveObject' has been changed to flush temp entity tables,
|
||||
@ -163,48 +168,29 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
--
|
||||
-- Hopefully we can remove this once we've got better methods of freezing migration
|
||||
-- code in time.
|
||||
when (currentSchemaVersion < 5) $ run Q.addTempEntityTables
|
||||
when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables
|
||||
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
||||
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
||||
run migration
|
||||
let ranMigrations = not (null migrationsToRun)
|
||||
when ranMigrations do
|
||||
region <-
|
||||
UnliftIO.mask_ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
result <- do
|
||||
-- Ideally we'd check everything here, but certain codebases are known to have objects
|
||||
-- with missing Hash Objects, we'll want to clean that up in a future migration.
|
||||
-- integrityCheckAllHashObjects,
|
||||
let checks =
|
||||
Monoid.whenM
|
||||
(currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked
|
||||
[ integrityCheckAllBranches,
|
||||
integrityCheckAllCausals
|
||||
]
|
||||
|
||||
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
|
||||
Region.setConsoleRegion
|
||||
region
|
||||
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
|
||||
run check
|
||||
case result of
|
||||
NoIntegrityErrors -> pure ()
|
||||
IntegrityErrorDetected errs -> do
|
||||
let msg = prettyPrintIntegrityErrors errs
|
||||
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
|
||||
Region.setConsoleRegion region (Text.pack rendered)
|
||||
run (abortMigration "Codebase integrity error detected.")
|
||||
pure ranMigrations
|
||||
when (currentSchemaVersion < 5) Q.addTempEntityTables
|
||||
when (currentSchemaVersion < 6) Q.addNamespaceStatsTables
|
||||
pure currentSchemaVersion
|
||||
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
||||
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
||||
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
||||
migration conn
|
||||
let ranMigrations = not (null migrationsToRun)
|
||||
pure ranMigrations
|
||||
Debug.debugLogM Debug.Migration "Migrations complete"
|
||||
when ranMigrations do
|
||||
region <- readMVar regionVar
|
||||
region <-
|
||||
UnliftIO.mask_ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
-- Vacuum once now that any migrations have taken place.
|
||||
Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text)
|
||||
case vacuumStrategy of
|
||||
Vacuum -> void $ Sqlite.Connection.vacuum conn
|
||||
Vacuum -> do
|
||||
Debug.debugLogM Debug.Migration "About to VACUUM"
|
||||
void $ Sqlite.Connection.vacuum conn
|
||||
Debug.debugLogM Debug.Migration "Done VACUUM"
|
||||
NoVacuum -> pure ()
|
||||
Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text)
|
||||
|
||||
@ -224,3 +210,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion
|
||||
Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL
|
||||
putStrLn ("📋 I backed up your codebase to " ++ (root </> backupPath))
|
||||
putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase."
|
||||
|
||||
runIntegrityChecks ::
|
||||
(MVar Region.ConsoleRegion) ->
|
||||
Sqlite.Transaction ()
|
||||
runIntegrityChecks regionVar = do
|
||||
region <- Sqlite.unsafeIO . UnliftIO.mask_ $ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
result <- do
|
||||
-- Ideally we'd check everything here, but certain codebases are known to have objects
|
||||
-- with missing Hash Objects, we'll want to clean that up in a future migration.
|
||||
-- integrityCheckAllHashObjects,
|
||||
let checks =
|
||||
[ integrityCheckAllBranches,
|
||||
integrityCheckAllCausals
|
||||
]
|
||||
|
||||
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
|
||||
Sqlite.unsafeIO $
|
||||
Region.setConsoleRegion
|
||||
region
|
||||
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
|
||||
check
|
||||
case result of
|
||||
NoIntegrityErrors -> pure ()
|
||||
IntegrityErrorDetected errs -> do
|
||||
let msg = prettyPrintIntegrityErrors errs
|
||||
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
|
||||
Sqlite.unsafeIO $ Region.setConsoleRegion region (Text.pack rendered)
|
||||
(abortMigration "Codebase integrity error detected.")
|
||||
|
@ -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"
|
@ -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
|
||||
|
@ -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}
|
||||
|
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
|
||||
-- monad.
|
||||
@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
|
||||
import U.Codebase.Branch.Diff qualified as BranchDiff
|
||||
@ -30,11 +33,14 @@ import U.Codebase.Sqlite.NamedRef qualified as S
|
||||
import U.Codebase.Sqlite.ObjectType qualified as OT
|
||||
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Project qualified as Project
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import Unison.Builtin qualified as Builtins
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
@ -43,7 +49,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.Core.Project (ProjectBranchName, ProjectName)
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as Decl
|
||||
import Unison.Hash (Hash)
|
||||
@ -74,6 +80,35 @@ import Unison.Util.Set qualified as Set
|
||||
import Unison.WatchKind qualified as UF
|
||||
import UnliftIO.STM
|
||||
|
||||
createSchema :: Transaction ()
|
||||
createSchema = do
|
||||
Q.runCreateSql
|
||||
Q.addTempEntityTables
|
||||
Q.addNamespaceStatsTables
|
||||
Q.addReflogTable
|
||||
Q.fixScopedNameLookupTables
|
||||
Q.addProjectTables
|
||||
Q.addMostRecentBranchTable
|
||||
Q.addNameLookupMountTables
|
||||
Q.addMostRecentNamespaceTable
|
||||
Sqlite.execute insertSchemaVersionSql
|
||||
Q.addSquashResultTable
|
||||
Q.addCurrentProjectPathTable
|
||||
Q.addProjectBranchReflogTable
|
||||
Q.addProjectBranchCausalHashIdColumn
|
||||
(_, emptyCausalHashId) <- emptyCausalHash
|
||||
(_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
|
||||
Q.setCurrentProjectPath projectId branchId []
|
||||
where
|
||||
scratchProjectName = UnsafeProjectName "scratch"
|
||||
scratchBranchName = UnsafeProjectBranchName "main"
|
||||
currentSchemaVersion = Q.currentSchemaVersion
|
||||
insertSchemaVersionSql =
|
||||
[Sqlite.sql|
|
||||
INSERT INTO schema_version (version)
|
||||
VALUES (:currentSchemaVersion)
|
||||
|]
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Buffer entry
|
||||
|
||||
@ -382,25 +417,6 @@ tryFlushDeclBuffer termBuffer declBuffer =
|
||||
h
|
||||
in loop
|
||||
|
||||
uncachedLoadRootBranch ::
|
||||
BranchCache Sqlite.Transaction ->
|
||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||
Transaction (Branch Transaction)
|
||||
uncachedLoadRootBranch branchCache getDeclType = do
|
||||
causal2 <- Ops.expectRootCausal
|
||||
Cv.causalbranch2to1 branchCache getDeclType causal2
|
||||
|
||||
-- | Get whether the root branch exists.
|
||||
getRootBranchExists :: Transaction Bool
|
||||
getRootBranchExists =
|
||||
isJust <$> Ops.loadRootCausalHash
|
||||
|
||||
putRootBranch :: Branch Transaction -> Transaction ()
|
||||
putRootBranch branch1 = do
|
||||
-- todo: check to see if root namespace hash has been externally modified
|
||||
-- and do something (merge?) it if necessary. But for now, we just overwrite it.
|
||||
void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1))
|
||||
|
||||
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||
-- to one that returns Maybe.
|
||||
getBranchForHash ::
|
||||
@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do
|
||||
conn <- Sqlite.unsafeGetConnection
|
||||
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||
|
||||
insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
||||
Q.insertProject projectId projectName
|
||||
-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project.
|
||||
insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch)
|
||||
insertProjectAndBranch projectName branchName chId = do
|
||||
projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do
|
||||
projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom)
|
||||
Q.insertProject projectId projectName
|
||||
pure projectId
|
||||
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
||||
let projectBranch =
|
||||
ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
Q.insertProjectBranch
|
||||
ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
"Project Created"
|
||||
chId
|
||||
projectBranch
|
||||
Q.setMostRecentBranch projectId branchId
|
||||
pure (Project {name = projectName, projectId}, ProjectBranch {projectId, name = branchName, branchId, parentBranchId = Nothing})
|
||||
|
||||
-- | Often we need to assign something to an empty causal, this ensures the empty causal
|
||||
-- exists in the codebase and returns its hash.
|
||||
emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId)
|
||||
emptyCausalHash = do
|
||||
let emptyBranch = Branch.empty
|
||||
putBranch emptyBranch
|
||||
let causalHash = Branch.headHash emptyBranch
|
||||
causalHashId <- Q.expectCausalHashIdByCausalHash causalHash
|
||||
pure (causalHash, causalHashId)
|
||||
|
@ -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.
|
||||
|
@ -10,6 +10,7 @@ import U.Codebase.Branch qualified as Codebase.Branch
|
||||
import U.Codebase.Decl qualified as Codebase.Decl
|
||||
import U.Codebase.Reference qualified as Codebase.Reference
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -21,8 +22,8 @@ import Witherable (witherM)
|
||||
-- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed
|
||||
-- by a cache.
|
||||
loadUniqueTypeGuid ::
|
||||
([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
||||
[NameSegment] ->
|
||||
(ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
||||
ProjectPath ->
|
||||
NameSegment ->
|
||||
Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid loadNamespaceAtPath path name =
|
||||
|
@ -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"
|
@ -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
|
||||
|
@ -52,14 +52,19 @@ import Options.Applicative.Help (bold, (<+>))
|
||||
import Options.Applicative.Help.Pretty qualified as P
|
||||
import Stats
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathNames)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import Unison.LSP (LspFormattingConfig (..))
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyTerminal qualified as PT
|
||||
import Unison.Project qualified as Project
|
||||
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Syntax.HashQualified qualified as HQ
|
||||
@ -68,7 +73,7 @@ import Unison.Util.Pretty (Width (..))
|
||||
-- | Valid ways to provide source code to the run command
|
||||
data RunSource
|
||||
= RunFromPipe (HashQualified Name)
|
||||
| RunFromSymbol (HashQualified Name)
|
||||
| RunFromSymbol ProjectPathNames
|
||||
| RunFromFile FilePath (HashQualified Name)
|
||||
| RunCompiled FilePath
|
||||
deriving (Show, Eq)
|
||||
@ -102,8 +107,8 @@ data Command
|
||||
= Launch
|
||||
IsHeadless
|
||||
CodebaseServerOpts
|
||||
-- Starting path
|
||||
(Maybe Path.Absolute)
|
||||
-- Starting project
|
||||
(Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
ShouldWatchFiles
|
||||
| PrintVersion
|
||||
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
|
||||
@ -357,9 +362,9 @@ launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command
|
||||
launchParser envOpts isHeadless = do
|
||||
-- ApplicativeDo
|
||||
codebaseServerOpts <- codebaseServerOptsParser envOpts
|
||||
startingPath <- startingPathOption
|
||||
startingProject <- startingProjectOption
|
||||
shouldWatchFiles <- noFileWatchFlag
|
||||
pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles)
|
||||
pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles)
|
||||
|
||||
initParser :: Parser Command
|
||||
initParser = pure Init
|
||||
@ -374,9 +379,13 @@ runHQParser :: Parser (HashQualified Name)
|
||||
runHQParser =
|
||||
argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL")
|
||||
|
||||
runProjectPathParser :: Parser PP.ProjectPathNames
|
||||
runProjectPathParser =
|
||||
argument (maybeReader (eitherToMaybe . PP.parseProjectPath . Text.pack)) (metavar "@myproject/mybranch:.path.in.project")
|
||||
|
||||
runSymbolParser :: Parser Command
|
||||
runSymbolParser =
|
||||
Run . RunFromSymbol <$> runHQParser <*> runArgumentParser
|
||||
Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser
|
||||
|
||||
runFileParser :: Parser Command
|
||||
runFileParser =
|
||||
@ -422,15 +431,15 @@ saveCodebaseToFlag = do
|
||||
_ -> DontSaveCodebase
|
||||
)
|
||||
|
||||
startingPathOption :: Parser (Maybe Path.Absolute)
|
||||
startingPathOption =
|
||||
startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
startingProjectOption =
|
||||
let meta =
|
||||
metavar ".path.in.codebase"
|
||||
<> long "path"
|
||||
metavar "project/branch"
|
||||
<> long "project"
|
||||
<> short 'p'
|
||||
<> help "Launch the UCM session at the provided path location."
|
||||
<> help "Launch the UCM session at the provided project and branch."
|
||||
<> noGlobal
|
||||
in optional $ option readAbsolutePath meta
|
||||
in optional (option readProjectAndBranchNames meta)
|
||||
|
||||
noFileWatchFlag :: Parser ShouldWatchFiles
|
||||
noFileWatchFlag =
|
||||
@ -469,6 +478,13 @@ readPath' = do
|
||||
Left err -> OptParse.readerError (Text.unpack err)
|
||||
Right path' -> pure path'
|
||||
|
||||
readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName)
|
||||
readProjectAndBranchNames = do
|
||||
str <- OptParse.str
|
||||
case Megaparsec.parse Project.fullyQualifiedProjectAndBranchNamesParser "arg" str of
|
||||
Left errBundle -> OptParse.readerError $ Megaparsec.errorBundlePretty errBundle
|
||||
Right projectAndBranch -> pure projectAndBranch
|
||||
|
||||
fileArgument :: String -> Parser FilePath
|
||||
fileArgument varName =
|
||||
strArgument
|
||||
|
@ -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.Queries qualified as Queries
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Auth.CredentialManager (CredentialManager)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import Unison.Codebase (Codebase)
|
||||
@ -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),
|
||||
lastSavedRootHash :: CausalHash,
|
||||
-- the current position in the namespace
|
||||
currentPathStack :: List.NonEmpty Path.Absolute,
|
||||
{ currentProjectRoot :: TMVar (Branch IO),
|
||||
-- the current position in the codebase, with the head being the most recent lcoation.
|
||||
projectPathStack :: List.NonEmpty PP.ProjectPathIds,
|
||||
-- TBD
|
||||
-- , _activeEdits :: Set Branch.EditGuid
|
||||
|
||||
@ -206,26 +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 lastSavedRootHash b p = do
|
||||
loopState0 :: TMVar (Branch IO) -> PP.ProjectPathIds -> LoopState
|
||||
loopState0 b p = do
|
||||
LoopState
|
||||
{ root = b,
|
||||
lastSavedRootHash = lastSavedRootHash,
|
||||
currentPathStack = pure p,
|
||||
{ currentProjectRoot = b,
|
||||
projectPathStack = 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
|
||||
State.modify' \state ->
|
||||
state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)}
|
||||
pp <- getProjectPathIds
|
||||
let newPP = pp & PP.absPath_ .~ path
|
||||
setMostRecentProjectPath newPP
|
||||
#projectPathStack %= NonEmpty.cons newPP
|
||||
|
||||
-- | 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)
|
||||
State.put state {currentPathStack = paths}
|
||||
setMostRecentProjectPath (List.NonEmpty.head paths)
|
||||
State.put state {projectPathStack = paths}
|
||||
pure True
|
||||
|
||||
setMostRecentNamespace :: Path.Absolute -> Cli ()
|
||||
setMostRecentNamespace =
|
||||
runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute
|
||||
setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
|
||||
setMostRecentProjectPath loc =
|
||||
runTransaction $ Codebase.setCurrentProjectPath loc
|
||||
|
||||
respond :: Output -> Cli ()
|
||||
respond output = do
|
||||
|
@ -6,10 +6,18 @@ module Unison.Cli.MonadUtils
|
||||
|
||||
-- * Paths
|
||||
getCurrentPath,
|
||||
getCurrentProjectName,
|
||||
getCurrentProjectBranchName,
|
||||
getCurrentProjectPath,
|
||||
resolvePath,
|
||||
resolvePath',
|
||||
resolvePath'ToAbsolute,
|
||||
resolveSplit',
|
||||
|
||||
-- * Project and branch resolution
|
||||
getCurrentProjectAndBranch,
|
||||
getCurrentProjectBranch,
|
||||
|
||||
-- * Branches
|
||||
|
||||
-- ** Resolving branch identifiers
|
||||
@ -20,18 +28,15 @@ module Unison.Cli.MonadUtils
|
||||
resolveShortCausalHash,
|
||||
|
||||
-- ** Getting/setting branches
|
||||
getRootBranch,
|
||||
setRootBranch,
|
||||
modifyRootBranch,
|
||||
getRootBranch0,
|
||||
getCurrentProjectRoot,
|
||||
getCurrentProjectRoot0,
|
||||
getCurrentBranch,
|
||||
getCurrentBranch0,
|
||||
getBranchAt,
|
||||
getBranch0At,
|
||||
getLastSavedRootHash,
|
||||
setLastSavedRootHash,
|
||||
getMaybeBranchAt,
|
||||
getMaybeBranch0At,
|
||||
getProjectBranchRoot,
|
||||
getBranchFromProjectPath,
|
||||
getBranch0FromProjectPath,
|
||||
getMaybeBranchFromProjectPath,
|
||||
getMaybeBranch0FromProjectPath,
|
||||
expectBranchAtPath,
|
||||
expectBranchAtPath',
|
||||
expectBranch0AtPath,
|
||||
@ -43,13 +48,10 @@ module Unison.Cli.MonadUtils
|
||||
stepAt',
|
||||
stepAt,
|
||||
stepAtM,
|
||||
stepAtNoSync',
|
||||
stepAtNoSync,
|
||||
stepManyAt,
|
||||
stepManyAtMNoSync,
|
||||
stepManyAtNoSync,
|
||||
syncRoot,
|
||||
updateRoot,
|
||||
stepManyAtM,
|
||||
updateProjectBranchRoot,
|
||||
updateProjectBranchRoot_,
|
||||
updateAtM,
|
||||
updateAt,
|
||||
updateAndStepAt,
|
||||
@ -91,6 +93,9 @@ import U.Codebase.Branch qualified as V2 (Branch)
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Sqlite.Project (Project)
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Codebase qualified as Codebase
|
||||
@ -103,6 +108,8 @@ import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Patch qualified as Patch
|
||||
import Unison.Codebase.Path (Path, Path' (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -112,6 +119,7 @@ import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -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
|
||||
pure (Path.resolve currentPath (Path.Relative path))
|
||||
pp <- getCurrentProjectPath
|
||||
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path
|
||||
|
||||
-- | Resolve a @Path'@ to a @Path.Absolute@, per the current path.
|
||||
resolvePath' :: Path' -> Cli Path.Absolute
|
||||
resolvePath' path = do
|
||||
currentPath <- getCurrentPath
|
||||
pure (Path.resolve currentPath path)
|
||||
resolvePath' :: Path' -> Cli PP.ProjectPath
|
||||
resolvePath' path' = do
|
||||
pp <- getCurrentProjectPath
|
||||
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path'
|
||||
|
||||
resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute
|
||||
resolvePath'ToAbsolute path' = do
|
||||
view PP.absPath_ <$> resolvePath' path'
|
||||
|
||||
-- | Resolve a path split, per the current path.
|
||||
resolveSplit' :: (Path', a) -> Cli (Path.Absolute, a)
|
||||
resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a)
|
||||
resolveSplit' =
|
||||
traverseOf _1 resolvePath'
|
||||
|
||||
@ -166,23 +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
|
||||
Right path -> getBranchAt path
|
||||
Input.BranchAtSCH hash -> resolveShortCausalHash hash
|
||||
Input.BranchAtPath absPath -> do
|
||||
pp <- resolvePath' (Path' (Left absPath))
|
||||
getBranchFromProjectPath pp
|
||||
Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp
|
||||
|
||||
-- | V2 version of 'resolveAbsBranchId2'.
|
||||
resolveAbsBranchIdV2 ::
|
||||
(forall void. Output.Output -> Sqlite.Transaction void) ->
|
||||
ProjectAndBranch Project ProjectBranch ->
|
||||
Input.AbsBranchId ->
|
||||
Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
||||
resolveAbsBranchIdV2 rollback = \case
|
||||
Left shortHash -> do
|
||||
resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case
|
||||
Input.BranchAtSCH shortHash -> do
|
||||
hash <- resolveShortCausalHashToCausalHash rollback shortHash
|
||||
succeed (Codebase.expectCausalBranchByCausalHash hash)
|
||||
Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
|
||||
where
|
||||
succeed getCausal = do
|
||||
causal <- getCausal
|
||||
V2Causal.value causal
|
||||
causal <- (Codebase.expectCausalBranchByCausalHash hash)
|
||||
V2Causal.value causal
|
||||
Input.BranchAtPath absPath -> do
|
||||
let pp = PP.ProjectPath proj branch absPath
|
||||
Codebase.getShallowBranchAtProjectPath pp
|
||||
Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp
|
||||
|
||||
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
|
||||
-- branches by path are OK - the empty branch will be returned).
|
||||
@ -194,7 +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)
|
||||
getRootBranch = do
|
||||
use #root >>= atomically . readTMVar
|
||||
getCurrentProjectRoot :: Cli (Branch IO)
|
||||
getCurrentProjectRoot = do
|
||||
use #currentProjectRoot >>= atomically . readTMVar
|
||||
|
||||
-- | Get the root branch0.
|
||||
getRootBranch0 :: Cli (Branch0 IO)
|
||||
getRootBranch0 =
|
||||
Branch.head <$> getRootBranch
|
||||
|
||||
-- | Set a new root branch.
|
||||
--
|
||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
||||
setRootBranch :: Branch IO -> Cli ()
|
||||
setRootBranch b = do
|
||||
void $ modifyRootBranch (const b)
|
||||
|
||||
-- | Modify the root branch.
|
||||
--
|
||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
||||
modifyRootBranch :: (Branch IO -> Branch IO) -> Cli (Branch IO)
|
||||
modifyRootBranch f = do
|
||||
rootVar <- use #root
|
||||
atomically do
|
||||
root <- takeTMVar rootVar
|
||||
let !newRoot = f root
|
||||
putTMVar rootVar newRoot
|
||||
pure newRoot
|
||||
getCurrentProjectRoot0 :: Cli (Branch0 IO)
|
||||
getCurrentProjectRoot0 =
|
||||
Branch.head <$> getCurrentProjectRoot
|
||||
|
||||
-- | Get the current branch.
|
||||
getCurrentBranch :: Cli (Branch IO)
|
||||
getCurrentBranch = do
|
||||
path <- getCurrentPath
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ Codebase.getBranchAtPath codebase path
|
||||
pp <- getCurrentProjectPath
|
||||
fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp)
|
||||
|
||||
-- | Get the current branch0.
|
||||
getCurrentBranch0 :: Cli (Branch0 IO)
|
||||
getCurrentBranch0 = do
|
||||
Branch.head <$> getCurrentBranch
|
||||
|
||||
-- | Get the last saved root hash.
|
||||
getLastSavedRootHash :: Cli CausalHash
|
||||
getLastSavedRootHash = do
|
||||
use #lastSavedRootHash
|
||||
|
||||
-- | Set a new root branch.
|
||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
||||
setLastSavedRootHash :: CausalHash -> Cli ()
|
||||
setLastSavedRootHash ch = do
|
||||
#lastSavedRootHash .= ch
|
||||
|
||||
-- | Get the branch at an absolute path.
|
||||
getBranchAt :: Path.Absolute -> Cli (Branch IO)
|
||||
getBranchAt path =
|
||||
getMaybeBranchAt path <&> fromMaybe Branch.empty
|
||||
-- | Get the branch at an absolute path from the project root.
|
||||
getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO)
|
||||
getBranchFromProjectPath pp =
|
||||
getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty
|
||||
|
||||
-- | Get the branch0 at an absolute path.
|
||||
getBranch0At :: Path.Absolute -> Cli (Branch0 IO)
|
||||
getBranch0At path =
|
||||
Branch.head <$> getBranchAt path
|
||||
getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO)
|
||||
getBranch0FromProjectPath pp =
|
||||
Branch.head <$> getBranchFromProjectPath pp
|
||||
|
||||
getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO)
|
||||
getProjectBranchRoot projectBranch = do
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId
|
||||
|
||||
-- | Get the maybe-branch at an absolute path.
|
||||
getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO))
|
||||
getMaybeBranchAt path = do
|
||||
rootBranch <- getRootBranch
|
||||
pure (Branch.getAt (Path.unabsolute path) rootBranch)
|
||||
getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO))
|
||||
getMaybeBranchFromProjectPath pp = do
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ Codebase.getBranchAtProjectPath codebase pp
|
||||
|
||||
-- | Get the maybe-branch0 at an absolute path.
|
||||
getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO))
|
||||
getMaybeBranch0At path =
|
||||
fmap Branch.head <$> getMaybeBranchAt path
|
||||
getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO))
|
||||
getMaybeBranch0FromProjectPath pp =
|
||||
fmap Branch.head <$> getMaybeBranchFromProjectPath pp
|
||||
|
||||
-- | Get the branch at a relative path, or return early if there's no such branch.
|
||||
expectBranchAtPath :: Path -> Cli (Branch IO)
|
||||
@ -303,7 +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 <- V2Causal.value causal
|
||||
branch <- Codebase.getShallowBranchAtProjectPath pp
|
||||
isEmpty <- V2Branch.isEmpty branch
|
||||
pure (not isEmpty)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Updating branches
|
||||
|
||||
makeActionsUnabsolute :: Functor f => f (Path.Absolute, x) -> f (Path, x)
|
||||
makeActionsUnabsolute = fmap (first Path.unabsolute)
|
||||
|
||||
stepAt ::
|
||||
Text ->
|
||||
(Path, Branch0 IO -> Branch0 IO) ->
|
||||
(ProjectPath, Branch0 IO -> Branch0 IO) ->
|
||||
Cli ()
|
||||
stepAt cause = stepManyAt @[] cause . pure
|
||||
stepAt cause (pp, action) = stepManyAt pp.branch cause [(pp.absPath, action)]
|
||||
|
||||
stepAt' ::
|
||||
Text ->
|
||||
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||
(ProjectPath, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||
Cli Bool
|
||||
stepAt' cause = stepManyAt' @[] cause . pure
|
||||
|
||||
stepAtNoSync' ::
|
||||
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||
Cli Bool
|
||||
stepAtNoSync' = stepManyAtNoSync' @[] . pure
|
||||
|
||||
stepAtNoSync ::
|
||||
(Path, Branch0 IO -> Branch0 IO) ->
|
||||
Cli ()
|
||||
stepAtNoSync = stepManyAtNoSync @[] . pure
|
||||
stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)]
|
||||
|
||||
stepAtM ::
|
||||
Text ->
|
||||
(Path, Branch0 IO -> IO (Branch0 IO)) ->
|
||||
(ProjectPath, Branch0 IO -> IO (Branch0 IO)) ->
|
||||
Cli ()
|
||||
stepAtM cause = stepManyAtM @[] cause . pure
|
||||
stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)]
|
||||
|
||||
stepManyAt ::
|
||||
(Foldable f) =>
|
||||
ProjectBranch ->
|
||||
Text ->
|
||||
f (Path, Branch0 IO -> Branch0 IO) ->
|
||||
[(Path.Absolute, Branch0 IO -> Branch0 IO)] ->
|
||||
Cli ()
|
||||
stepManyAt reason actions = do
|
||||
stepManyAtNoSync actions
|
||||
syncRoot reason
|
||||
stepManyAt pb reason actions = do
|
||||
updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions)
|
||||
|
||||
stepManyAt' ::
|
||||
(Foldable f) =>
|
||||
ProjectBranch ->
|
||||
Text ->
|
||||
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||
[(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] ->
|
||||
Cli Bool
|
||||
stepManyAt' reason actions = do
|
||||
res <- stepManyAtNoSync' actions
|
||||
syncRoot reason
|
||||
pure res
|
||||
|
||||
stepManyAtNoSync' ::
|
||||
(Foldable f) =>
|
||||
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||
Cli Bool
|
||||
stepManyAtNoSync' actions = do
|
||||
origRoot <- getRootBranch
|
||||
newRoot <- Branch.stepManyAtM actions origRoot
|
||||
setRootBranch newRoot
|
||||
pure (origRoot /= newRoot)
|
||||
stepManyAt' pb reason actions = do
|
||||
origRoot <- getProjectBranchRoot pb
|
||||
newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot
|
||||
didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot))
|
||||
pure didChange
|
||||
|
||||
-- Like stepManyAt, but doesn't update the last saved root
|
||||
stepManyAtNoSync ::
|
||||
(Foldable f) =>
|
||||
f (Path, Branch0 IO -> Branch0 IO) ->
|
||||
Cli ()
|
||||
stepManyAtNoSync actions =
|
||||
void . modifyRootBranch $ Branch.stepManyAt actions
|
||||
|
||||
stepManyAtM ::
|
||||
(Foldable f) =>
|
||||
ProjectBranch ->
|
||||
Text ->
|
||||
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
|
||||
[(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] ->
|
||||
Cli ()
|
||||
stepManyAtM reason actions = do
|
||||
stepManyAtMNoSync actions
|
||||
syncRoot reason
|
||||
|
||||
stepManyAtMNoSync ::
|
||||
(Foldable f) =>
|
||||
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
|
||||
Cli ()
|
||||
stepManyAtMNoSync actions = do
|
||||
oldRoot <- getRootBranch
|
||||
newRoot <- liftIO (Branch.stepManyAtM actions oldRoot)
|
||||
setRootBranch newRoot
|
||||
|
||||
-- | Sync the in-memory root branch.
|
||||
syncRoot :: Text -> Cli ()
|
||||
syncRoot description = do
|
||||
rootBranch <- getRootBranch
|
||||
updateRoot rootBranch description
|
||||
stepManyAtM pb reason actions = do
|
||||
updateProjectBranchRoot pb reason \oldRoot -> do
|
||||
newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot)
|
||||
pure (newRoot, ())
|
||||
|
||||
-- | Update a branch at the given path, returning `True` if
|
||||
-- an update occurred and false otherwise
|
||||
updateAtM ::
|
||||
Text ->
|
||||
Path.Absolute ->
|
||||
ProjectPath ->
|
||||
(Branch IO -> Cli (Branch IO)) ->
|
||||
Cli Bool
|
||||
updateAtM reason (Path.Absolute p) f = do
|
||||
b <- getRootBranch
|
||||
b' <- Branch.modifyAtM p f b
|
||||
updateRoot b' reason
|
||||
pure $ b /= b'
|
||||
updateAtM reason pp f = do
|
||||
oldRootBranch <- getProjectBranchRoot (pp ^. #branch)
|
||||
newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch
|
||||
updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch)
|
||||
pure $ oldRootBranch /= newRootBranch
|
||||
|
||||
-- | Update a branch at the given path, returning `True` if
|
||||
-- an update occurred and false otherwise
|
||||
updateAt ::
|
||||
Text ->
|
||||
Path.Absolute ->
|
||||
ProjectPath ->
|
||||
(Branch IO -> Branch IO) ->
|
||||
Cli Bool
|
||||
updateAt reason p f = do
|
||||
updateAtM reason p (pure . f)
|
||||
updateAt reason pp f = do
|
||||
updateAtM reason pp (pure . f)
|
||||
|
||||
updateAndStepAt ::
|
||||
(Foldable f, Foldable g) =>
|
||||
(Foldable f, Foldable g, Functor g) =>
|
||||
Text ->
|
||||
ProjectBranch ->
|
||||
f (Path.Absolute, Branch IO -> Branch IO) ->
|
||||
g (Path, Branch0 IO -> Branch0 IO) ->
|
||||
g (Path.Absolute, Branch0 IO -> Branch0 IO) ->
|
||||
Cli ()
|
||||
updateAndStepAt reason updates steps = do
|
||||
root <-
|
||||
(Branch.stepManyAt steps)
|
||||
. (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
|
||||
<$> getRootBranch
|
||||
updateRoot root reason
|
||||
updateAndStepAt reason projectBranch updates steps = do
|
||||
let f b =
|
||||
b
|
||||
& (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
|
||||
& (Branch.stepManyAt (first Path.unabsolute <$> steps))
|
||||
updateProjectBranchRoot_ projectBranch reason f
|
||||
|
||||
updateRoot :: Branch IO -> Text -> Cli ()
|
||||
updateRoot new reason =
|
||||
Cli.time "updateRoot" do
|
||||
Cli.Env {codebase} <- ask
|
||||
let newHash = Branch.headHash new
|
||||
oldHash <- getLastSavedRootHash
|
||||
when (oldHash /= newHash) do
|
||||
liftIO (Codebase.putRootBranch codebase reason new)
|
||||
setRootBranch new
|
||||
setLastSavedRootHash newHash
|
||||
updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r
|
||||
updateProjectBranchRoot projectBranch reason f = do
|
||||
currentPB <- getCurrentProjectBranch
|
||||
Cli.Env {codebase} <- ask
|
||||
Cli.time "updateProjectBranchRoot" do
|
||||
old <- getProjectBranchRoot projectBranch
|
||||
(new, result) <- f old
|
||||
liftIO $ Codebase.putBranch codebase new
|
||||
Cli.runTransaction $ do
|
||||
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 path = do
|
||||
rootBranch0 <- getRootBranch0
|
||||
pure (BranchUtil.getTerm (first Path.unabsolute path) rootBranch0)
|
||||
getTermsAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent)
|
||||
getTermsAt (pp, hqSeg) = do
|
||||
rootBranch0 <- getBranch0FromProjectPath pp
|
||||
pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting types
|
||||
|
||||
getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference)
|
||||
getTypesAt path = do
|
||||
rootBranch0 <- getRootBranch0
|
||||
pure (BranchUtil.getType (first Path.unabsolute path) rootBranch0)
|
||||
getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference)
|
||||
getTypesAt (pp, hqSeg) = do
|
||||
rootBranch0 <- getBranch0FromProjectPath pp
|
||||
pure (BranchUtil.getType (mempty, hqSeg) rootBranch0)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting patches
|
||||
@ -507,8 +495,8 @@ getPatchAt path =
|
||||
-- | Get the patch at a path.
|
||||
getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch)
|
||||
getMaybePatchAt path0 = do
|
||||
(path, name) <- resolveSplit' path0
|
||||
branch <- getBranch0At path
|
||||
(pp, name) <- resolveSplit' path0
|
||||
branch <- getBranch0FromProjectPath pp
|
||||
liftIO (Branch.getMaybePatch name branch)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
|
@ -5,7 +5,8 @@
|
||||
module Unison.Cli.Pretty
|
||||
( displayBranchHash,
|
||||
prettyAbsolute,
|
||||
prettyAbsoluteStripProject,
|
||||
prettyProjectPath,
|
||||
prettyBranchRelativePath,
|
||||
prettyBase32Hex#,
|
||||
prettyBase32Hex,
|
||||
prettyBranchId,
|
||||
@ -33,7 +34,6 @@ module Unison.Cli.Pretty
|
||||
prettyRepoInfo,
|
||||
prettySCH,
|
||||
prettySemver,
|
||||
prettyShareLink,
|
||||
prettySharePath,
|
||||
prettyShareURI,
|
||||
prettySlashProjectBranchName,
|
||||
@ -57,12 +57,10 @@ import Control.Monad.Writer (Writer, runWriter)
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
|
||||
import Network.URI (URI)
|
||||
import Network.URI qualified as URI
|
||||
import Network.URI.Encode qualified as URI
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Reference qualified as Reference
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
@ -70,23 +68,20 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Util.Base32Hex (Base32Hex)
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
|
||||
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
|
||||
import Unison.Cli.Share.Projects.Types qualified as Share
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadRemoteNamespace (..),
|
||||
ShareUserHandle (..),
|
||||
WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
shareUserHandleToText,
|
||||
)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||
import Unison.Core.Project (ProjectBranchName)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Debug qualified as Debug
|
||||
@ -126,6 +121,7 @@ import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
@ -150,7 +146,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty
|
||||
prettyReadRemoteNamespaceWith printProject =
|
||||
P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject
|
||||
|
||||
prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
||||
prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
||||
prettyWriteRemoteNamespace =
|
||||
P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace
|
||||
|
||||
@ -161,14 +157,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty
|
||||
prettyRepoInfo (Share.RepoInfo repoInfo) =
|
||||
P.blue (P.text repoInfo)
|
||||
|
||||
prettyShareLink :: WriteShareRemoteNamespace -> Pretty
|
||||
prettyShareLink WriteShareRemoteNamespace {repo, path} =
|
||||
let encodedPath =
|
||||
Path.toList path
|
||||
& fmap (URI.encodeText . NameSegment.toUnescapedText)
|
||||
& Text.intercalate "/"
|
||||
in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath
|
||||
|
||||
prettySharePath :: Share.Path -> Pretty
|
||||
prettySharePath =
|
||||
prettyRelative
|
||||
@ -194,16 +182,17 @@ prettyPath' p' =
|
||||
then "the current namespace"
|
||||
else P.blue (P.shown p')
|
||||
|
||||
prettyNamespaceKey :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
|
||||
prettyNamespaceKey :: Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
|
||||
prettyNamespaceKey = \case
|
||||
Left path -> prettyPath' path
|
||||
Left path -> prettyProjectPath path
|
||||
Right (ProjectAndBranch project branch) ->
|
||||
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
|
||||
|
||||
prettyBranchId :: Input.AbsBranchId -> Pretty
|
||||
prettyBranchId = \case
|
||||
Left sch -> prettySCH sch
|
||||
Right absPath -> prettyAbsolute $ absPath
|
||||
Input.BranchAtSCH sch -> prettySCH sch
|
||||
Input.BranchAtPath absPath -> prettyAbsolute $ absPath
|
||||
Input.BranchAtProjectPath pp -> prettyProjectPath pp
|
||||
|
||||
prettyRelative :: Path.Relative -> Pretty
|
||||
prettyRelative = P.blue . P.shown
|
||||
@ -211,6 +200,13 @@ prettyRelative = P.blue . P.shown
|
||||
prettyAbsolute :: Path.Absolute -> Pretty
|
||||
prettyAbsolute = P.blue . P.shown
|
||||
|
||||
prettyProjectPath :: PP.ProjectPath -> Pretty
|
||||
prettyProjectPath (PP.ProjectPath project branch path) =
|
||||
prettyProjectAndBranchName (ProjectAndBranch project.name branch.name)
|
||||
<>
|
||||
-- Only show the path if it's not the root
|
||||
Monoid.whenM (path /= Path.absoluteEmpty) (P.cyan (":" <> P.shown path))
|
||||
|
||||
prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s
|
||||
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
|
||||
|
||||
@ -271,6 +267,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName ->
|
||||
prettyProjectAndBranchName (ProjectAndBranch project branch) =
|
||||
P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch)
|
||||
|
||||
prettyBranchRelativePath :: BranchRelativePath -> Pretty
|
||||
prettyBranchRelativePath = P.blue . P.text . into @Text
|
||||
|
||||
-- produces:
|
||||
-- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0
|
||||
-- Optional.None, Maybe.Nothing : Maybe a
|
||||
@ -343,7 +342,7 @@ prettyTypeName ppe r =
|
||||
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
|
||||
prettyWhichBranchEmpty = \case
|
||||
WhichBranchEmptyHash hash -> P.shown hash
|
||||
WhichBranchEmptyPath path -> prettyPath' path
|
||||
WhichBranchEmptyPath pp -> prettyProjectPath pp
|
||||
|
||||
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
|
||||
displayBranchHash :: CausalHash -> Text
|
||||
@ -389,15 +388,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
|
||||
<> " on "
|
||||
<> P.shown host
|
||||
|
||||
stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path
|
||||
stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism
|
||||
|
||||
prettyAbsoluteStripProject :: Path.Absolute -> Pretty
|
||||
prettyAbsoluteStripProject path =
|
||||
P.blue case stripProjectBranchInfo path of
|
||||
Just p -> P.shown p
|
||||
Nothing -> P.shown path
|
||||
|
||||
prettyLabeledDependencies :: PPE.PrettyPrintEnv -> Set LabeledDependency -> Pretty
|
||||
prettyLabeledDependencies ppe lds =
|
||||
P.syntaxToColor (P.sep ", " (ld <$> toList lds))
|
||||
|
@ -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
|
||||
|
@ -1,21 +1,10 @@
|
||||
-- | Project-related utilities.
|
||||
module Unison.Cli.ProjectUtils
|
||||
( -- * Project/path helpers
|
||||
getCurrentProject,
|
||||
expectCurrentProject,
|
||||
expectCurrentProjectIds,
|
||||
getCurrentProjectIds,
|
||||
getCurrentProjectBranch,
|
||||
getProjectBranchForPath,
|
||||
expectCurrentProjectBranch,
|
||||
expectProjectBranchByName,
|
||||
projectPath,
|
||||
projectBranchesPath,
|
||||
projectBranchPath,
|
||||
projectBranchSegment,
|
||||
projectBranchPathPrism,
|
||||
resolveBranchRelativePath,
|
||||
branchRelativePathToAbsolute,
|
||||
resolveProjectBranch,
|
||||
resolveProjectBranchInProject,
|
||||
|
||||
-- * Name hydration
|
||||
hydrateNames,
|
||||
@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils
|
||||
-- * Loading local project info
|
||||
expectProjectAndBranchByIds,
|
||||
getProjectAndBranchByTheseNames,
|
||||
expectProjectAndBranchByTheseNames,
|
||||
getProjectAndBranchByNames,
|
||||
expectLooseCodeOrProjectBranch,
|
||||
expectProjectAndBranchByTheseNames,
|
||||
getProjectBranchCausalHash,
|
||||
|
||||
-- * Loading remote project info
|
||||
@ -59,65 +47,43 @@ import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Causal qualified
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.Share.Projects (IncludeSquashedHead)
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Input (LooseCodeOrProject)
|
||||
import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath)
|
||||
import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
|
||||
import Unison.Core.Project (ProjectBranchName (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
import Unison.Project.Util
|
||||
import Unison.Sqlite (Transaction)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
|
||||
branchRelativePathToAbsolute brp =
|
||||
resolveBranchRelativePath brp <&> \case
|
||||
BranchRelativePath.ResolvedLoosePath p -> p
|
||||
BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
|
||||
let projectBranchIds = getIds projectBranch
|
||||
handleRel = case mRel of
|
||||
Nothing -> id
|
||||
Just rel -> flip Path.resolve rel
|
||||
in handleRel (projectBranchPath projectBranchIds)
|
||||
where
|
||||
getIds = \case
|
||||
ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
|
||||
|
||||
resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath
|
||||
resolveBranchRelativePath = \case
|
||||
BranchRelativePath.BranchRelative brp -> case brp of
|
||||
This projectBranch -> do
|
||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing)
|
||||
That path -> do
|
||||
(projectBranch, _) <- expectCurrentProjectBranch
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
||||
These projectBranch path -> do
|
||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
||||
BranchRelativePath.LoosePath path ->
|
||||
BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path
|
||||
where
|
||||
toThese = \case
|
||||
Left branchName -> That branchName
|
||||
Right (projectName, branchName) -> These projectName branchName
|
||||
resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath
|
||||
resolveBranchRelativePath brp = do
|
||||
case brp of
|
||||
BranchPathInCurrentProject projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
QualifiedBranchPath projName projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
UnqualifiedPath newPath' -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||
|
||||
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
|
||||
justTheIds x =
|
||||
@ -152,58 +118,11 @@ findTemporaryBranchName projectId preferred = do
|
||||
|
||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||
|
||||
-- | Get the current project that a user is on.
|
||||
getCurrentProject :: Cli (Maybe Sqlite.Project)
|
||||
getCurrentProject = do
|
||||
path <- Cli.getCurrentPath
|
||||
case preview projectBranchPathPrism path of
|
||||
Nothing -> pure Nothing
|
||||
Just (ProjectAndBranch projectId _branchId, _restPath) ->
|
||||
Cli.runTransaction do
|
||||
project <- Queries.expectProject projectId
|
||||
pure (Just project)
|
||||
|
||||
-- | Like 'getCurrentProject', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProject :: Cli Sqlite.Project
|
||||
expectCurrentProject = do
|
||||
getCurrentProject & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- | Get the current project ids that a user is on.
|
||||
getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId))
|
||||
getCurrentProjectIds =
|
||||
fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath
|
||||
|
||||
-- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
expectCurrentProjectIds =
|
||||
getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- | Get the current project+branch+branch path that a user is on.
|
||||
getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
|
||||
getCurrentProjectBranch = do
|
||||
path <- Cli.getCurrentPath
|
||||
getProjectBranchForPath path
|
||||
|
||||
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
||||
expectProjectBranchByName project branchName =
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
|
||||
getProjectBranchForPath :: Path.Absolute -> Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
|
||||
getProjectBranchForPath path = do
|
||||
case preview projectBranchPathPrism path of
|
||||
Nothing -> pure Nothing
|
||||
Just (ProjectAndBranch projectId branchId, restPath) ->
|
||||
Cli.runTransaction do
|
||||
project <- Queries.expectProject projectId
|
||||
branch <- Queries.expectProjectBranch projectId branchId
|
||||
pure (Just (ProjectAndBranch project branch, restPath))
|
||||
|
||||
-- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProjectBranch :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)
|
||||
expectCurrentProjectBranch =
|
||||
getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- We often accept a `These ProjectName ProjectBranchName` from the user, so they can leave off either a project or
|
||||
-- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following
|
||||
-- defaults if a name is missing:
|
||||
@ -214,8 +133,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
|
||||
hydrateNames = \case
|
||||
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
||||
pure (ProjectAndBranch (project ^. #name) branchName)
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure (ProjectAndBranch (pp ^. #project . #name) branchName)
|
||||
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
||||
|
||||
getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
@ -244,11 +163,15 @@ getProjectAndBranchByTheseNames ::
|
||||
getProjectAndBranchByTheseNames = \case
|
||||
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> runMaybeT do
|
||||
(ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName))
|
||||
pure (ProjectAndBranch project branch)
|
||||
These projectName branchName ->
|
||||
Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName))
|
||||
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
|
||||
pure (ProjectAndBranch proj branch)
|
||||
These projectName branchName -> do
|
||||
Cli.runTransaction do
|
||||
runMaybeT do
|
||||
project <- MaybeT (Queries.loadProjectByName projectName)
|
||||
branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName)
|
||||
pure (ProjectAndBranch project branch)
|
||||
|
||||
-- Expect a local project branch by a "these names", using the following defaults if a name is missing:
|
||||
--
|
||||
@ -260,7 +183,7 @@ expectProjectAndBranchByTheseNames ::
|
||||
expectProjectAndBranchByTheseNames = \case
|
||||
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
||||
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
|
||||
branch <-
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
@ -275,31 +198,33 @@ expectProjectAndBranchByTheseNames = \case
|
||||
maybeProjectAndBranch & onNothing do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
|
||||
-- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules:
|
||||
-- | Expect/resolve branch reference with the following rules:
|
||||
--
|
||||
-- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database.
|
||||
-- 2. If we have an unambiguous `loose.code.path`, just return it.
|
||||
-- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*,
|
||||
-- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash).
|
||||
expectLooseCodeOrProjectBranch ::
|
||||
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ->
|
||||
Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
expectLooseCodeOrProjectBranch =
|
||||
_Right expectProjectAndBranchByTheseNames . f
|
||||
where
|
||||
f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName)
|
||||
f = \case
|
||||
This path -> Left path
|
||||
That (ProjectAndBranch Nothing branch) -> Right (That branch)
|
||||
That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
|
||||
These path _ -> Left path -- (3) above
|
||||
-- 1. If the project is missing, use the provided project.
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
||||
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||
pure projectAndBranch
|
||||
|
||||
-- | Expect/resolve branch reference with the following rules:
|
||||
--
|
||||
-- 1. If the project is missing, use the current project.
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranch pab = do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
resolveProjectBranchInProject (pp ^. #project) pab
|
||||
|
||||
-- | Get the causal hash of a project branch.
|
||||
getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash
|
||||
getProjectBranchCausalHash branch = do
|
||||
let path = projectBranchPath branch
|
||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
|
||||
pure causal.causalHash
|
||||
getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash
|
||||
getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
Q.expectCausalHash causalHashId
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Remote project utils
|
||||
@ -384,7 +309,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
That branchName -> do
|
||||
(ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch
|
||||
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
|
||||
let localProjectId = localProject ^. #projectId
|
||||
let localBranchId = localBranch ^. #branchId
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
|
@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (unsnoc)
|
||||
import Data.Foldable qualified as Foldable
|
||||
import Data.Maybe (fromJust)
|
||||
import U.Codebase.Branch qualified as Codebase.Branch
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.UniqueTypeGuidLookup qualified as Codebase
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
|
||||
loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid currentPath name0 = do
|
||||
-- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path
|
||||
-- to the unique type, plus its final distinguished name segment.
|
||||
let (branchPath, name) =
|
||||
name0
|
||||
& Path.fromName'
|
||||
& Path.resolve currentPath
|
||||
& Path.unabsolute
|
||||
& Path.toSeq
|
||||
& unsnoc
|
||||
-- This is safe because we were handed a Name, which can't be empty
|
||||
& fromJust
|
||||
loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid pp name0 = do
|
||||
let (namePath, finalSegment) = Path.splitFromName name0
|
||||
let fullPP = pp & over PP.path_ (<> namePath)
|
||||
|
||||
-- Define an operation to load a branch by its full path from the root namespace.
|
||||
--
|
||||
-- This ought to probably lean somewhat on a cache (so long as the caller is aware of the cache, and discrads it at
|
||||
-- an appropriate time, such as after the current unison file finishes parsing).
|
||||
let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||
loadBranchAtPath = Operations.loadBranchAtPath Nothing
|
||||
let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||
loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath
|
||||
|
||||
Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name
|
||||
Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment
|
||||
|
@ -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)
|
@ -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
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
That (ProjectAndBranch mProjectName branchName) -> do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
||||
Cli.expectBranchAtPath'
|
||||
( Path.absoluteToPath'
|
||||
( ProjectUtils.projectBranchPath
|
||||
(ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
|
||||
)
|
||||
)
|
||||
These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do
|
||||
absPath <- case branchId of
|
||||
Left hash -> jump =<< Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.resolvePath' path'
|
||||
mrelativePath <-
|
||||
Cli.getMaybeBranchAt absPath <&> \case
|
||||
Nothing -> Nothing
|
||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
||||
projectAndBranch <- do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
||||
thePath <- case (mrelativePath, projectAndBranch) of
|
||||
(Nothing, Nothing) ->
|
||||
ProjectUtils.getCurrentProject >>= \case
|
||||
Nothing -> pure absPath
|
||||
Just project ->
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
||||
Cli.returnEarlyWithoutOutput
|
||||
(Just _relativePath, Nothing) -> pure absPath
|
||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
Cli.expectBranchAtPath' (Path.absoluteToPath' thePath)
|
||||
|
||||
BranchAtPath p -> do
|
||||
pp <- Cli.resolvePath' p
|
||||
Cli.getBranchFromProjectPath pp
|
||||
BranchAtSCH sch -> Cli.resolveShortCausalHash sch
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
target <-
|
||||
case mtarget of
|
||||
Nothing -> Cli.getCurrentPath
|
||||
Just looseCodeOrProject -> case looseCodeOrProject of
|
||||
This path' -> Cli.resolvePath' path'
|
||||
That (ProjectAndBranch mProjectName branchName) -> do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
These path' (ProjectAndBranch mProjectName branchName) -> do
|
||||
absPath <- Cli.resolvePath' path'
|
||||
mrelativePath <-
|
||||
Cli.getMaybeBranchAt absPath <&> \case
|
||||
Nothing -> Nothing
|
||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
||||
projectAndBranch <- do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
||||
case (mrelativePath, projectAndBranch) of
|
||||
(Nothing, Nothing) ->
|
||||
ProjectUtils.getCurrentProject >>= \case
|
||||
Nothing -> pure absPath
|
||||
Just project ->
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
||||
Cli.returnEarlyWithoutOutput
|
||||
(Just _relativePath, Nothing) -> pure absPath
|
||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
Nothing -> Cli.getCurrentProjectPath
|
||||
Just unresolvedProjectAndBranch -> do
|
||||
targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch)
|
||||
pure $ PP.projectBranchRoot targetProjectAndBranch
|
||||
description <- inputDescription input
|
||||
_ <- Cli.updateAt description target (const newRoot)
|
||||
Cli.respond Success
|
||||
@ -335,22 +263,23 @@ loop e = do
|
||||
Cli.time "reset-root" do
|
||||
newRoot <-
|
||||
case src0 of
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||
BranchAtPath path' -> Cli.expectBranchAtPath' path'
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot newRoot description
|
||||
pb <- getCurrentProjectBranch
|
||||
void $ Cli.updateProjectBranchRoot_ pb description (const newRoot)
|
||||
Cli.respond Success
|
||||
ForkLocalBranchI src0 dest0 -> do
|
||||
(srcb, branchEmpty) <-
|
||||
case src0 of
|
||||
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
absPath <- ProjectUtils.branchRelativePathToAbsolute path'
|
||||
let srcp = Path.AbsolutePath' absPath
|
||||
srcb <- Cli.expectBranchAtPath' srcp
|
||||
pure (srcb, WhichBranchEmptyPath srcp)
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath path'
|
||||
srcb <- Cli.getBranchFromProjectPath srcPP
|
||||
pure (srcb, WhichBranchEmptyPath srcPP)
|
||||
description <- inputDescription input
|
||||
dest <- ProjectUtils.branchRelativePathToAbsolute dest0
|
||||
dest <- ProjectUtils.resolveBranchRelativePath dest0
|
||||
ok <- Cli.updateAtM description dest (const $ pure srcb)
|
||||
Cli.respond
|
||||
if ok
|
||||
@ -358,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
|
||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
||||
let srcp = looseCodeOrProjectToPath src0
|
||||
let destp = looseCodeOrProjectToPath dest0
|
||||
srcb <- Cli.expectBranchAtPath' srcp
|
||||
dest <- Cli.resolvePath' destp
|
||||
let err =
|
||||
Just $
|
||||
MergeAlreadyUpToDate
|
||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
|
||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
|
||||
mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
|
||||
PreviewMergeLocalBranchI src0 dest0 -> do
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||
(destPP, destBRP) <- case mayUnresolvedDest of
|
||||
Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_))
|
||||
Just unresolvedDest -> do
|
||||
ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest)
|
||||
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||
let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP
|
||||
mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP
|
||||
PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
||||
srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0
|
||||
dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0
|
||||
destb <- Cli.getBranchAt dest
|
||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||
if merged == destb
|
||||
then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0)
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||
destPP <- case mayUnresolvedDest of
|
||||
Nothing -> Cli.getCurrentProjectPath
|
||||
Just unresolvedDest -> do
|
||||
ProjectUtils.resolveBranchRelativePath unresolvedDest
|
||||
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||
destBranch <- Cli.getProjectBranchRoot destPP.branch
|
||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch)
|
||||
if merged == destBranch
|
||||
then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP)
|
||||
else do
|
||||
(ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff)
|
||||
(ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff)
|
||||
DiffNamespaceI before after -> do
|
||||
absBefore <- traverseOf _Right Cli.resolvePath' before
|
||||
absAfter <- traverseOf _Right Cli.resolvePath' after
|
||||
beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore
|
||||
afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter
|
||||
beforeLoc <- case before of
|
||||
BranchAtSCH sch -> pure $ Left sch
|
||||
BranchAtPath path' -> Right <$> Cli.resolvePath' path'
|
||||
BranchAtProjectPath pp -> pure $ Right pp
|
||||
afterLoc <- case after of
|
||||
BranchAtSCH sch -> pure $ Left sch
|
||||
BranchAtPath path' -> Right <$> Cli.resolvePath' path'
|
||||
BranchAtProjectPath pp -> pure $ Right pp
|
||||
beforeBranch0 <- Branch.head <$> Cli.resolveBranchId before
|
||||
afterBranch0 <- Branch.head <$> Cli.resolveBranchId after
|
||||
case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
|
||||
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
|
||||
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [])
|
||||
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| [])
|
||||
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc])
|
||||
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [])
|
||||
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| [])
|
||||
(False, False) -> pure ()
|
||||
(ppe, diff) <- diffHelper beforeBranch0 afterBranch0
|
||||
Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
|
||||
Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff)
|
||||
MoveBranchI src' dest' -> do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
description <- inputDescription input
|
||||
doMoveBranch description hasConfirmed src' dest'
|
||||
doMoveBranch description src' dest'
|
||||
SwitchBranchI path' -> do
|
||||
path <- Cli.resolvePath' path'
|
||||
branchExists <- Cli.branchExistsAtPath' path'
|
||||
when (not branchExists) (Cli.respond $ CreatedNewBranch path)
|
||||
Cli.cd path
|
||||
when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_))
|
||||
Cli.cd (path ^. PP.absPath_)
|
||||
UpI -> do
|
||||
path0 <- Cli.getCurrentPath
|
||||
whenJust (unsnoc path0) \(path, _) ->
|
||||
@ -416,10 +348,11 @@ loop e = do
|
||||
HistoryI resultsCap diffCap from -> do
|
||||
branch <-
|
||||
case from of
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
path <- Cli.resolvePath' path'
|
||||
Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
|
||||
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||
BranchAtPath path' -> do
|
||||
pp <- Cli.resolvePath' path'
|
||||
Cli.getBranchFromProjectPath pp
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
schLength <- Cli.runTransaction Codebase.branchHashLength
|
||||
history <- liftIO (doHistory schLength 0 branch [])
|
||||
Cli.respondNumbered history
|
||||
@ -437,7 +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'
|
||||
branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
|
||||
projPath <- ProjectUtils.resolveBranchRelativePath namespacePath'
|
||||
branch <- Cli.getBranchFromProjectPath projPath
|
||||
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
|
||||
pure ()
|
||||
AliasTermI force src' dest' -> do
|
||||
@ -490,7 +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'
|
||||
old <- Cli.getBranch0At destAbs
|
||||
destPP <- Cli.resolvePath' dest'
|
||||
old <- Cli.getBranch0FromProjectPath destPP
|
||||
description <- inputDescription input
|
||||
let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs
|
||||
Cli.stepManyAt description actions
|
||||
new <- Cli.getBranch0At destAbs
|
||||
let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs
|
||||
Cli.stepManyAt destPP.branch description actions
|
||||
new <- Cli.getBranch0FromProjectPath destPP
|
||||
(ppe, diff) <- diffHelper old new
|
||||
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff)
|
||||
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff)
|
||||
when (not (null unknown)) do
|
||||
Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown
|
||||
where
|
||||
@ -537,28 +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 = first Path.unabsolute $ Path.resolve dest hqsrc
|
||||
hqProposedDest :: Path.HQSplitAbsolute
|
||||
hqProposedDest = Path.resolve dest hqsrc
|
||||
-- `Nothing` if src doesn't exist
|
||||
doType :: Maybe [(Path, Branch0 m -> Branch0 m)]
|
||||
doType :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
doType = case ( BranchUtil.getType hqsrc currentBranch0,
|
||||
BranchUtil.getType hqProposedDest root0
|
||||
BranchUtil.getType (first Path.unabsolute hqProposedDest) root0
|
||||
) of
|
||||
(null -> True, _) -> Nothing -- missing src
|
||||
(rsrcs, existing) ->
|
||||
-- happy path
|
||||
Just . map addAlias . toList $ Set.difference rsrcs existing
|
||||
where
|
||||
addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m)
|
||||
addAlias r = BranchUtil.makeAddTypeName proposedDest r
|
||||
doTerm :: Maybe [(Path, Branch0 m -> Branch0 m)]
|
||||
doTerm :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0,
|
||||
BranchUtil.getTerm hqProposedDest root0
|
||||
BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0
|
||||
) of
|
||||
(null -> True, _) -> Nothing -- missing src
|
||||
(rsrcs, existing) ->
|
||||
@ -575,15 +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
|
||||
-- Use an absolutely qualified ppe for view.global
|
||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||
let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names)
|
||||
pure (names, pped)
|
||||
error "TODO: Implement names.global."
|
||||
else do
|
||||
names <- Cli.currentNames
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
@ -613,11 +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 Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
|
||||
[ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef),
|
||||
BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef)
|
||||
]
|
||||
currentPath <- Cli.getCurrentPath
|
||||
finalBranch <- Cli.getCurrentBranch0
|
||||
@ -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
|
||||
DeleteI dtarget -> case dtarget of
|
||||
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
|
||||
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
|
||||
DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
|
||||
DeleteTarget'Namespace insistence Nothing -> do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
if hasConfirmed || insistence == Force
|
||||
then do
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot Branch.empty description
|
||||
Cli.respond DeletedEverything
|
||||
else Cli.respond DeleteEverythingConfirmation
|
||||
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
|
||||
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
||||
description <- inputDescription input
|
||||
let toDelete =
|
||||
Names.prefix0
|
||||
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
||||
(Branch.toNames (Branch.head branch))
|
||||
afterDelete <- do
|
||||
names <- Cli.currentNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
||||
case (null endangerments, insistence) of
|
||||
(True, _) -> pure (Cli.respond Success)
|
||||
(False, Force) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
pure do
|
||||
Cli.respond Success
|
||||
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
||||
(False, Try) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
||||
Cli.returnEarlyWithoutOutput
|
||||
parentPathAbs <- Cli.resolvePath parentPath
|
||||
-- We have to modify the parent in order to also wipe out the history at the
|
||||
-- child.
|
||||
Cli.updateAt description parentPathAbs \parentBranch ->
|
||||
parentBranch
|
||||
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
||||
afterDelete
|
||||
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
||||
DeleteTarget'Project name -> handleDeleteProject name
|
||||
handleMoveAll src' dest' desc
|
||||
DeleteI dtarget -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg)
|
||||
let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg)
|
||||
case dtarget of
|
||||
DeleteTarget'TermOrType doutput hqs -> do
|
||||
delete input doutput getTerms getTypes hqs
|
||||
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs
|
||||
DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs
|
||||
DeleteTarget'Namespace insistence p@(parentPath, childName) -> do
|
||||
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
||||
description <- inputDescription input
|
||||
let toDelete =
|
||||
Names.prefix0
|
||||
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
||||
(Branch.toNames (Branch.head branch))
|
||||
afterDelete <- do
|
||||
names <- Cli.currentNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
||||
case (null endangerments, insistence) of
|
||||
(True, _) -> pure (Cli.respond Success)
|
||||
(False, Force) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
pure do
|
||||
Cli.respond Success
|
||||
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
||||
(False, Try) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
||||
Cli.returnEarlyWithoutOutput
|
||||
parentPathAbs <- Cli.resolvePath parentPath
|
||||
-- We have to modify the parent in order to also wipe out the history at the
|
||||
-- child.
|
||||
Cli.updateAt description parentPathAbs \parentBranch ->
|
||||
parentBranch
|
||||
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
||||
afterDelete
|
||||
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
||||
DeleteTarget'Project name -> handleDeleteProject name
|
||||
DisplayI outputLoc namesToDisplay -> do
|
||||
traverse_ (displayI outputLoc) namesToDisplay
|
||||
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
|
||||
@ -697,16 +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
|
||||
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp
|
||||
(_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
|
||||
Cli.respond (DisplayDebugCompletions completions)
|
||||
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
|
||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
|
||||
projectRoot <- Cli.getCurrentProjectRoot
|
||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot]
|
||||
DebugDumpNamespaceSimpleI -> do
|
||||
rootBranch0 <- Cli.getRootBranch0
|
||||
for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) ->
|
||||
projectRootBranch0 <- Cli.getCurrentProjectRoot0
|
||||
for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) ->
|
||||
traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
|
||||
for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) ->
|
||||
for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) ->
|
||||
traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
|
||||
DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
|
||||
DebugLSPFoldRangesI -> do
|
||||
@ -934,7 +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
|
||||
dest <- looseCodeOrProjectToText dest0
|
||||
let src = into @Text src0
|
||||
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
|
||||
That pr -> pure (into @Text pr)
|
||||
These hash _pr -> hp' hash
|
||||
BranchAtSCH hash -> hp' $ Left hash
|
||||
BranchAtPath pr -> pure $ into @Text pr
|
||||
BranchAtProjectPath pp -> pure $ into @Text pp
|
||||
tgt <- case tgt of
|
||||
Nothing -> pure ""
|
||||
Just tgt -> do
|
||||
tgt <- looseCodeOrProjectToText tgt
|
||||
pure (" " <> tgt)
|
||||
let tgtText = into @Text tgt
|
||||
pure (" " <> tgtText)
|
||||
pure ("reset " <> hashTxt <> tgt)
|
||||
ResetRootI src0 -> do
|
||||
src <- hp' src0
|
||||
let src = into @Text src0
|
||||
pure ("reset-root " <> src)
|
||||
AliasTermI 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
|
||||
ops :: Maybe Path.Split -> Cli Text
|
||||
ops = maybe (pure ".") ps
|
||||
brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath
|
||||
wat = error $ show input ++ " is not expected to alter the branch"
|
||||
hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
|
||||
hhqs' = \case
|
||||
@ -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
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames globalNames
|
||||
-- TODO: Rewrite to be properly global again
|
||||
projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
|
||||
currentBranch0 <- Cli.getCurrentBranch0
|
||||
pure (pped, globalNames, Nothing, currentBranch0)
|
||||
pure (pped, projectRootNames, Nothing, currentBranch0)
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
let getResults :: Names -> Cli [SearchResult]
|
||||
getResults names =
|
||||
@ -1316,16 +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
|
||||
terms <- getTerms absolute
|
||||
types <- getTypes (first PP.absPath 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
|
||||
resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
(pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
let resolvedSplit = (pp.absPath, ns)
|
||||
return
|
||||
( resolvedPath,
|
||||
Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
|
||||
hq ^. _2,
|
||||
hq ^. _3
|
||||
)
|
||||
(resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3)
|
||||
|
||||
-- get the splits and names with terms and types
|
||||
splitsNames <- traverse toSplitName typesTermsTuples
|
||||
let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref
|
||||
toRel setRef name = R.fromList (fmap (name,) (toList setRef))
|
||||
let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames
|
||||
-- make sure endangered is compeletely contained in paths
|
||||
-- TODO: We should just check for endangerments from the project root, not the
|
||||
-- global root!
|
||||
rootNames <- Branch.toNames <$> Cli.getRootBranch0
|
||||
projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
-- get only once for the entire deletion set
|
||||
let allTermsToDelete :: Set LabeledDependency
|
||||
allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
|
||||
@ -1574,7 +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)
|
||||
)
|
||||
)
|
||||
|
@ -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)
|
||||
|
@ -1,44 +1,42 @@
|
||||
-- | @branch@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.Branch
|
||||
( handleBranch,
|
||||
CreateFrom (..),
|
||||
doCreateBranch,
|
||||
doCreateBranch',
|
||||
( CreateFrom (..),
|
||||
handleBranch,
|
||||
createBranch,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.These (These (..))
|
||||
import Control.Monad.Reader
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (getBranchAt, getCurrentPath, updateAt)
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch (empty)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
|
||||
data CreateFrom
|
||||
= CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
| CreateFrom'LooseCode Path.Absolute
|
||||
= CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
|
||||
| CreateFrom'ParentBranch Sqlite.ProjectBranch
|
||||
| CreateFrom'Namespace (Branch IO)
|
||||
| CreateFrom'Nothingness
|
||||
|
||||
-- | Create a new project branch from an existing project branch or namespace.
|
||||
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleBranch sourceI projectAndBranchNames0 = do
|
||||
projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <-
|
||||
case projectAndBranchNames0 of
|
||||
ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName)
|
||||
ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName)
|
||||
|
||||
handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do
|
||||
-- You can only create release branches with `branch.clone`
|
||||
--
|
||||
-- We do allow creating draft release branches with `branch`, but you'll get different output if you use
|
||||
@ -50,93 +48,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 ->
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath
|
||||
Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch)
|
||||
Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness
|
||||
Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath))
|
||||
Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) ->
|
||||
fmap CreateFrom'Branch do
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case sourceBranch of
|
||||
ProjectAndBranch Nothing b -> That b
|
||||
ProjectAndBranch (Just p) b -> These p b
|
||||
-- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a
|
||||
-- branch from a relative one-segment namespace.
|
||||
--
|
||||
-- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they
|
||||
-- really meant create a branch from that namespace.
|
||||
Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) ->
|
||||
fmap CreateFrom'Branch do
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case sourceBranch of
|
||||
ProjectAndBranch Nothing b -> That b
|
||||
ProjectAndBranch (Just p) b -> These p b
|
||||
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
|
||||
Input.BranchSourceI'Empty -> pure Nothing
|
||||
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
|
||||
|
||||
project <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
|
||||
_ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
|
||||
case maySrcProjectAndBranch of
|
||||
Just srcProjectAndBranch -> do
|
||||
let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name))
|
||||
void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName)
|
||||
Nothing -> do
|
||||
let description = "Empty branch created"
|
||||
void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName)
|
||||
|
||||
Cli.respond $
|
||||
Output.CreatedProjectBranch
|
||||
( case createFrom of
|
||||
CreateFrom'Branch sourceBranch ->
|
||||
if sourceBranch ^. #project . #projectId == project ^. #projectId
|
||||
( case maySrcProjectAndBranch of
|
||||
Just sourceBranch ->
|
||||
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
|
||||
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
||||
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
||||
CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path
|
||||
CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness
|
||||
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
||||
)
|
||||
projectAndBranchNames
|
||||
(projectAndBranchNames & #project .~ projectName)
|
||||
|
||||
-- | @doCreateBranch createFrom project branch description@:
|
||||
-- | @createBranchFromParent createFrom project branch description@:
|
||||
--
|
||||
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@)
|
||||
-- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog.
|
||||
-- 3. cds to the new branch in the root namespace.
|
||||
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@).
|
||||
-- 3. Switches to the new branch.
|
||||
--
|
||||
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
|
||||
-- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
|
||||
--
|
||||
-- Returns the branch id of the newly-created branch.
|
||||
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
|
||||
doCreateBranch createFrom project newBranchName description = do
|
||||
sourceNamespaceObject <-
|
||||
case createFrom of
|
||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do
|
||||
let sourceProjectId = sourceBranch ^. #projectId
|
||||
let sourceBranchId = sourceBranch ^. #branchId
|
||||
Cli.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 ->
|
||||
createBranch ::
|
||||
Text ->
|
||||
CreateFrom ->
|
||||
Sqlite.Project ->
|
||||
Sqlite.Transaction ProjectBranchName ->
|
||||
Text ->
|
||||
Cli (ProjectBranchId, ProjectBranchName)
|
||||
doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do
|
||||
createBranch description createFrom project getNewBranchName = do
|
||||
let projectId = project ^. #projectId
|
||||
(newBranchId, newBranchName) <-
|
||||
Cli.Env {codebase} <- ask
|
||||
(mayParentBranchId, newBranchCausalHashId) <- case createFrom of
|
||||
CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do
|
||||
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 (newBranchId, newBranchName)
|
||||
pure (newBranchName, newBranchId)
|
||||
|
||||
let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
|
||||
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
|
||||
Cli.cd newBranchPath
|
||||
Cli.switchProject (ProjectAndBranch projectId newBranchId)
|
||||
pure (newBranchId, newBranchName)
|
||||
|
@ -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 ()
|
||||
|
@ -10,14 +10,14 @@ import Network.URI (URI)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectBranchName, ProjectName)
|
||||
|
||||
handleBranches :: Maybe ProjectName -> Cli ()
|
||||
handleBranches maybeProjectName = do
|
||||
maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
(project, branches) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
project <-
|
||||
@ -26,8 +26,7 @@ handleBranches maybeProjectName = do
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
rollback (Output.LocalProjectDoesntExist projectName)
|
||||
Nothing -> do
|
||||
ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch)
|
||||
Queries.expectProject projectId
|
||||
pure (pp ^. #project)
|
||||
branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId)
|
||||
pure (project, branches)
|
||||
Cli.respondNumbered (Output.ListBranches (project ^. #name) (f branches))
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -5,8 +5,7 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
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.Path qualified as Path
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectCreate
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
-- | Delete a project branch.
|
||||
@ -27,44 +27,50 @@ import Witch (unsafeFrom)
|
||||
-- project.
|
||||
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleDeleteBranch projectAndBranchNamesToDelete = do
|
||||
projectAndBranchToDelete <-
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case projectAndBranchNamesToDelete of
|
||||
ProjectAndBranch Nothing branch -> That branch
|
||||
ProjectAndBranch (Just project) branch -> These project branch
|
||||
|
||||
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
|
||||
doDeleteProjectBranch projectAndBranchToDelete
|
||||
ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath
|
||||
projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just)
|
||||
|
||||
-- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
|
||||
--
|
||||
-- 1. cd to parent branch, if it exists
|
||||
-- 2. cd to "main", if it exists
|
||||
-- 3. cd to loose code path `.`
|
||||
whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
|
||||
when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
|
||||
newPath <-
|
||||
case projectAndBranchToDelete.branch.parentBranchId of
|
||||
Nothing ->
|
||||
let loadMain =
|
||||
Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
|
||||
in Cli.runTransaction loadMain <&> \case
|
||||
Nothing -> Path.Absolute Path.empty
|
||||
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
|
||||
Just parentBranchId ->
|
||||
pure $
|
||||
ProjectUtils.projectBranchPath
|
||||
(ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
|
||||
Cli.cd newPath
|
||||
-- 3. Any other branch in the codebase
|
||||
-- 4. Create a dummy project and go to /main
|
||||
when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do
|
||||
mayNextLocation <-
|
||||
Cli.runTransaction . runMaybeT $
|
||||
asum
|
||||
[ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId),
|
||||
findMainBranchInProject (currentProject ^. #projectId),
|
||||
findAnyBranchInProject (currentProject ^. #projectId),
|
||||
findAnyBranchInCodebase,
|
||||
createDummyProject
|
||||
]
|
||||
nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing
|
||||
Cli.switchProject nextLoc
|
||||
doDeleteProjectBranch projectAndBranchToDelete
|
||||
where
|
||||
parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
parentBranch projectId mayParentBranchId = do
|
||||
parentBranchId <- hoistMaybe mayParentBranchId
|
||||
pure (ProjectAndBranch projectId parentBranchId)
|
||||
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))
|
||||
)
|
||||
|
@ -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.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
import Unison.Project (ProjectName)
|
||||
|
||||
-- | Delete a project
|
||||
handleDeleteProject :: ProjectName -> Cli ()
|
||||
handleDeleteProject projectName = do
|
||||
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath
|
||||
|
||||
deletedProject <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
@ -29,14 +28,8 @@ handleDeleteProject projectName = do
|
||||
Queries.deleteProject (project ^. #projectId)
|
||||
pure project
|
||||
|
||||
let projectId = deletedProject ^. #projectId
|
||||
|
||||
Cli.updateAt
|
||||
("delete.project " <> into @Text projectName)
|
||||
(ProjectUtils.projectPath projectId)
|
||||
(const Branch.empty)
|
||||
|
||||
-- If the user is on the project that they're deleting, we cd to the root path
|
||||
whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) ->
|
||||
when (on (==) (view #projectId) deletedProject currentProject) do
|
||||
Cli.cd (Path.Absolute Path.empty)
|
||||
-- If the user is on the project that they're deleting, we create a new project to switch
|
||||
-- to.
|
||||
when (((==) `on` (view #projectId)) deletedProject currentProject) do
|
||||
nextLoc <- projectCreate False Nothing
|
||||
Cli.switchProject nextLoc
|
||||
|
@ -10,8 +10,6 @@ import Data.Map.Strict qualified as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
|
||||
import Unison.Cli.DownloadUtils
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -22,6 +20,7 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Core.Project (ProjectBranchName)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment (libSegment)
|
||||
@ -40,14 +39,6 @@ import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText)
|
||||
|
||||
handleInstallLib :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli ()
|
||||
handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do
|
||||
(currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
|
||||
let currentProjectBranchPath =
|
||||
ProjectUtils.projectBranchPath $
|
||||
ProjectAndBranch
|
||||
currentProjectAndBranch.project.projectId
|
||||
currentProjectAndBranch.branch.branchId
|
||||
|
||||
libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName
|
||||
|
||||
libdepBranchName <-
|
||||
@ -79,7 +70,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran
|
||||
--
|
||||
-- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3".
|
||||
libdepNameSegment :: NameSegment <- do
|
||||
currentBranchObject <- Cli.getBranch0At currentProjectBranchPath
|
||||
currentBranchObject <- Cli.getCurrentProjectRoot0
|
||||
pure $
|
||||
fresh
|
||||
(\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText)
|
||||
@ -90,13 +81,12 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran
|
||||
(makeDependencyName libdepProjectName libdepBranchName)
|
||||
|
||||
let libdepPath :: Path.Absolute
|
||||
libdepPath =
|
||||
Path.resolve
|
||||
currentProjectBranchPath
|
||||
(Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment]))
|
||||
libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment]
|
||||
|
||||
let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames
|
||||
_didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject)
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let libDepPP = pp & PP.absPath_ .~ libdepPath
|
||||
_didUpdate <- Cli.updateAt reflogDescription libDepPP (\_empty -> remoteBranchObject)
|
||||
|
||||
Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment)
|
||||
|
||||
|
@ -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 <-
|
||||
|
@ -8,9 +8,11 @@ import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
@ -18,9 +20,9 @@ import Unison.Server.Backend qualified as Backend
|
||||
handleLs :: Path' -> Cli ()
|
||||
handleLs pathArg = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
pathArgAbs <- Cli.resolvePath' pathArg
|
||||
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
|
||||
pp <- Cli.resolvePath' pathArg
|
||||
projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch
|
||||
entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath))
|
||||
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
|
@ -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'
|
||||
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
||||
(Just info.alice.projectAndBranch.branch.branchId)
|
||||
HandleInput.Branch.createBranch
|
||||
info.description
|
||||
(HandleInput.Branch.CreateFrom'NamespaceWithParent info.alice.projectAndBranch.branch (Branch.mergeNode stageOneBranch parents.alice parents.bob))
|
||||
info.alice.projectAndBranch.project
|
||||
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||
info.description
|
||||
|
||||
scratchFilePath <-
|
||||
Cli.getLatestFile <&> \case
|
||||
Nothing -> "scratch.u"
|
||||
@ -423,11 +425,10 @@ doMerge info = do
|
||||
Just tuf -> do
|
||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||
_ <-
|
||||
Cli.updateAt
|
||||
info.description
|
||||
alicePath
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
Cli.updateProjectBranchRoot_
|
||||
info.alice.projectAndBranch.branch
|
||||
info.description
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
pure (Output.MergeSuccess mergeSourceAndTarget)
|
||||
|
||||
Cli.respond finalOutput
|
||||
@ -436,8 +437,8 @@ doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
|
||||
doMergeLocalBranch branches = do
|
||||
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
|
||||
Cli.runTransaction do
|
||||
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
|
||||
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
|
||||
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch)
|
||||
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch)
|
||||
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
|
||||
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
|
||||
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
|
||||
|
@ -11,9 +11,9 @@ import Unison.Codebase.Path qualified as Path
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Prelude
|
||||
|
||||
handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli ()
|
||||
handleMoveAll hasConfirmed src' dest' description = do
|
||||
moveBranchFunc <- moveBranchFunc hasConfirmed src' dest'
|
||||
handleMoveAll :: Path.Path' -> Path.Path' -> Text -> Cli ()
|
||||
handleMoveAll src' dest' description = do
|
||||
moveBranchFunc <- moveBranchFunc src' dest'
|
||||
moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
|
||||
Nothing -> pure []
|
||||
Just (fmap HQ'.NameOnly -> src, dest) -> do
|
||||
@ -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
|
||||
|
@ -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))
|
||||
moveBranchFunc hasConfirmed src' dest' = do
|
||||
srcAbs <- Cli.resolvePath' src'
|
||||
destAbs <- Cli.resolvePath' dest'
|
||||
-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if
|
||||
-- needed.
|
||||
moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
|
||||
moveBranchFunc src' dest' = do
|
||||
-- We currently only support moving within the same project branch.
|
||||
srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src'
|
||||
PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest'
|
||||
destBranchExists <- Cli.branchExistsAtPath' dest'
|
||||
let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
|
||||
when (isRootMove && not hasConfirmed) do
|
||||
Cli.returnEarly MoveRootBranchConfirmation
|
||||
Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
|
||||
Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do
|
||||
-- We want the move to appear as a single step in the root namespace, but we need to make
|
||||
-- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
|
||||
-- those changes such that they appear as a single change in the root.
|
||||
@ -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 actionDescription hasConfirmed src' dest' = do
|
||||
moveBranchFunc hasConfirmed src' dest' >>= \case
|
||||
doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli ()
|
||||
doMoveBranch actionDescription src' dest' = do
|
||||
moveBranchFunc src' dest' >>= \case
|
||||
Nothing -> Cli.respond (BranchNotFound src')
|
||||
Just (path, func) -> do
|
||||
_ <- Cli.updateAt actionDescription path func
|
||||
Just (absPath, func) -> do
|
||||
pp <- Cli.resolvePath' (Path.AbsolutePath' absPath)
|
||||
_ <- Cli.updateAt actionDescription pp func
|
||||
Cli.respond Success
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -14,7 +14,6 @@ import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
@ -22,7 +21,6 @@ import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Reference qualified as Reference
|
||||
@ -35,19 +33,16 @@ import Unison.Util.Relation qualified as Relation
|
||||
handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli ()
|
||||
handleNamespaceDependencies namespacePath' = do
|
||||
Cli.Env {codebase} <- ask
|
||||
path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath'
|
||||
pp <- maybe Cli.getCurrentProjectPath Cli.resolvePath' namespacePath'
|
||||
let pb = pp ^. #branch
|
||||
branch <-
|
||||
Cli.getMaybeBranch0At path & onNothingM do
|
||||
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path)))
|
||||
Cli.getMaybeBranch0FromProjectPath pp & onNothingM do
|
||||
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp))
|
||||
externalDependencies <-
|
||||
Cli.runTransaction (namespaceDependencies codebase branch)
|
||||
currentPPED <- Cli.currentPrettyPrintEnvDecl
|
||||
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
|
||||
globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames
|
||||
-- We explicitly include a global unsuffixified fallback on namespace dependencies since
|
||||
-- the things we want names for are obviously outside of our scope.
|
||||
let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback globalPPED currentPPED
|
||||
Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies
|
||||
pped <- Cli.projectBranchPPED pb
|
||||
let ppe = PPED.unsuffixifiedPPE pped
|
||||
Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies
|
||||
|
||||
-- | Check the dependencies of all types and terms in the current namespace,
|
||||
-- returns a map of dependencies which do not have a name within the current namespace,
|
||||
|
@ -5,24 +5,21 @@ module Unison.Codebase.Editor.HandleInput.ProjectClone
|
||||
where
|
||||
|
||||
import Control.Lens (_2)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.These (These (..))
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||
import U.Codebase.Sqlite.DbId qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (updateAt)
|
||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch)
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -39,9 +36,9 @@ data RemoteProjectKey
|
||||
-- | Clone a remote branch.
|
||||
handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
|
||||
handleClone remoteNames0 maybeLocalNames0 = do
|
||||
maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
|
||||
localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||
currentProjectBranch <- Cli.getCurrentProjectAndBranch
|
||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0
|
||||
localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||
cloneInto localNames1 resolvedRemoteNames.branch
|
||||
|
||||
data ResolvedRemoteNames = ResolvedRemoteNames
|
||||
@ -78,63 +75,59 @@ data ResolvedRemoteNamesFrom
|
||||
-- otherwise abort
|
||||
resolveRemoteNames ::
|
||||
Share.IncludeSquashedHead ->
|
||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
||||
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||
ProjectAndBranchNames ->
|
||||
Cli ResolvedRemoteNames
|
||||
resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
||||
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
|
||||
case maybeCurrentProjectBranch of
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just (currentProjectAndBranch, _path) ->
|
||||
case projectNameUserSlug remoteProjectName of
|
||||
Nothing -> resolveB remoteBranchName
|
||||
Just _ ->
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just remoteBranchProjectId -> do
|
||||
-- Fetching these in parallel would be an improvement
|
||||
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
||||
maybeRemoteBranch <-
|
||||
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
||||
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||
(Just remoteProject, Nothing) -> do
|
||||
let remoteProjectId = remoteProject.projectId
|
||||
let remoteProjectName = remoteProject.projectName
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Project
|
||||
}
|
||||
(Nothing, Just remoteBranch) ->
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Branch
|
||||
}
|
||||
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
||||
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
||||
-- wouldn't help, because we did enough work to know neither thing exists"
|
||||
_ -> do
|
||||
branchProjectName <-
|
||||
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneRemote
|
||||
remoteProjectName
|
||||
(ProjectAndBranch branchProjectName remoteBranchName)
|
||||
resolveRemoteNames includeSquashed currentProjectAndBranch = \case
|
||||
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do
|
||||
case projectNameUserSlug remoteProjectName of
|
||||
Nothing -> resolveB remoteBranchName
|
||||
Just _ ->
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just remoteBranchProjectId -> do
|
||||
-- Fetching these in parallel would be an improvement
|
||||
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
||||
maybeRemoteBranch <-
|
||||
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
||||
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||
(Just remoteProject, Nothing) -> do
|
||||
let remoteProjectId = remoteProject.projectId
|
||||
let remoteProjectName = remoteProject.projectName
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Project
|
||||
}
|
||||
(Nothing, Just remoteBranch) ->
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Branch
|
||||
}
|
||||
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
||||
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
||||
-- wouldn't help, because we did enough work to know neither thing exists"
|
||||
_ -> do
|
||||
branchProjectName <-
|
||||
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneRemote
|
||||
remoteProjectName
|
||||
(ProjectAndBranch branchProjectName remoteBranchName)
|
||||
ProjectAndBranchNames'Unambiguous (This p) -> resolveP p
|
||||
ProjectAndBranchNames'Unambiguous (That b) -> resolveB b
|
||||
ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b
|
||||
where
|
||||
resolveB branchName = do
|
||||
(currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
remoteProjectId <-
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do
|
||||
Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch)
|
||||
@ -181,11 +174,11 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
||||
-- `clone @foo/bar` resulted in treating `@foo/bar` as a contributor branch of the current project, then it is as if
|
||||
-- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`.
|
||||
resolveLocalNames ::
|
||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
||||
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||
ResolvedRemoteNames ->
|
||||
Maybe ProjectAndBranchNames ->
|
||||
Cli (ProjectAndBranch LocalProjectKey ProjectBranchName)
|
||||
resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames =
|
||||
resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames =
|
||||
resolve case maybeLocalNames of
|
||||
Nothing ->
|
||||
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
|
||||
@ -199,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
|
||||
resolve names =
|
||||
case names of
|
||||
ProjectAndBranchNames'Ambiguous localProjectName localBranchName ->
|
||||
case maybeCurrentProjectBranch of
|
||||
Nothing -> resolveP localProjectName
|
||||
Just (ProjectAndBranch currentProject _, _path) -> do
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneLocal
|
||||
(ProjectAndBranch localProjectName remoteBranchName)
|
||||
(ProjectAndBranch currentProject.name localBranchName)
|
||||
ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneLocal
|
||||
(ProjectAndBranch localProjectName remoteBranchName)
|
||||
(ProjectAndBranch currentProject.name localBranchName)
|
||||
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
|
||||
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
|
||||
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
|
||||
@ -215,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
go (LocalProjectKey'Name localProjectName) remoteBranchName
|
||||
|
||||
resolveB localBranchName = do
|
||||
(ProjectAndBranch currentProject _, _path) <-
|
||||
maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
go (LocalProjectKey'Project currentProject) localBranchName
|
||||
|
||||
resolvePB localProjectName localBranchName =
|
||||
@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
pure (localProjectId, localProjectName)
|
||||
Right localProject -> pure (localProject.projectId, localProject.name)
|
||||
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
causalHashId <- Q.expectCausalHashIdByCausalHash branchHead
|
||||
let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName)
|
||||
Queries.insertProjectBranch
|
||||
description
|
||||
causalHashId
|
||||
Sqlite.ProjectBranch
|
||||
{ projectId = localProjectId,
|
||||
branchId = localBranchId,
|
||||
@ -277,12 +269,8 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
localProjectBranch.branch
|
||||
)
|
||||
|
||||
-- Manipulate the root namespace and cd
|
||||
Cli.Env {codebase} <- ask
|
||||
theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead)
|
||||
let path = projectBranchPath (over #project fst localProjectAndBranch)
|
||||
Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch)
|
||||
Cli.cd path
|
||||
let newProjectAndBranch = (over #project fst localProjectAndBranch)
|
||||
Cli.switchProject newProjectAndBranch
|
||||
|
||||
-- Return the remote project id associated with the given project branch
|
||||
loadAssociatedRemoteProjectId ::
|
||||
|
@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import System.Random.Shuffle qualified as RandomShuffle
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
|
||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Causal qualified as Causal
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
@ -55,14 +55,12 @@ import Witch (unsafeFrom)
|
||||
--
|
||||
-- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too
|
||||
-- much time getting everything perfectly correct before we get there.
|
||||
projectCreate :: Bool -> Maybe ProjectName -> Cli ()
|
||||
projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
projectCreate tryDownloadingBase maybeProjectName = do
|
||||
projectId <- liftIO (ProjectId <$> UUID.nextRandom)
|
||||
branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
(_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash
|
||||
|
||||
projectName <-
|
||||
(project, branch) <-
|
||||
case maybeProjectName of
|
||||
Nothing -> do
|
||||
randomProjectNames <- liftIO generateRandomProjectNames
|
||||
@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
let loop = \case
|
||||
[] -> error (reportBug "E066388" "project name supply is supposed to be infinite")
|
||||
projectName : projectNames ->
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
True -> loop projectNames
|
||||
Queries.loadProjectByName projectName >>= \case
|
||||
Nothing -> do
|
||||
(project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||
pure (project, branch)
|
||||
Just _project -> loop projectNames
|
||||
loop randomProjectNames
|
||||
Just projectName -> do
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||
True -> rollback (Output.ProjectNameAlreadyExists projectName)
|
||||
|
||||
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
|
||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
|
||||
Cli.cd path
|
||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
|
||||
Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)
|
||||
|
||||
maybeBaseLatestReleaseBranchObject <-
|
||||
if tryDownloadingBase
|
||||
@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
pure maybeBaseLatestReleaseBranchObject
|
||||
else pure Nothing
|
||||
|
||||
let projectBranchObject =
|
||||
case maybeBaseLatestReleaseBranchObject of
|
||||
Nothing -> Branch.empty0
|
||||
Just baseLatestReleaseBranchObject ->
|
||||
let -- lib.base
|
||||
projectBranchLibBaseObject =
|
||||
over
|
||||
Branch.children
|
||||
(Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject)
|
||||
Branch.empty0
|
||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||
in over
|
||||
Branch.children
|
||||
(Map.insert NameSegment.libSegment projectBranchLibObject)
|
||||
Branch.empty0
|
||||
|
||||
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
|
||||
for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do
|
||||
-- lib.base
|
||||
let projectBranchLibBaseObject =
|
||||
Branch.empty0
|
||||
& Branch.children
|
||||
. at NameSegment.baseSegment
|
||||
.~ Just baseLatestReleaseBranchObject
|
||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||
let branchWithBase =
|
||||
Branch.empty
|
||||
& Branch.history
|
||||
. Causal.head_
|
||||
. Branch.children
|
||||
. at NameSegment.libSegment
|
||||
.~ Just projectBranchLibObject
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ Codebase.putBranch codebase branchWithBase
|
||||
Cli.runTransaction $ do
|
||||
baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase)
|
||||
Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId
|
||||
|
||||
Cli.respond Output.HappyCoding
|
||||
where
|
||||
reflogDescription =
|
||||
case maybeProjectName of
|
||||
Nothing -> "project.create"
|
||||
Just projectName -> "project.create " <> into @Text projectName
|
||||
pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}
|
||||
|
||||
-- An infinite list of random project names that looks like
|
||||
--
|
||||
|
@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
|
||||
handleProjectRename :: ProjectName -> Cli ()
|
||||
handleProjectRename newName = do
|
||||
project <- ProjectUtils.expectCurrentProject
|
||||
let oldName = project ^. #name
|
||||
ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch
|
||||
let oldName = project.name
|
||||
when (oldName /= newName) do
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.loadProjectByName newName >>= \case
|
||||
Just _ -> rollback (Output.ProjectNameAlreadyExists newName)
|
||||
Nothing -> Queries.renameProject (project ^. #projectId) newName
|
||||
Nothing -> Queries.renameProject project.projectId newName
|
||||
Cli.respond (Output.RenamedProject oldName newName)
|
||||
|
@ -5,11 +5,11 @@ module Unison.Codebase.Editor.HandleInput.ProjectSwitch
|
||||
where
|
||||
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Sqlite.Project qualified
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
@ -28,51 +28,46 @@ import Witch (unsafeFrom)
|
||||
projectSwitch :: ProjectAndBranchNames -> Cli ()
|
||||
projectSwitch projectNames = do
|
||||
case projectNames of
|
||||
ProjectAndBranchNames'Ambiguous projectName branchName ->
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> switchToProjectAndBranchByTheseNames (This projectName)
|
||||
Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do
|
||||
(projectExists, branchExists) <-
|
||||
Cli.runTransaction do
|
||||
(,)
|
||||
<$> Queries.projectExistsByName projectName
|
||||
<*> Queries.projectBranchExistsByName currentProject.projectId branchName
|
||||
case (projectExists, branchExists) of
|
||||
(False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
|
||||
(False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
|
||||
(True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
|
||||
(True, True) ->
|
||||
Cli.respondNumbered $
|
||||
Output.AmbiguousSwitch
|
||||
projectName
|
||||
(ProjectAndBranch currentProject.name branchName)
|
||||
ProjectAndBranchNames'Ambiguous projectName branchName -> do
|
||||
ProjectAndBranch currentProject _currentBranch <- Cli.getCurrentProjectAndBranch
|
||||
(projectExists, branchExists) <-
|
||||
Cli.runTransaction do
|
||||
(,)
|
||||
<$> Queries.projectExistsByName projectName
|
||||
<*> Queries.projectBranchExistsByName currentProject.projectId branchName
|
||||
case (projectExists, branchExists) of
|
||||
(False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
|
||||
(False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
|
||||
(True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
|
||||
(True, True) ->
|
||||
Cli.respondNumbered $
|
||||
Output.AmbiguousSwitch
|
||||
projectName
|
||||
(ProjectAndBranch currentProject.name branchName)
|
||||
ProjectAndBranchNames'Unambiguous projectAndBranchNames0 ->
|
||||
switchToProjectAndBranchByTheseNames projectAndBranchNames0
|
||||
|
||||
switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli ()
|
||||
switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
|
||||
branch <-
|
||||
case projectAndBranchNames0 of
|
||||
This projectName ->
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
project <-
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
rollback (Output.LocalProjectDoesntExist projectName)
|
||||
Queries.loadMostRecentBranch project.projectId >>= \case
|
||||
Nothing -> do
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
branch <-
|
||||
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
||||
pure branch
|
||||
Just branchId -> Queries.expectProjectBranch project.projectId branchId
|
||||
_ -> do
|
||||
projectAndBranchNames <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
branch <-
|
||||
Queries.loadProjectBranchByNames projectAndBranchNames.project projectAndBranchNames.branch & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
||||
pure branch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId))
|
||||
branch <- case projectAndBranchNames0 of
|
||||
This projectName ->
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
project <-
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
rollback (Output.LocalProjectDoesntExist projectName)
|
||||
Queries.loadMostRecentBranch (project ^. #projectId) >>= \case
|
||||
Nothing -> do
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
branch <-
|
||||
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
pure branch
|
||||
Just branchId -> Queries.expectProjectBranch project.projectId branchId
|
||||
_ -> do
|
||||
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
branch <-
|
||||
Queries.loadProjectBranchByNames projectName branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
pure branch
|
||||
Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId))
|
||||
|
@ -21,9 +21,9 @@ import Unison.Cli.MergeTypes (MergeSource (..))
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
@ -34,13 +34,11 @@ import Unison.Codebase.Editor.Input
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
|
||||
import Unison.Codebase.Editor.Propagate qualified as Propagate
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.CommandLine.InputPattern qualified as InputPattern
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
@ -76,8 +74,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
||||
|
||||
when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
|
||||
|
||||
let targetAbsolutePath =
|
||||
ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId)
|
||||
let targetProjectPath = PP.projectBranchRoot (ProjectAndBranch target.project target.branch)
|
||||
|
||||
let description =
|
||||
Text.unwords
|
||||
@ -92,22 +89,18 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
||||
|
||||
case pullMode of
|
||||
Input.PullWithHistory -> do
|
||||
targetBranchObject <- Cli.getBranch0At targetAbsolutePath
|
||||
targetBranch <- Cli.getBranchFromProjectPath targetProjectPath
|
||||
|
||||
if Branch.isEmpty0 targetBranchObject
|
||||
if Branch.isEmpty0 $ Branch.head targetBranch
|
||||
then do
|
||||
Cli.Env {codebase} <- ask
|
||||
remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
|
||||
void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject)
|
||||
void $ Cli.updateAtM description targetProjectPath (const $ pure remoteBranchObject)
|
||||
Cli.respond $ MergeOverEmpty target
|
||||
else do
|
||||
Cli.respond AboutToMerge
|
||||
|
||||
aliceCausalHash <-
|
||||
Cli.runTransaction do
|
||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath)
|
||||
pure causal.causalHash
|
||||
|
||||
let aliceCausalHash = Branch.headHash targetBranch
|
||||
lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)
|
||||
|
||||
doMerge
|
||||
@ -139,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
||||
didUpdate <-
|
||||
Cli.updateAtM
|
||||
description
|
||||
targetAbsolutePath
|
||||
targetProjectPath
|
||||
(\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject)
|
||||
|
||||
Cli.respond
|
||||
@ -167,30 +160,29 @@ resolveSourceAndTarget includeSquashed = \case
|
||||
pure (source, target)
|
||||
|
||||
resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
|
||||
resolveImplicitSource includeSquashed =
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath
|
||||
Just (localProjectAndBranch, _restPath) -> do
|
||||
(remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
let localProjectId = localProjectAndBranch.project.projectId
|
||||
let localBranchId = localProjectAndBranch.branch.branchId
|
||||
Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
|
||||
Just (remoteProjectId, Just remoteBranchId) -> do
|
||||
remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
|
||||
remoteBranchName <-
|
||||
Queries.expectRemoteProjectBranchName
|
||||
Share.hardCodedUri
|
||||
remoteProjectId
|
||||
remoteBranchId
|
||||
pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
|
||||
_ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchById includeSquashed $
|
||||
ProjectAndBranch
|
||||
(remoteProjectId, remoteProjectName)
|
||||
(remoteBranchId, remoteBranchName)
|
||||
pure (ReadShare'ProjectBranch remoteBranch)
|
||||
resolveImplicitSource includeSquashed = do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let localProjectAndBranch = PP.toProjectAndBranch pp
|
||||
(remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
let localProjectId = localProjectAndBranch.project.projectId
|
||||
let localBranchId = localProjectAndBranch.branch.branchId
|
||||
Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
|
||||
Just (remoteProjectId, Just remoteBranchId) -> do
|
||||
remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
|
||||
remoteBranchName <-
|
||||
Queries.expectRemoteProjectBranchName
|
||||
Share.hardCodedUri
|
||||
remoteProjectId
|
||||
remoteBranchId
|
||||
pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
|
||||
_ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchById includeSquashed $
|
||||
ProjectAndBranch
|
||||
(remoteProjectId, remoteProjectName)
|
||||
(remoteBranchId, remoteBranchName)
|
||||
pure (ReadShare'ProjectBranch remoteBranch)
|
||||
|
||||
resolveExplicitSource ::
|
||||
Share.IncludeSquashedHead ->
|
||||
@ -208,7 +200,7 @@ resolveExplicitSource includeSquashed = \case
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||
ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
|
||||
(localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch
|
||||
localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
|
||||
let localProjectId = localProjectAndBranch.project.projectId
|
||||
let localBranchId = localProjectAndBranch.branch.branchId
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
@ -243,8 +235,7 @@ resolveExplicitSource includeSquashed = \case
|
||||
|
||||
resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveImplicitTarget = do
|
||||
(projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
pure projectAndBranch
|
||||
PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
|
||||
|
||||
-- | supply `dest0` if you want to print diff messages
|
||||
-- supply unchangedMessage if you want to display it if merge had no effect
|
||||
@ -253,8 +244,8 @@ mergeBranchAndPropagateDefaultPatch ::
|
||||
Text ->
|
||||
Maybe Output ->
|
||||
Branch IO ->
|
||||
Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||
Path.Absolute ->
|
||||
Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||
PP.ProjectPath ->
|
||||
Cli ()
|
||||
mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest =
|
||||
ifM
|
||||
@ -266,7 +257,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
|
||||
mergeBranch =
|
||||
Cli.time "mergeBranch" do
|
||||
Cli.Env {codebase} <- ask
|
||||
destb <- Cli.getBranchAt dest
|
||||
destb <- Cli.getBranchFromProjectPath dest
|
||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb)
|
||||
b <- Cli.updateAtM inputDescription dest (const $ pure merged)
|
||||
for_ maybeDest0 \dest0 -> do
|
||||
@ -276,19 +267,19 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
|
||||
|
||||
loadPropagateDiffDefaultPatch ::
|
||||
Text ->
|
||||
Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||
Path.Absolute ->
|
||||
Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||
PP.ProjectPath ->
|
||||
Cli ()
|
||||
loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
||||
Cli.respond Output.AboutToPropagatePatch
|
||||
Cli.time "loadPropagateDiffDefaultPatch" do
|
||||
original <- Cli.getBranch0At dest
|
||||
original <- Cli.getBranch0FromProjectPath dest
|
||||
patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original
|
||||
patchDidChange <- propagatePatch inputDescription patch dest
|
||||
when patchDidChange do
|
||||
whenJust maybeDest0 \dest0 -> do
|
||||
Cli.respond Output.CalculatingDiff
|
||||
patched <- Cli.getBranchAt dest
|
||||
patched <- Cli.getBranchFromProjectPath dest
|
||||
let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment])))
|
||||
(ppe, diff) <- diffHelper original (Branch.head patched)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff)
|
||||
@ -297,10 +288,11 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
||||
propagatePatch ::
|
||||
Text ->
|
||||
Patch ->
|
||||
Path.Absolute ->
|
||||
PP.ProjectPath ->
|
||||
Cli Bool
|
||||
propagatePatch inputDescription patch scopePath = do
|
||||
Cli.time "propagatePatch" do
|
||||
rootNames <- Cli.projectBranchNames scopePath.branch
|
||||
Cli.stepAt'
|
||||
(inputDescription <> " (applying patch)")
|
||||
(Path.unabsolute scopePath, Propagate.propagateAndApply patch)
|
||||
(scopePath, Propagate.propagateAndApply rootNames patch)
|
||||
|
@ -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 ->
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
|
||||
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
Just (localProjectAndBranch, _restPath) ->
|
||||
pushProjectBranchToProjectBranch
|
||||
force
|
||||
localProjectAndBranch
|
||||
Nothing
|
||||
PushSourceTarget0 -> do
|
||||
localProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch Nothing
|
||||
-- push <implicit> to .some.path (share)
|
||||
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
||||
-- push <implicit> to @some/project
|
||||
PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) ->
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
|
||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
||||
Just (localProjectAndBranch, _restPath) ->
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
|
||||
-- push .some.path to .some.path (share)
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
||||
-- push .some.path to @some/project
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
|
||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
||||
-- push @some/project to .some.path (share)
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||
pushLooseCodeToShareLooseCode
|
||||
(ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
namespace
|
||||
pushBehavior
|
||||
PushSourceTarget1 remoteProjectAndBranch0 -> do
|
||||
localProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
|
||||
-- push @some/project to @some/project
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteProjectBranch remoteProjectAndBranch) -> do
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do
|
||||
localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch)
|
||||
where
|
||||
@ -119,24 +78,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
PushBehavior.RequireEmpty -> False
|
||||
PushBehavior.RequireNonEmpty -> False
|
||||
|
||||
-- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code").
|
||||
pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli ()
|
||||
pushLooseCodeToShareLooseCode _ _ _ = do
|
||||
Cli.returnEarly LooseCodePushDeprecated
|
||||
|
||||
-- Push a local namespace ("loose code") to a remote project branch.
|
||||
pushLooseCodeToProjectBranch :: Bool -> Path.Absolute -> ProjectAndBranch ProjectName ProjectBranchName -> Cli ()
|
||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch = do
|
||||
_ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
|
||||
localBranchHead <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
loadCausalHashToPush localPath >>= \case
|
||||
Nothing -> rollback (EmptyLooseCodePush (Path.absoluteToPath' localPath))
|
||||
Just hash -> pure hash
|
||||
|
||||
uploadPlan <- pushToProjectBranch0 force PushingLooseCode localBranchHead remoteProjectAndBranch
|
||||
executeUploadPlan uploadPlan
|
||||
|
||||
-- | Push a local project branch to a remote project branch. If the remote project branch is left unspecified, we either
|
||||
-- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it).
|
||||
pushProjectBranchToProjectBranch ::
|
||||
@ -147,14 +88,11 @@ pushProjectBranchToProjectBranch ::
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do
|
||||
_ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
|
||||
let localProjectAndBranchIds = localProjectAndBranch & over #project (view #projectId) & over #branch (view #branchId)
|
||||
let localProjectAndBranchNames = localProjectAndBranch & over #project (view #name) & over #branch (view #name)
|
||||
|
||||
-- Load local project and branch from database and get the causal hash to push
|
||||
(localProjectAndBranch, localBranchHead) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
hash <-
|
||||
loadCausalHashToPush (ProjectUtils.projectBranchPath localProjectAndBranchIds) & onNothingM do
|
||||
rollback (EmptyProjectBranchPush localProjectAndBranchNames)
|
||||
Cli.runTransaction do
|
||||
hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch)
|
||||
localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds
|
||||
pure (localProjectAndBranch, hash)
|
||||
|
||||
@ -471,7 +409,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do
|
||||
Share.TransportError err -> ShareErrorTransport err
|
||||
afterUploadAction
|
||||
let ProjectAndBranch projectName branchName = remoteBranch
|
||||
Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName)))
|
||||
Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName))
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- After upload actions
|
||||
@ -563,7 +501,7 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
|
||||
|
||||
when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do
|
||||
Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
|
||||
Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)))
|
||||
Cli.returnEarly (ViewOnShare (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))
|
||||
|
||||
when (not force) do
|
||||
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
|
||||
@ -633,14 +571,11 @@ expectProjectAndBranch (ProjectAndBranch projectId branchId) =
|
||||
<$> Queries.expectProject projectId
|
||||
<*> Queries.expectProjectBranch projectId branchId
|
||||
|
||||
-- Get the causal hash to push at the given path. Return Nothing if there's no history.
|
||||
loadCausalHashToPush :: Path.Absolute -> Sqlite.Transaction (Maybe Hash32)
|
||||
loadCausalHashToPush path =
|
||||
Operations.loadCausalHashAtPath Nothing segments <&> \case
|
||||
Nothing -> Nothing
|
||||
Just (CausalHash hash) -> Just (Hash32.fromHash hash)
|
||||
where
|
||||
segments = Path.toList (Path.unabsolute path)
|
||||
-- Get the causal hash for the given project branch.
|
||||
expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32
|
||||
expectCausalHashToPush pb = do
|
||||
CausalHash causalHash <- Operations.expectProjectBranchHead (pb ^. #projectId) (pb ^. #branchId)
|
||||
pure (Hash32.fromHash causalHash)
|
||||
|
||||
-- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward?
|
||||
wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool
|
||||
|
@ -6,8 +6,8 @@ where
|
||||
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), doCreateBranch)
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), createBranch)
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
import Unison.Project (Semver)
|
||||
@ -16,15 +16,15 @@ import Witch (unsafeFrom)
|
||||
-- | Handle a @release.draft@ command.
|
||||
handleReleaseDraft :: Semver -> Cli ()
|
||||
handleReleaseDraft ver = do
|
||||
currentProjectAndBranch <- fst <$> ProjectUtils.expectCurrentProjectBranch
|
||||
currentProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||
|
||||
let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver)
|
||||
|
||||
_ <-
|
||||
doCreateBranch
|
||||
(CreateFrom'Branch currentProjectAndBranch)
|
||||
(currentProjectAndBranch ^. #project)
|
||||
branchName
|
||||
createBranch
|
||||
("release.draft " <> into @Text ver)
|
||||
(CreateFrom'ParentBranch (currentProjectAndBranch ^. #branch))
|
||||
(currentProjectAndBranch ^. #project)
|
||||
(pure branchName)
|
||||
|
||||
Cli.respond (Output.DraftingRelease branchName ver)
|
||||
|
@ -11,16 +11,14 @@ import U.Codebase.Reference qualified as V2 (Reference)
|
||||
import U.Codebase.Referent qualified as V2 (Referent)
|
||||
import U.Codebase.Referent qualified as V2.Referent
|
||||
import U.Codebase.Sqlite.Project qualified as Project
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as Project
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||
import Unison.ConstructorType qualified as ConstructorType
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -28,8 +26,7 @@ import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch)
|
||||
import Unison.Project.Util (projectBranchPath)
|
||||
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -39,39 +36,27 @@ import Web.Browser (openBrowser)
|
||||
openUI :: Path.Path' -> Cli ()
|
||||
openUI path' = do
|
||||
Cli.Env {serverBaseUrl} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let absPath = Path.resolve currentPath path'
|
||||
defnPath <- Cli.resolvePath' path'
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
whenJust serverBaseUrl \url -> do
|
||||
Project.getProjectBranchForPath absPath >>= \case
|
||||
Nothing -> openUIForLooseCode url path'
|
||||
Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch
|
||||
openUIForProject url pp (defnPath ^. PP.absPath_)
|
||||
|
||||
openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli ()
|
||||
openUIForProject url projectAndBranch pathFromProjectRoot = do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
perspective <-
|
||||
Project.getProjectBranchForPath currentPath <&> \case
|
||||
Nothing ->
|
||||
-- The current path is outside the project the argument was in. Use the project root
|
||||
-- as the perspective.
|
||||
Path.empty
|
||||
Just (_projectBranch, pathWithinBranch) -> pathWithinBranch
|
||||
openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
|
||||
openUIForProject url pp@(PP.ProjectPath project projectBranch perspective) defnPath = do
|
||||
mayDefinitionRef <- getDefinitionRef perspective
|
||||
let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch
|
||||
let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch)
|
||||
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
|
||||
pure ()
|
||||
where
|
||||
pathToBranchFromCodebaseRoot :: Path.Absolute
|
||||
pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch)
|
||||
-- If the provided ui path matches a definition, find it.
|
||||
getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference))
|
||||
getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference))
|
||||
getDefinitionRef perspective = runMaybeT $ do
|
||||
Cli.Env {codebase} <- lift ask
|
||||
let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot)
|
||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition
|
||||
namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing)
|
||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath
|
||||
let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace
|
||||
namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath
|
||||
fqn <- hoistMaybe $ do
|
||||
pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot)
|
||||
pathFromPerspective <- List.stripPrefix (Path.toList (Path.unabsolute perspective)) (Path.toList $ Path.unabsolute defnPath)
|
||||
Path.toName . Path.fromList $ pathFromPerspective
|
||||
def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn
|
||||
pure def
|
||||
@ -89,35 +74,6 @@ getTermOrTypeRef codebase namespaceBranch fqn = runMaybeT $ do
|
||||
pure (toTypeReference fqn oneType)
|
||||
terms <|> types
|
||||
|
||||
openUIForLooseCode :: Server.BaseUrl -> Path.Path' -> Cli ()
|
||||
openUIForLooseCode url path' = do
|
||||
Cli.Env {codebase} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
(perspective, definitionRef) <- getUIUrlParts currentPath path' codebase
|
||||
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.LooseCodeUI perspective definitionRef) url
|
||||
pure ()
|
||||
|
||||
getUIUrlParts :: Path.Absolute -> Path.Path' -> Codebase m Symbol Ann -> Cli (Path.Absolute, Maybe (Server.DefinitionReference))
|
||||
getUIUrlParts startPath definitionPath' codebase = do
|
||||
let absPath = Path.resolve startPath definitionPath'
|
||||
let perspective =
|
||||
if Path.isAbsolute definitionPath'
|
||||
then Path.absoluteEmpty
|
||||
else startPath
|
||||
case Lens.unsnoc absPath of
|
||||
Just (abs, _nameSeg) -> do
|
||||
namespaceBranch <-
|
||||
Cli.runTransaction
|
||||
(Codebase.getShallowBranchAtPath (Path.unabsolute abs) Nothing)
|
||||
mayDefRef <- runMaybeT do
|
||||
name <- hoistMaybe $ Path.toName $ Path.fromPath' definitionPath'
|
||||
MaybeT $ getTermOrTypeRef codebase namespaceBranch name
|
||||
case mayDefRef of
|
||||
Nothing -> pure (absPath, Nothing)
|
||||
Just defRef -> pure (perspective, Just defRef)
|
||||
Nothing ->
|
||||
pure (absPath, Nothing)
|
||||
|
||||
toTypeReference :: Name -> V2.Reference -> Server.DefinitionReference
|
||||
toTypeReference name reference =
|
||||
Server.TypeReference $
|
||||
|
@ -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
|
||||
-- and make a patch diff to record a replacement from the old to new references
|
||||
Cli.stepManyAtMNoSync
|
||||
( [ ( Path.unabsolute currentPath',
|
||||
pure . doSlurpUpdates typeEdits termEdits termDeprecations
|
||||
),
|
||||
( Path.unabsolute currentPath',
|
||||
pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr)
|
||||
)
|
||||
]
|
||||
++ case patchOps of
|
||||
Nothing -> []
|
||||
Just (_, update, p) -> [(Path.unabsolute p, update)]
|
||||
)
|
||||
-- First add the new definitions to the codebase
|
||||
Cli.runTransaction
|
||||
. Codebase.addDefsToCodebase codebase
|
||||
. Slurp.filterUnisonFile sr
|
||||
$ Slurp.originalFile sr
|
||||
currentBranch <- Cli.getCurrentBranch
|
||||
-- take a look at the `updates` from the SlurpResult
|
||||
-- and make a patch diff to record a replacement from the old to new references
|
||||
updatedBranch <-
|
||||
currentBranch
|
||||
& Branch.stepManyAtM
|
||||
( [ ( Path.unabsolute currentPath',
|
||||
pure . doSlurpUpdates typeEdits termEdits termDeprecations
|
||||
),
|
||||
( Path.unabsolute currentPath',
|
||||
pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr)
|
||||
)
|
||||
]
|
||||
++ case patchOps of
|
||||
Nothing -> []
|
||||
Just (_, update, p) -> [(Path.unabsolute p, update)]
|
||||
)
|
||||
& liftIO
|
||||
|
||||
let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames
|
||||
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||
whenJust patchOps \(updatedPatch, _, _) ->
|
||||
void $ propagatePatchNoSync updatedPatch currentPath'
|
||||
Cli.syncRoot case patchPath of
|
||||
Nothing -> "update.nopatch"
|
||||
Just p ->
|
||||
p
|
||||
& Path.unsplit'
|
||||
& Path.resolve @_ @_ @Path.Absolute currentPath'
|
||||
& tShow
|
||||
branchWithPropagatedPatch <- case patchOps of
|
||||
Nothing -> pure updatedBranch
|
||||
Just (updatedPatch, _, _) -> do
|
||||
propagatePatch updatedPatch (Path.unabsolute currentPath') updatedBranch
|
||||
let description = case patchPath of
|
||||
Nothing -> "update.nopatch"
|
||||
Just p ->
|
||||
p
|
||||
& Path.unsplit'
|
||||
& Path.resolve @_ @_ @Path.Absolute currentPath'
|
||||
& tShow
|
||||
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
|
||||
propagatePatchNoSync patch scopePath =
|
||||
propagatePatch :: Patch -> Path.Path -> Branch.Branch IO -> Cli (Branch.Branch IO)
|
||||
propagatePatch patch scopePath b = do
|
||||
Cli.time "propagatePatchNoSync" do
|
||||
Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
|
||||
let names = Branch.toNames $ Branch.head b
|
||||
Branch.stepManyAtM [(scopePath, Propagate.propagateAndApply names patch)] b
|
||||
|
||||
recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])]
|
||||
recomponentize =
|
||||
|
@ -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
|
||||
currentBranch0 <- Cli.getBranch0At currentPath
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
currentBranch0 <- Cli.getCurrentBranch0
|
||||
let namesIncludingLibdeps = Branch.toNames currentBranch0
|
||||
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
|
||||
let ctorNames = forwardCtorNames namesExcludingLibdeps
|
||||
@ -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@.
|
||||
|
@ -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 projectId = projectAndBranch.project.projectId
|
||||
let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId projectAndBranch.branch.branchId)
|
||||
let oldPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldName]))
|
||||
let newPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newName]))
|
||||
let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName])
|
||||
let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName])
|
||||
|
||||
currentNamespace <- Cli.getBranch0At projectPath
|
||||
currentNamespace <- Cli.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
|
||||
-- transactions, creating could fail.
|
||||
temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName projectId oldName newName)
|
||||
temporaryBranchId <-
|
||||
HandleInput.Branch.doCreateBranch
|
||||
(HandleInput.Branch.CreateFrom'Branch projectAndBranch)
|
||||
projectAndBranch.project
|
||||
temporaryBranchName
|
||||
let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName
|
||||
(_temporaryBranchId, temporaryBranchName) <-
|
||||
HandleInput.Branch.createBranch
|
||||
textualDescriptionOfUpgrade
|
||||
let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
|
||||
Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld)
|
||||
(CreateFrom'ParentBranch projectBranch)
|
||||
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)
|
||||
|
@ -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
|
||||
-- have distinct syntaxes, but sometimes it's ambiguous, in which case we'd parse a `These`. The command itself can
|
||||
-- decide what to do with the ambiguity.
|
||||
type LooseCodeOrProject =
|
||||
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||
instance From p Text => From (BranchIdG p) Text where
|
||||
from = \case
|
||||
BranchAtSCH h -> "#" <> SCH.toText h
|
||||
BranchAtPath p -> from p
|
||||
BranchAtProjectPath pp -> from pp
|
||||
|
||||
type AbsBranchId = Either ShortCausalHash Path.Absolute
|
||||
type BranchId = BranchIdG Path'
|
||||
|
||||
type 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
|
||||
parseBranchId s = Right <$> Path.parsePath' s
|
||||
Just h -> pure $ BranchAtSCH h
|
||||
parseBranchId s = BranchAtPath <$> Path.parsePath' s
|
||||
|
||||
parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
|
||||
parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||
@ -106,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
|
||||
| PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject
|
||||
MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode
|
||||
| PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath)
|
||||
| DiffNamespaceI BranchId BranchId -- old new
|
||||
| PullI !PullSourceTarget !PullMode
|
||||
| PushRemoteBranchI PushRemoteBranchInput
|
||||
| ResetRootI (Either ShortCausalHash Path')
|
||||
| ResetI
|
||||
( These
|
||||
(Either ShortCausalHash Path')
|
||||
(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||
)
|
||||
(Maybe LooseCodeOrProject)
|
||||
| ResetRootI BranchId
|
||||
| ResetI BranchId (Maybe UnresolvedProjectBranch)
|
||||
| -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
|
||||
-- Does it make sense to fork from not-the-root of a Github repo?
|
||||
-- used in Welcome module to give directions to user
|
||||
@ -237,8 +243,8 @@ data BranchSourceI
|
||||
BranchSourceI'CurrentContext
|
||||
| -- | Create an empty branch
|
||||
BranchSourceI'Empty
|
||||
| -- | Create a branch from this loose-code-or-project
|
||||
BranchSourceI'LooseCodeOrProject LooseCodeOrProject
|
||||
| -- | Create a branch from this other branch
|
||||
BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- | Pull source and target: either neither is specified, or only a source, or both.
|
||||
@ -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))
|
||||
| PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
| PushSourceTarget1 (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)
|
||||
|
@ -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))
|
||||
Path.Absolute
|
||||
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
ProjectPath
|
||||
PPE.PrettyPrintEnv
|
||||
(BranchDiffOutput Symbol Ann)
|
||||
| ShowDiffAfterMergePropagate
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
Path.Absolute
|
||||
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
ProjectPath
|
||||
Path.Path'
|
||||
PPE.PrettyPrintEnv
|
||||
(BranchDiffOutput Symbol Ann)
|
||||
| ShowDiffAfterMergePreview
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
Path.Absolute
|
||||
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
ProjectPath
|
||||
PPE.PrettyPrintEnv
|
||||
(BranchDiffOutput Symbol Ann)
|
||||
| ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||
@ -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
|
||||
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
| MergeAlreadyUpToDate BranchRelativePath BranchRelativePath
|
||||
| -- This will replace the above once `merge.old` is deleted
|
||||
MergeAlreadyUpToDate2 !MergeSourceAndTarget
|
||||
| PreviewMergeAlreadyUpToDate
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
| PreviewMergeAlreadyUpToDate ProjectPath ProjectPath
|
||||
| NotImplemented
|
||||
| NoBranchWithHash ShortCausalHash
|
||||
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
|
||||
@ -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
|
||||
| ShareErrorFastForwardPush Sync.FastForwardPushError
|
||||
= ShareErrorDownloadEntities Share.DownloadEntitiesError
|
||||
| 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
|
||||
|
@ -14,7 +14,6 @@ import U.Codebase.Reference qualified as Reference
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.TypeCheck qualified as Cli (computeTypecheckingEnvironment)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
@ -82,11 +81,12 @@ noEdits :: Edits v
|
||||
noEdits = Edits mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
propagateAndApply ::
|
||||
Names ->
|
||||
Patch ->
|
||||
Branch0 IO ->
|
||||
Cli (Branch0 IO)
|
||||
propagateAndApply patch branch = do
|
||||
edits <- propagate patch branch
|
||||
propagateAndApply rootNames patch branch = do
|
||||
edits <- propagate rootNames patch branch
|
||||
let f = applyPropagate patch edits
|
||||
(pure . f . applyDeprecations patch) branch
|
||||
|
||||
@ -234,15 +234,13 @@ debugMode = False
|
||||
--
|
||||
-- "dirty" means in need of update
|
||||
-- "frontier" means updated definitions responsible for the "dirty"
|
||||
propagate :: Patch -> Branch0 IO -> Cli (Edits Symbol)
|
||||
propagate patch b = case validatePatch patch of
|
||||
propagate :: Names -> Patch -> Branch0 IO -> Cli (Edits Symbol)
|
||||
propagate rootNames patch b = case validatePatch patch of
|
||||
Nothing -> do
|
||||
Cli.respond PatchNeedsToBeConflictFree
|
||||
pure noEdits
|
||||
Just (initialTermEdits, initialTypeEdits) -> do
|
||||
-- TODO: this can be removed once patches have term replacement of type `Referent -> Referent`
|
||||
rootNames <- Branch.toNames <$> Cli.getRootBranch0
|
||||
|
||||
let -- TODO: these are just used for tracing, could be deleted if we don't care
|
||||
-- about printing meaningful names for definitions during propagation, or if
|
||||
-- we want to just remove the tracing.
|
||||
|
@ -1,8 +1,7 @@
|
||||
module Unison.Codebase.Editor.UriParser
|
||||
( readRemoteNamespaceParser,
|
||||
writeRemoteNamespace,
|
||||
writeRemoteNamespaceWith,
|
||||
parseReadShareLooseCode,
|
||||
writeRemoteNamespace,
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,8 +16,6 @@ import Unison.Codebase.Editor.RemoteRepo
|
||||
ReadShareLooseCode (..),
|
||||
ShareCodeserver (DefaultCodeserver),
|
||||
ShareUserHandle (..),
|
||||
WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -53,25 +50,9 @@ parseReadShareLooseCode label input =
|
||||
|
||||
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
|
||||
-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
|
||||
writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
writeRemoteNamespace :: P (These ProjectName ProjectBranchName)
|
||||
writeRemoteNamespace =
|
||||
writeRemoteNamespaceWith
|
||||
(projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
|
||||
|
||||
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
|
||||
writeRemoteNamespaceWith projectBranchParser =
|
||||
WriteRemoteProjectBranch <$> projectBranchParser
|
||||
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
|
||||
|
||||
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
|
||||
-- Just (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})
|
||||
writeShareRemoteNamespace :: P WriteShareRemoteNamespace
|
||||
writeShareRemoteNamespace =
|
||||
P.label "write share remote namespace" $
|
||||
WriteShareRemoteNamespace
|
||||
<$> pure DefaultCodeserver
|
||||
<*> shareUserHandle
|
||||
<*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
|
||||
(projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
|
||||
|
||||
-- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
|
||||
-- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4"
|
||||
|
@ -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.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.Verbosity (Verbosity, isSilent)
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
@ -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
|
||||
UcmContextLooseCode path -> show path
|
||||
UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch)
|
||||
showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
|
||||
|
||||
instance Show Stanza where
|
||||
show s = 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
|
||||
(Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||
(Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs)
|
||||
case (tryFrom @Text contextString) of
|
||||
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||
_ -> fail "expected project/branch or absolute path"
|
||||
void $ lineToken $ word ">"
|
||||
pure context
|
||||
|
@ -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
|
||||
Path.Absolute ->
|
||||
-- | Current location
|
||||
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
|
||||
let projCtx = projectContextFromPath currentPath
|
||||
getCurrentBranch0 = do
|
||||
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 projCtx getCurrentBranch pat args = runExceptT do
|
||||
fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
|
||||
fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do
|
||||
-- We resolve args in two steps, first we check that all arguments that will require a fzf
|
||||
-- resolver have one, and only if so do we prompt the user to actually do a fuzzy search.
|
||||
-- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver
|
||||
@ -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 <-
|
||||
|
@ -2,9 +2,9 @@ module Unison.CommandLine.BranchRelativePath
|
||||
( BranchRelativePath (..),
|
||||
parseBranchRelativePath,
|
||||
branchRelativePathParser,
|
||||
ResolvedBranchRelativePath (..),
|
||||
parseIncrementalBranchRelativePath,
|
||||
IncrementalBranchRelativePath (..),
|
||||
toText,
|
||||
)
|
||||
where
|
||||
|
||||
@ -14,10 +14,9 @@ import Data.These (These (..))
|
||||
import Text.Builder qualified
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Text.Megaparsec.Char qualified as Megaparsec
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project qualified as Project
|
||||
@ -25,8 +24,11 @@ import Unison.Util.ColorText qualified as CT
|
||||
import Unison.Util.Pretty qualified as P
|
||||
|
||||
data BranchRelativePath
|
||||
= BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative)
|
||||
| LoosePath Path.Path'
|
||||
= -- | A path rooted at some specified branch/project
|
||||
BranchPathInCurrentProject ProjectBranchName Path.Absolute
|
||||
| QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute
|
||||
| -- | A path which is relative to the user's current location.
|
||||
UnqualifiedPath Path.Path'
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- | Strings without colons are parsed as loose code paths. A path with a colon may specify:
|
||||
@ -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
|
||||
This eitherProj ->
|
||||
Text.Builder.run
|
||||
( Text.Builder.text (eitherProjToText eitherProj)
|
||||
<> Text.Builder.char ':'
|
||||
)
|
||||
That path ->
|
||||
Text.Builder.run
|
||||
( Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
||||
)
|
||||
These eitherProj path ->
|
||||
Text.Builder.run
|
||||
( Text.Builder.text (eitherProjToText eitherProj)
|
||||
<> Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
||||
)
|
||||
LoosePath path -> Path.toText' path
|
||||
where
|
||||
eitherProjToText = \case
|
||||
Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName)
|
||||
Right (projName, branchName) -> into @Text (These projName branchName)
|
||||
|
||||
data ResolvedBranchRelativePath
|
||||
= ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative)
|
||||
| ResolvedLoosePath Path.Absolute
|
||||
|
||||
instance From ResolvedBranchRelativePath BranchRelativePath where
|
||||
from = \case
|
||||
ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of
|
||||
Nothing -> BranchRelative (This (Right (view #name proj, view #name branch)))
|
||||
Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel)
|
||||
ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p)
|
||||
|
||||
instance From ResolvedBranchRelativePath Text where
|
||||
from = from . into @BranchRelativePath
|
||||
BranchPathInCurrentProject branch path ->
|
||||
Text.Builder.run $
|
||||
Text.Builder.char '/'
|
||||
<> Text.Builder.text (into @Text branch)
|
||||
<> Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.absToText path)
|
||||
QualifiedBranchPath proj branch path ->
|
||||
Text.Builder.run $
|
||||
Text.Builder.text (into @Text proj)
|
||||
<> Text.Builder.char '/'
|
||||
<> Text.Builder.text (into @Text branch)
|
||||
<> Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.absToText path)
|
||||
UnqualifiedPath path ->
|
||||
Path.toText' path
|
||||
|
||||
data IncrementalBranchRelativePath
|
||||
= -- | no dots, slashes, or colons
|
||||
ProjectOrRelative Text Path.Path'
|
||||
| -- | dots, no slashes or colons
|
||||
LooseCode Path.Path'
|
||||
= -- | no dots, slashes, or colons, so could be a project name or a single path segment
|
||||
ProjectOrPath' Text Path.Path'
|
||||
| -- | dots, no slashes or colons, must be a relative or absolute path
|
||||
OnlyPath' Path.Path'
|
||||
| -- | valid project, no slash
|
||||
IncompleteProject ProjectName
|
||||
| -- | valid project/branch, slash, no colon
|
||||
IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName)
|
||||
| -- | valid project/branch, with colon
|
||||
IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative)
|
||||
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)
|
||||
LooseCode path -> pure (LoosePath path)
|
||||
ProjectOrPath' _txt path -> pure (UnqualifiedPath path)
|
||||
OnlyPath' path -> pure (UnqualifiedPath path)
|
||||
IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here."
|
||||
IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here."
|
||||
PathRelativeToCurrentBranch p -> pure (BranchRelative (That p))
|
||||
PathRelativeToCurrentBranch p -> pure (UnqualifiedPath (Path.RelativePath' p))
|
||||
IncompletePath projStuff mpath ->
|
||||
case projStuff of
|
||||
Left (ProjectAndBranch projName branchName) -> case mpath of
|
||||
Nothing -> pure (BranchRelative (This (Right (projName, branchName))))
|
||||
Just path -> pure (BranchRelative (These (Right (projName, branchName)) path))
|
||||
Right branch -> case mpath of
|
||||
Nothing -> pure (BranchRelative (This (Left branch)))
|
||||
Just path -> pure (BranchRelative (These (Left branch) path))
|
||||
Left (ProjectAndBranch projName branchName) ->
|
||||
pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath)
|
||||
Right branch ->
|
||||
pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath)
|
||||
|
||||
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'
|
||||
|
@ -20,9 +20,8 @@ module Unison.CommandLine.Completion
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (ifoldMap)
|
||||
import Control.Lens
|
||||
import Control.Lens qualified as Lens
|
||||
import Control.Lens.Cons (unsnoc)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List qualified as List
|
||||
@ -48,6 +47,7 @@ import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.CommandLine.InputPattern qualified as IP
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
@ -73,9 +73,9 @@ haskelineTabComplete ::
|
||||
Map String IP.InputPattern ->
|
||||
Codebase m v a ->
|
||||
AuthenticatedHttpClient ->
|
||||
Path.Absolute ->
|
||||
PP.ProjectPath ->
|
||||
Line.CompletionFunc m
|
||||
haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.completeWordWithPrev Nothing " " $ \prev word ->
|
||||
haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWordWithPrev Nothing " " $ \prev word ->
|
||||
-- User hasn't finished a command name, complete from command names
|
||||
if null prev
|
||||
then pure . exactComplete word $ Map.keys patterns
|
||||
@ -84,7 +84,7 @@ haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.compl
|
||||
h : t -> fromMaybe (pure []) $ do
|
||||
p <- Map.lookup h patterns
|
||||
argType <- IP.argType p (length t)
|
||||
pure $ IP.suggestions argType word codebase authedHTTPClient currentPath
|
||||
pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx
|
||||
_ -> pure []
|
||||
|
||||
-- | Things which we may want to complete for.
|
||||
@ -101,7 +101,7 @@ noCompletions ::
|
||||
String ->
|
||||
Codebase m v a ->
|
||||
AuthenticatedHttpClient ->
|
||||
Path.Absolute ->
|
||||
PP.ProjectPath ->
|
||||
m [System.Console.Haskeline.Completion.Completion]
|
||||
noCompletions _ _ _ _ = pure []
|
||||
|
||||
@ -141,11 +141,11 @@ completeWithinNamespace ::
|
||||
NESet CompletionType ->
|
||||
-- | The portion of this are that the user has already typed.
|
||||
String ->
|
||||
Path.Absolute ->
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
||||
completeWithinNamespace compTypes query currentPath = do
|
||||
completeWithinNamespace compTypes query ppCtx = do
|
||||
shortHashLen <- Codebase.hashLength
|
||||
b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing
|
||||
b <- Codebase.getShallowBranchAtProjectPath queryProjectPath
|
||||
currentBranchSuggestions <- do
|
||||
nib <- namesInBranch shortHashLen b
|
||||
nib
|
||||
@ -168,8 +168,8 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
queryPathPrefix :: Path.Path'
|
||||
querySuffix :: Text
|
||||
(queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query)
|
||||
absQueryPath :: Path.Absolute
|
||||
absQueryPath = Path.resolve currentPath queryPathPrefix
|
||||
queryProjectPath :: PP.ProjectPath
|
||||
queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix
|
||||
getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
|
||||
getChildSuggestions shortHashLen b
|
||||
| Text.null querySuffix = pure []
|
||||
@ -274,35 +274,35 @@ parseLaxPath'Query txt =
|
||||
-- | Completes a namespace argument by prefix-matching against the query.
|
||||
prefixCompleteNamespace ::
|
||||
String ->
|
||||
Path.Absolute -> -- Current path
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [Line.Completion]
|
||||
prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion)
|
||||
|
||||
-- | Completes a term or type argument by prefix-matching against the query.
|
||||
prefixCompleteTermOrType ::
|
||||
String ->
|
||||
Path.Absolute -> -- Current path
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [Line.Completion]
|
||||
prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion]))
|
||||
|
||||
-- | Completes a term argument by prefix-matching against the query.
|
||||
prefixCompleteTerm ::
|
||||
String ->
|
||||
Path.Absolute -> -- Current path
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [Line.Completion]
|
||||
prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion)
|
||||
|
||||
-- | Completes a term or type argument by prefix-matching against the query.
|
||||
prefixCompleteType ::
|
||||
String ->
|
||||
Path.Absolute -> -- Current path
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [Line.Completion]
|
||||
prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion)
|
||||
|
||||
-- | Completes a patch argument by prefix-matching against the query.
|
||||
prefixCompletePatch ::
|
||||
String ->
|
||||
Path.Absolute -> -- Current path
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction [Line.Completion]
|
||||
prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion)
|
||||
|
||||
|
@ -37,13 +37,13 @@ import Unison.Codebase.Branch (Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Path (Path, Path' (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Position qualified as Position
|
||||
import Unison.Prelude
|
||||
import Unison.Project.Util (ProjectContext (..))
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
@ -51,7 +51,7 @@ import Unison.Util.Monoid (foldMapM)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Relation qualified as Relation
|
||||
|
||||
type OptionFetcher = Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text]
|
||||
type OptionFetcher = Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text]
|
||||
|
||||
data FZFResolver = FZFResolver
|
||||
{ getOptions :: OptionFetcher
|
||||
@ -121,7 +121,7 @@ fuzzySelectFromList options =
|
||||
-- | Combine multiple option fetchers into one resolver.
|
||||
multiResolver :: [OptionFetcher] -> FZFResolver
|
||||
multiResolver resolvers =
|
||||
let getOptions :: Codebase IO Symbol Ann -> ProjectContext -> Branch0 IO -> IO [Text]
|
||||
let getOptions :: Codebase IO Symbol Ann -> PP.ProjectPath -> Branch0 IO -> IO [Text]
|
||||
getOptions codebase projCtx searchBranch0 = do
|
||||
List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers
|
||||
in (FZFResolver {getOptions})
|
||||
@ -177,11 +177,8 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do
|
||||
-- E.g. '@unison/base/main'
|
||||
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
||||
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
||||
case projCtx of
|
||||
LooseCodePath _ -> pure []
|
||||
ProjectBranchPath currentProjectId _projectBranchId _path -> do
|
||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith currentProjectId Nothing)
|
||||
<&> fmap (into @Text . snd)
|
||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing)
|
||||
<&> fmap (into @Text . snd)
|
||||
|
||||
-- | Exported from here just so the debug command and actual implementation can use the same
|
||||
-- messaging.
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
Right pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
|
||||
BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
|
||||
BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
|
||||
BranchAtProjectPath pp ->
|
||||
pp
|
||||
& PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
|
||||
& PP.toNames
|
||||
& into @Text
|
||||
|
||||
entryToHQText :: Path' -> ShallowListEntry v Ann -> Text
|
||||
entryToHQText pathArg =
|
||||
@ -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 (Right prefix) name ->
|
||||
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||
pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg
|
||||
|
||||
@ -486,27 +481,34 @@ handleBranchIdArg =
|
||||
either
|
||||
(first P.text . Input.parseBranchId)
|
||||
\case
|
||||
SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . pure $ Path.fromName' name
|
||||
SA.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . BranchAtPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix mprefix name ->
|
||||
pure . pure . Path.fromName' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') name mprefix
|
||||
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
|
||||
pure $ case mprefix of
|
||||
BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name
|
||||
BranchAtPath prefix -> BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
BranchAtProjectPath pp ->
|
||||
pp
|
||||
& PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
|
||||
& BranchAtProjectPath
|
||||
SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash
|
||||
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||
|
||||
handleBranchIdOrProjectArg ::
|
||||
-- | TODO: Maybe remove?
|
||||
_handleBranchIdOrProjectArg ::
|
||||
I.Argument ->
|
||||
Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
|
||||
handleBranchIdOrProjectArg =
|
||||
_handleBranchIdOrProjectArg =
|
||||
either
|
||||
(maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject)
|
||||
\case
|
||||
SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash
|
||||
SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . This . pure $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
||||
pure . This . pure . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.ProjectBranch pb -> pure $ pure pb
|
||||
SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash
|
||||
SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||
pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.ProjectBranch pb -> pure $ That pb
|
||||
otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType
|
||||
where
|
||||
branchIdOrProject ::
|
||||
@ -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.Name name -> pure . pure . LoosePath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
||||
pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||
pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
|
||||
pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
|
||||
case mproject of
|
||||
Just proj -> pure . pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
|
||||
Nothing -> pure . pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
|
||||
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||
|
||||
handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath
|
||||
@ -547,13 +551,15 @@ handleBranchRelativePathArg =
|
||||
either
|
||||
parseBranchRelativePath
|
||||
\case
|
||||
SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . LoosePath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
||||
pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path
|
||||
SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name
|
||||
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||
pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
|
||||
pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
|
||||
case mproject of
|
||||
Just proj -> pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
|
||||
Nothing -> pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
|
||||
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||
|
||||
hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit'
|
||||
@ -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 (Right prefix) hqname ->
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||
pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
||||
SA.ShallowListEntry prefix entry ->
|
||||
pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||
@ -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 (Right prefix) hqname ->
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||
pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
||||
SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry
|
||||
sr@(SA.SearchResult mpath result) ->
|
||||
@ -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 (Right prefix) hqname ->
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||
pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname)
|
||||
SA.ShallowListEntry prefix entry ->
|
||||
pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||
@ -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 (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name
|
||||
SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||
SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname
|
||||
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname
|
||||
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname
|
||||
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||
pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname
|
||||
SA.ShallowListEntry prefix entry ->
|
||||
pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||
@ -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 . pure <$> handleSplitArg p
|
||||
[p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> 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, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1)
|
||||
[arg0] -> Input.ResetI <$> handleBranchIdArg arg0 <*> pure Nothing
|
||||
[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
|
||||
<*> handleLooseCodeOrProjectArg dest
|
||||
<$> handleBranchRelativePathArg src
|
||||
<*> (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
|
||||
<*> pure (This Path.relativeEmpty')
|
||||
<$> handleBranchRelativePathArg src
|
||||
<*> pure Nothing
|
||||
<*> pure Branch.RegularMerge
|
||||
[src, dest] ->
|
||||
Input.MergeLocalBranchI
|
||||
<$> handleLooseCodeOrProjectArg src
|
||||
<*> handleLooseCodeOrProjectArg dest
|
||||
<$> handleBranchRelativePathArg src
|
||||
<*> (Just <$> handleBranchRelativePathArg dest)
|
||||
<*> pure Branch.RegularMerge
|
||||
_ -> 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 path `.bar` of the current project to a new branch `foo`")
|
||||
("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`")
|
||||
],
|
||||
parse = \case
|
||||
[source0, name] ->
|
||||
Input.BranchI . Input.BranchSourceI'LooseCodeOrProject
|
||||
<$> handleLooseCodeOrProjectArg source0
|
||||
Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch
|
||||
<$> handleMaybeProjectBranchArg source0
|
||||
<*> handleMaybeProjectBranchArg name
|
||||
[name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name
|
||||
_ -> 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
|
||||
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
|
||||
suggestions = \q cb _http pp -> Codebase.runTransaction cb do
|
||||
prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
|
||||
fzfResolver = Just Resolvers.projectDependencyResolver
|
||||
}
|
||||
|
||||
@ -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
|
||||
Nothing -> pure []
|
||||
Just currentProjectId ->
|
||||
fmap (filterBranches config path) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||
projects <- case (projectInclusion config, mayCurrentProjectId) of
|
||||
(OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
|
||||
(OnlyWithinCurrentProject, Nothing) -> pure []
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||
projects <- case projectInclusion config of
|
||||
OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
|
||||
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
||||
pure (branches, projects)
|
||||
let branchCompletions = map currentProjectBranchToCompletion branches
|
||||
@ -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]
|
||||
handleBranchesComplete branchName codebase path = do
|
||||
-- Complete the text into a branch name within the provided project
|
||||
handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
|
||||
handleBranchesComplete branchName codebase pp = do
|
||||
let projId = pp ^. #project . #projectId
|
||||
branches <-
|
||||
case preview ProjectUtils.projectBranchPathPrism path of
|
||||
Nothing -> pure []
|
||||
Just (ProjectAndBranch currentProjectId _, _) ->
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config path) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
|
||||
pure (map currentProjectBranchToCompletion branches)
|
||||
|
||||
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
||||
filterProjects projects =
|
||||
case (mayCurrentProjectId, projectInclusion config) of
|
||||
(_, AllProjects) -> projects
|
||||
(Nothing, _) -> projects
|
||||
(Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
|
||||
(Just currentBranchId, OnlyWithinCurrentProject) ->
|
||||
case (projectInclusion config) of
|
||||
AllProjects -> projects
|
||||
OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
|
||||
OnlyWithinCurrentProject ->
|
||||
projects
|
||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
|
||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
|
||||
& maybeToList
|
||||
|
||||
PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp
|
||||
|
||||
projectToCompletion :: Sqlite.Project -> Completion
|
||||
projectToCompletion project =
|
||||
Completion
|
||||
@ -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
|
||||
Nothing -> pure []
|
||||
Just (ProjectAndBranch currentProjectId _, _) ->
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config path) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName)
|
||||
pure (map currentProjectBranchToCompletion branches)
|
||||
|
||||
filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
||||
filterBranches config path branches =
|
||||
case (mayCurrentBranchId, branchInclusion config) of
|
||||
(_, AllBranches) -> branches
|
||||
(Nothing, _) -> branches
|
||||
(Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
||||
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
||||
filterBranches config pp branches =
|
||||
case (branchInclusion config) of
|
||||
AllBranches -> branches
|
||||
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
||||
where
|
||||
(_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of
|
||||
LooseCodePath {} -> (Nothing, Nothing)
|
||||
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
|
||||
currentBranchId = pp ^. #branch . #branchId
|
||||
|
||||
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
||||
currentProjectBranchToCompletion (_, branchName) =
|
||||
@ -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
|
||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
||||
BranchRelativePath.ProjectOrPath' _txt _path -> do
|
||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
||||
pure (namespaceSuggestions ++ projectSuggestions)
|
||||
BranchRelativePath.LooseCode _path ->
|
||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
||||
BranchRelativePath.OnlyPath' _path ->
|
||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||
BranchRelativePath.IncompleteProject _proj ->
|
||||
projectNameSuggestions WithSlash inputStr codebase
|
||||
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
|
||||
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath
|
||||
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp
|
||||
Just projectName -> do
|
||||
branches <-
|
||||
Codebase.runTransaction codebase do
|
||||
@ -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
|
||||
(projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId)
|
||||
MaybeT (Queries.loadProjectBranch projectId branchId)
|
||||
case mprojectBranch of
|
||||
Nothing -> pure []
|
||||
Just projectBranch -> do
|
||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
||||
map prefixPathSep
|
||||
<$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath
|
||||
-- TODO: Verify this works as intended, might need to use an absolute path instead.
|
||||
map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) pp
|
||||
BranchRelativePath.IncompletePath projStuff mpath -> do
|
||||
Codebase.runTransaction codebase do
|
||||
mprojectBranch <- runMaybeT do
|
||||
case projStuff of
|
||||
Left names@(ProjectAndBranch projectName branchName) -> do
|
||||
(,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName)
|
||||
Right branchName -> do
|
||||
currentProjectId <- MaybeT (pure mayCurrentProjectId)
|
||||
projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName)
|
||||
pure (projectBranch, Right (projectBranch ^. #name))
|
||||
case mprojectBranch of
|
||||
Nothing -> pure []
|
||||
Just (projectBranch, prefix) -> do
|
||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
||||
map (addBranchPrefix prefix)
|
||||
<$> prefixCompleteNamespace
|
||||
(maybe "" (Text.unpack . Path.toText' . Path.RelativePath') mpath)
|
||||
branchPath
|
||||
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp
|
||||
where
|
||||
(mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of
|
||||
LooseCodePath {} -> (Nothing, Nothing)
|
||||
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
|
||||
|
||||
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
||||
projectBranchToCompletionWithSep projectName (_, branchName) =
|
||||
Completion
|
||||
@ -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 ::
|
||||
|
@ -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.ProjectUtils (projectBranchPathPrism)
|
||||
import Unison.Cli.Pretty qualified as P
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
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 <-
|
||||
case preview projectBranchPathPrism currentPath of
|
||||
Nothing -> pure ((P.green . P.shown) currentPath)
|
||||
Just (ProjectAndBranch projectId branchId, restPath) -> do
|
||||
lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case
|
||||
-- If the project branch has been deleted from sqlite, just show a borked prompt
|
||||
Nothing -> P.red "???"
|
||||
Just (projectName, branchName) ->
|
||||
P.sep
|
||||
" "
|
||||
( catMaybes
|
||||
[ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)),
|
||||
case restPath of
|
||||
Path.Empty -> Nothing
|
||||
_ -> (Just . P.green . P.shown) restPath
|
||||
]
|
||||
)
|
||||
let promptString = P.prettyProjectPath pp
|
||||
let fullPrompt = P.toANSI 80 (promptString <> fromString prompt)
|
||||
line <- Line.getInputLine fullPrompt
|
||||
case line of
|
||||
@ -102,7 +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
|
||||
|
@ -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 $
|
||||
"View it here: " <> case shareRef of
|
||||
Left repoPath -> prettyShareLink repoPath
|
||||
Right branchInfo -> prettyRemoteBranchInfo branchInfo
|
||||
pure $ "View it here: " <> prettyRemoteBranchInfo shareRef
|
||||
IntegrityCheck result -> pure $ case result of
|
||||
NoIntegrityErrors -> "🎉 No issues detected 🎉"
|
||||
IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
|
||||
@ -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)] ->
|
||||
|
@ -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 lspFormattingConfig codebase runtime latestRootHash latestPath =
|
||||
spawnLsp ::
|
||||
LspFormattingConfig ->
|
||||
Codebase IO Symbol Ann ->
|
||||
Runtime Symbol ->
|
||||
STM CausalHash ->
|
||||
STM PP.ProjectPath ->
|
||||
IO ()
|
||||
spawnLsp lspFormattingConfig codebase runtime latestProjectRootHash latestPath =
|
||||
ifEnabled . TCP.withSocketsDo $ do
|
||||
lspPort <- getLspPort
|
||||
UnliftIO.handleIO (handleFailure lspPort) $ do
|
||||
@ -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,
|
||||
..
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -24,7 +24,7 @@ import Language.LSP.Server
|
||||
import Language.LSP.Server qualified as LSP
|
||||
import Language.LSP.VFS
|
||||
import Unison.Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.LSP.Orphans ()
|
||||
@ -72,7 +72,7 @@ data Env = Env
|
||||
currentNamesCache :: IO Names,
|
||||
ppedCache :: IO PrettyPrintEnvDecl,
|
||||
nameSearchCache :: IO (NameSearch Sqlite.Transaction),
|
||||
currentPathCache :: IO Path.Absolute,
|
||||
currentProjectPathCache :: IO PP.ProjectPath,
|
||||
vfsVar :: MVar VFS,
|
||||
runtime :: Runtime Symbol,
|
||||
-- The information we have for each file.
|
||||
@ -129,8 +129,8 @@ data FileAnalysis = FileAnalysis
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
getCurrentPath :: Lsp Path.Absolute
|
||||
getCurrentPath = asks currentPathCache >>= liftIO
|
||||
getCurrentProjectPath :: Lsp PP.ProjectPath
|
||||
getCurrentProjectPath = asks currentProjectPathCache >>= liftIO
|
||||
|
||||
getCodebaseCompletions :: Lsp CompletionTree
|
||||
getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar
|
||||
|
@ -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
|
||||
loop (currentRoot, currentPath) = do
|
||||
Debug.debugM Debug.LSP "LSP path: " currentPath
|
||||
currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath)
|
||||
let loop :: CausalHash -> ProjectPath -> Lsp a
|
||||
loop currentProjectRootHash currentProjectPath = do
|
||||
currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch . #projectId) (currentProjectPath ^. #branch . #branchId)
|
||||
Debug.debugM Debug.LSP "LSP path: " currentProjectPath
|
||||
let currentBranch0 = Branch.head currentBranch
|
||||
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
|
||||
latestRoot <- getLatestRoot
|
||||
latestPath <- getLatestPath
|
||||
guard $ (currentRoot /= latestRoot || currentPath /= latestPath)
|
||||
pure (latestRoot, latestPath)
|
||||
(latestRootHash, latestProjectPath) <- atomically $ do
|
||||
latestRootHash <- getLatestProjectRootHash
|
||||
latestPath <- getLatestProjectPath
|
||||
guard $ (currentProjectRootHash /= latestRootHash || currentProjectPath /= latestPath)
|
||||
pure (latestRootHash, latestPath)
|
||||
Debug.debugLogM Debug.LSP "LSP Change detected"
|
||||
loop latest
|
||||
(rootBranch, currentPath) <- atomically $ do
|
||||
rootBranch <- getLatestRoot
|
||||
currentPath <- getLatestPath
|
||||
pure (rootBranch, currentPath)
|
||||
loop (rootBranch, currentPath)
|
||||
loop latestRootHash latestProjectPath
|
||||
(currentProjectRootHash, currentProjectPath) <- atomically $ do
|
||||
latestProjectRootHash <- getLatestProjectRootHash
|
||||
currentProjectPath <- getLatestProjectPath
|
||||
pure (latestProjectRootHash, currentProjectPath)
|
||||
loop currentProjectRootHash currentProjectPath
|
||||
where
|
||||
-- This is added in stm-2.5.1, remove this if we upgrade.
|
||||
writeTMVar :: TMVar a -> a -> STM ()
|
||||
|
@ -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
|
||||
WithCLI -> do
|
||||
-- If the user didn't provide a starting path on the command line, put them in the most recent
|
||||
-- path they cd'd to
|
||||
case mayStartingPath of
|
||||
Just startingPath -> pure startingPath
|
||||
Nothing -> do
|
||||
segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace
|
||||
pure (Path.Absolute (Path.fromList segments))
|
||||
Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath
|
||||
rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash)
|
||||
rootCausalHashVar <- newTVarIO rootCausalHash
|
||||
pathVar <- newTVarIO startingPath
|
||||
startingProjectPath <- do
|
||||
-- If the user didn't provide a starting path on the command line, put them in the most recent
|
||||
-- path they cd'd to
|
||||
case mayStartingProject of
|
||||
Just startingProject -> do
|
||||
Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case
|
||||
Nothing -> do
|
||||
PT.putPrettyLn $
|
||||
P.callout
|
||||
"❓"
|
||||
( P.lines
|
||||
[ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject)
|
||||
]
|
||||
)
|
||||
System.exitFailure
|
||||
Just pab -> do
|
||||
pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty
|
||||
Nothing -> do
|
||||
Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
|
||||
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
|
||||
let notifyOnPathChanges :: Path.Absolute -> STM ()
|
||||
notifyOnPathChanges = writeTVar pathVar
|
||||
writeTVar projectRootHashVar b
|
||||
let notifyOnPathChanges :: PP.ProjectPath -> STM ()
|
||||
notifyOnPathChanges = writeTVar projectPathVar
|
||||
-- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever
|
||||
-- when waiting for input on handles, so if we listen for LSP connections it will
|
||||
-- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on
|
||||
-- Windows when we move to GHC 9.*
|
||||
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224
|
||||
void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar)
|
||||
void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar projectRootHashVar) (readTVar projectPathVar)
|
||||
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do
|
||||
case exitOption of
|
||||
DoNotExit -> do
|
||||
@ -346,7 +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' ""
|
||||
|
@ -6,14 +6,10 @@ module Unison.Share.Sync
|
||||
getCausalHashByPath,
|
||||
GetCausalHashByPathError (..),
|
||||
|
||||
-- ** Push
|
||||
checkAndSetPush,
|
||||
CheckAndSetPushError (..),
|
||||
fastForwardPush,
|
||||
FastForwardPushError (..),
|
||||
-- ** Upload
|
||||
uploadEntities,
|
||||
|
||||
-- ** Pull
|
||||
-- ** Pull/Download
|
||||
pull,
|
||||
PullError (..),
|
||||
downloadEntities,
|
||||
@ -26,16 +22,10 @@ import Control.Monad.Except
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||
import Control.Monad.Trans.Reader qualified as Reader
|
||||
import Data.Foldable qualified as Foldable (find)
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.Map qualified as Map
|
||||
import Data.Map.NonEmpty (NEMap)
|
||||
import Data.Map.NonEmpty qualified as NEMap
|
||||
import Data.Proxy
|
||||
import Data.Sequence.NonEmpty (NESeq ((:<||)))
|
||||
import Data.Sequence.NonEmpty qualified as NESeq (fromList, nonEmptySeq, (><|))
|
||||
import Data.Set qualified as Set
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
import Data.Set.NonEmpty qualified as NESet
|
||||
@ -65,7 +55,7 @@ import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expect
|
||||
import Unison.Share.Sync.Types
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sync.API qualified as Share (API)
|
||||
import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash)
|
||||
import Unison.Sync.Common (entityToTempEntity, expectEntity, hash32ToCausalHash)
|
||||
import Unison.Sync.EntityValidation qualified as EV
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
@ -98,300 +88,6 @@ syncChunkSize = unsafePerformIO $ do
|
||||
Nothing -> 50
|
||||
{-# NOINLINE syncChunkSize #-}
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Push
|
||||
|
||||
-- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the
|
||||
-- server is missing, too) to Unison Share.
|
||||
--
|
||||
-- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation
|
||||
-- is off, we won't proceed with the push.
|
||||
checkAndSetPush ::
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
-- | The repo+path to push to.
|
||||
Share.Path ->
|
||||
-- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error.
|
||||
-- This prevents accidentally pushing over data that we didn't know was there.
|
||||
Maybe Hash32 ->
|
||||
-- | The hash of our local causal to push.
|
||||
CausalHash ->
|
||||
-- | Callback that's given a number of entities we just uploaded.
|
||||
(Int -> IO ()) ->
|
||||
Cli (Either (SyncError CheckAndSetPushError) ())
|
||||
checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = do
|
||||
Cli.Env {authHTTPClient} <- ask
|
||||
|
||||
Cli.label \done -> do
|
||||
let failed :: SyncError CheckAndSetPushError -> Cli void
|
||||
failed = done . Left
|
||||
|
||||
let updatePathError :: Share.UpdatePathError -> Cli void
|
||||
updatePathError err =
|
||||
failed (SyncError (CheckAndSetPushError'UpdatePath (Share.pathRepoInfo path) err))
|
||||
|
||||
let updatePath :: Cli Share.UpdatePathResponse
|
||||
updatePath = do
|
||||
liftIO request & onLeftM \err -> failed (TransportError err)
|
||||
where
|
||||
request :: IO (Either CodeserverTransportError Share.UpdatePathResponse)
|
||||
request =
|
||||
httpUpdatePath
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
Share.UpdatePathRequest
|
||||
{ path,
|
||||
expectedHash,
|
||||
newHash = causalHashToHash32 causalHash
|
||||
}
|
||||
|
||||
-- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it
|
||||
-- needs this causal (UpdatePathMissingDependencies).
|
||||
dependencies <-
|
||||
updatePath >>= \case
|
||||
Share.UpdatePathSuccess -> done (Right ())
|
||||
Share.UpdatePathFailure err ->
|
||||
case err of
|
||||
Share.UpdatePathError'MissingDependencies (Share.NeedDependencies dependencies) -> pure dependencies
|
||||
_ -> updatePathError err
|
||||
|
||||
-- Upload the causal and all of its dependencies.
|
||||
uploadEntities unisonShareUrl (Share.pathRepoInfo path) dependencies uploadedCallback & onLeftM \err ->
|
||||
failed (CheckAndSetPushError'UploadEntities <$> err)
|
||||
|
||||
-- After uploading the causal and all of its dependencies, try setting the remote path again.
|
||||
updatePath >>= \case
|
||||
Share.UpdatePathSuccess -> pure (Right ())
|
||||
Share.UpdatePathFailure err -> updatePathError err
|
||||
|
||||
-- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the
|
||||
-- server is missing, too) to Unison Share.
|
||||
--
|
||||
-- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired
|
||||
-- state.
|
||||
fastForwardPush ::
|
||||
-- | The Unison Share URL.
|
||||
BaseUrl ->
|
||||
-- | The repo+path to push to.
|
||||
Share.Path ->
|
||||
-- | The hash of our local causal to push.
|
||||
CausalHash ->
|
||||
-- | Callback that's given a number of entities we just uploaded.
|
||||
(Int -> IO ()) ->
|
||||
Cli (Either (SyncError FastForwardPushError) ())
|
||||
fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
|
||||
Cli.label \done -> do
|
||||
let succeeded :: Cli void
|
||||
succeeded =
|
||||
done (Right ())
|
||||
|
||||
let failed :: SyncError FastForwardPushError -> Cli void
|
||||
failed = done . Left
|
||||
|
||||
let fastForwardPathError :: Share.FastForwardPathError -> Cli void
|
||||
fastForwardPathError err =
|
||||
failed (SyncError (FastForwardPushError'FastForwardPath path err))
|
||||
|
||||
remoteHeadHash <-
|
||||
getCausalHashByPath unisonShareUrl path >>= \case
|
||||
Left err -> failed (FastForwardPushError'GetCausalHash <$> err)
|
||||
Right Nothing -> fastForwardPathError Share.FastForwardPathError'NoHistory
|
||||
Right (Just remoteHeadHash) -> pure (Share.hashJWTHash remoteHeadHash)
|
||||
|
||||
let doLoadCausalSpineBetween = do
|
||||
-- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
|
||||
-- actual path.
|
||||
let isBefore :: Sqlite.Transaction Bool
|
||||
isBefore = do
|
||||
maybeHashIds <-
|
||||
runMaybeT $
|
||||
(,)
|
||||
<$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
|
||||
<*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
|
||||
case maybeHashIds of
|
||||
Nothing -> pure False
|
||||
Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
|
||||
isBefore >>= \case
|
||||
False -> pure Nothing
|
||||
True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
|
||||
|
||||
let doUpload :: List.NonEmpty CausalHash -> Cli ()
|
||||
-- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes",
|
||||
-- but we don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure
|
||||
-- the server doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server
|
||||
-- needs.
|
||||
doUpload (headHash :| _tailHashes) =
|
||||
request & onLeftM \err -> failed (FastForwardPushError'UploadEntities <$> err)
|
||||
where
|
||||
request =
|
||||
uploadEntities
|
||||
unisonShareUrl
|
||||
(Share.pathRepoInfo path)
|
||||
(NESet.singleton (causalHashToHash32 headHash))
|
||||
uploadedCallback
|
||||
|
||||
localInnerHashes <-
|
||||
Cli.runTransaction doLoadCausalSpineBetween >>= \case
|
||||
-- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a
|
||||
-- fast-forward push, so we don't bother trying - just report the error now.
|
||||
Nothing -> failed (SyncError (FastForwardPushError'NotFastForward path))
|
||||
-- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push.
|
||||
Just [] -> succeeded
|
||||
-- drop remote hash
|
||||
Just (_ : localInnerHashes) -> pure (map hash32ToCausalHash localInnerHashes)
|
||||
|
||||
doUpload (localHeadHash :| localInnerHashes)
|
||||
|
||||
let doFastForwardPath :: Cli Share.FastForwardPathResponse
|
||||
doFastForwardPath = do
|
||||
Cli.Env {authHTTPClient} <- ask
|
||||
let request =
|
||||
httpFastForwardPath
|
||||
authHTTPClient
|
||||
unisonShareUrl
|
||||
Share.FastForwardPathRequest
|
||||
{ expectedHash = remoteHeadHash,
|
||||
hashes =
|
||||
causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]),
|
||||
path
|
||||
}
|
||||
liftIO request & onLeftM \err -> failed (TransportError err)
|
||||
|
||||
doFastForwardPath >>= \case
|
||||
Share.FastForwardPathSuccess -> succeeded
|
||||
Share.FastForwardPathFailure err -> fastForwardPathError err
|
||||
|
||||
-- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments,
|
||||
-- excluding the newest hash (second argument).
|
||||
loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32])
|
||||
loadCausalSpineBetween earlierHash laterHash =
|
||||
dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash
|
||||
|
||||
data Step a
|
||||
= DeadEnd
|
||||
| KeepSearching (List.NonEmpty a)
|
||||
| FoundGoal a
|
||||
|
||||
-- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each
|
||||
-- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True).
|
||||
--
|
||||
-- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because
|
||||
-- it was provided as an input ;))
|
||||
--
|
||||
-- For example, when searching a tree that looks like
|
||||
--
|
||||
-- 1
|
||||
-- / \
|
||||
-- 2 3
|
||||
-- / \ \
|
||||
-- 4 [5] 6
|
||||
--
|
||||
-- (where the goal is marked [5]), we'd return
|
||||
--
|
||||
-- Just [5,2]
|
||||
--
|
||||
-- And (as another example), if the root node is the goal,
|
||||
--
|
||||
-- [1]
|
||||
-- / \
|
||||
-- 2 3
|
||||
-- / \ \
|
||||
-- 4 5 6
|
||||
--
|
||||
-- we'd return
|
||||
--
|
||||
-- Just []
|
||||
dagbfs :: forall a m. (Monad m) => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a])
|
||||
dagbfs goal children =
|
||||
let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied,
|
||||
-- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet.
|
||||
-- (Otherwise, we wouldn't still be in this loop, we'd return!).
|
||||
--
|
||||
-- For example, say we are exploring the tree
|
||||
--
|
||||
-- 1
|
||||
-- / \
|
||||
-- 2 3
|
||||
-- / \ \
|
||||
-- 4 5 6
|
||||
--
|
||||
-- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below
|
||||
-- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children,
|
||||
-- and maybe it doesn't).
|
||||
--
|
||||
-- The loop state, in this case, would be these three paths:
|
||||
--
|
||||
-- [ 4, 2 ]
|
||||
-- [ 5, 2 ]
|
||||
-- [ 6, 3 ]
|
||||
--
|
||||
-- (Note, again, that we do not include the root).
|
||||
go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a))
|
||||
go (path :<|| paths) =
|
||||
-- Step forward from the first path in our loop state (in the example above, [4, 2]).
|
||||
step (List.NonEmpty.head path) >>= \case
|
||||
-- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep
|
||||
-- searching (as we would in the example, since we have two more paths to continue from), or we don't, because
|
||||
-- this was the only remaining path.
|
||||
DeadEnd ->
|
||||
case NESeq.nonEmptySeq paths of
|
||||
Nothing -> pure Nothing
|
||||
Just paths' -> go paths'
|
||||
-- If node 4 did have children, then maybe the search tree now looks like this.
|
||||
--
|
||||
-- 1
|
||||
-- / \
|
||||
-- 2 3
|
||||
-- / \ \
|
||||
-- 4 5 6
|
||||
-- / \
|
||||
-- 7 8
|
||||
--
|
||||
-- There are two cases to handle:
|
||||
--
|
||||
-- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path
|
||||
--
|
||||
-- [ 7, 4, 2 ]
|
||||
--
|
||||
-- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end
|
||||
-- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four
|
||||
-- paths:
|
||||
--
|
||||
-- [ 5, 2 ] \ these two are are variable 'paths', the tail of the loop state.
|
||||
-- [ 6, 3 ] /
|
||||
-- [ 7, 4, 2 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children
|
||||
-- [ 8, 4, 2 ] / to itself, making two new paths to search
|
||||
KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys))
|
||||
FoundGoal y -> pure (Just (List.NonEmpty.cons y path))
|
||||
|
||||
-- Step forward from a single node. There are 3 possible outcomes:
|
||||
--
|
||||
-- 1. We discover it has no children. (return DeadEnd)
|
||||
-- 2. We discover is has children, none of which are a goal. (return KeepSearching)
|
||||
-- 3. We discover it has children, (at least) one of which is a goal. (return FoundGoal)
|
||||
step :: a -> m (Step a)
|
||||
step x = do
|
||||
ys0 <- children x
|
||||
pure case List.NonEmpty.nonEmpty ys0 of
|
||||
Nothing -> DeadEnd
|
||||
Just ys ->
|
||||
case Foldable.find goal ys of
|
||||
Nothing -> KeepSearching ys
|
||||
Just y -> FoundGoal y
|
||||
in \root ->
|
||||
if goal root
|
||||
then pure (Just [])
|
||||
else
|
||||
step root >>= \case
|
||||
DeadEnd -> pure Nothing
|
||||
-- lts-18.28 doesn't have List.NonEmpty.singleton
|
||||
KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs))
|
||||
FoundGoal x -> pure (Just [x])
|
||||
where
|
||||
-- Concatenate a seq and a non-empty seq.
|
||||
append :: Seq x -> NESeq x -> NESeq x
|
||||
append = (NESeq.><|)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Pull
|
||||
|
||||
@ -977,16 +673,6 @@ httpGetCausalHashByPath ::
|
||||
BaseUrl ->
|
||||
Share.GetCausalHashByPathRequest ->
|
||||
IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse)
|
||||
httpFastForwardPath ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.FastForwardPathRequest ->
|
||||
IO (Either CodeserverTransportError Share.FastForwardPathResponse)
|
||||
httpUpdatePath ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
Share.UpdatePathRequest ->
|
||||
IO (Either CodeserverTransportError Share.UpdatePathResponse)
|
||||
httpDownloadEntities ::
|
||||
Auth.AuthenticatedHttpClient ->
|
||||
BaseUrl ->
|
||||
@ -998,14 +684,10 @@ httpUploadEntities ::
|
||||
Share.UploadEntitiesRequest ->
|
||||
IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
|
||||
( httpGetCausalHashByPath,
|
||||
httpFastForwardPath,
|
||||
httpUpdatePath,
|
||||
httpDownloadEntities,
|
||||
httpUploadEntities
|
||||
) =
|
||||
let ( httpGetCausalHashByPath
|
||||
Servant.:<|> httpFastForwardPath
|
||||
Servant.:<|> httpUpdatePath
|
||||
Servant.:<|> httpDownloadEntities
|
||||
Servant.:<|> httpUploadEntities
|
||||
) =
|
||||
@ -1013,8 +695,6 @@ httpUploadEntities ::
|
||||
pp = Proxy
|
||||
in Servant.hoistClient pp hoist (Servant.client pp)
|
||||
in ( go httpGetCausalHashByPath,
|
||||
go httpFastForwardPath,
|
||||
go httpUpdatePath,
|
||||
go httpDownloadEntities,
|
||||
go httpUploadEntities
|
||||
)
|
||||
|
@ -1,8 +1,6 @@
|
||||
-- | Types used by the UCM client during sync.
|
||||
module Unison.Share.Sync.Types
|
||||
( CheckAndSetPushError (..),
|
||||
CodeserverTransportError (..),
|
||||
FastForwardPushError (..),
|
||||
( CodeserverTransportError (..),
|
||||
GetCausalHashByPathError (..),
|
||||
PullError (..),
|
||||
SyncError (..),
|
||||
@ -13,29 +11,6 @@ import Servant.Client qualified as Servant
|
||||
import Unison.Prelude
|
||||
import Unison.Sync.Types qualified as Share
|
||||
|
||||
-- | Error used by the client when pushing code to Unison Share.
|
||||
data CheckAndSetPushError
|
||||
= CheckAndSetPushError'UpdatePath
|
||||
-- The repo we are pushing to. This is only necessary because an UpdatePathError does not have enough context to
|
||||
-- print the entire error message we want to print, but it really should, at which point maybe this can go away.
|
||||
Share.RepoInfo
|
||||
Share.UpdatePathError
|
||||
| CheckAndSetPushError'UploadEntities Share.UploadEntitiesError
|
||||
deriving stock (Show)
|
||||
|
||||
-- | An error occurred while fast-forward pushing code to Unison Share.
|
||||
data FastForwardPushError
|
||||
= FastForwardPushError'FastForwardPath
|
||||
-- The path we are fast forwarding. This is only necessary because a FastForwardPathError does not have enough
|
||||
-- context to print the entire error message we want to print, but it really should, at which point maybe this can
|
||||
-- go away.
|
||||
Share.Path
|
||||
Share.FastForwardPathError
|
||||
| FastForwardPushError'GetCausalHash GetCausalHashByPathError
|
||||
| FastForwardPushError'NotFastForward Share.Path
|
||||
| FastForwardPushError'UploadEntities Share.UploadEntitiesError
|
||||
deriving stock (Show)
|
||||
|
||||
-- | An error occurred while pulling code from Unison Share.
|
||||
data PullError
|
||||
= PullError'DownloadEntities Share.DownloadEntitiesError
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -38,7 +38,7 @@ module Unison.Server.Backend
|
||||
lsAtPath,
|
||||
lsBranch,
|
||||
mungeSyntaxText,
|
||||
resolveCausalHashV2,
|
||||
Codebase.expectCausalBranchByCausalHash,
|
||||
resolveRootBranchHashV2,
|
||||
namesAtPathFromRootBranchHash,
|
||||
termEntryDisplayName,
|
||||
@ -58,7 +58,6 @@ module Unison.Server.Backend
|
||||
renderDocRefs,
|
||||
docsForDefinitionName,
|
||||
normaliseRootCausalHash,
|
||||
causalHashForProjectBranchName,
|
||||
|
||||
-- * Unused, could remove?
|
||||
resolveRootBranchHash,
|
||||
@ -101,16 +100,12 @@ import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (BranchHash, CausalHash (..))
|
||||
import U.Codebase.Referent qualified as V2Referent
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Builtin qualified as B
|
||||
import Unison.Builtin.Decls qualified as Decls
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase qualified as UCodebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
@ -148,8 +143,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||
import Unison.PrettyPrintEnv.Util qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project.Util qualified as ProjectUtils
|
||||
import Unison.Project (ProjectBranchName, ProjectName)
|
||||
import Unison.Reference (Reference, TermReference, TypeReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
@ -370,12 +364,12 @@ lsAtPath ::
|
||||
(MonadIO m) =>
|
||||
Codebase m Symbol Ann ->
|
||||
-- The root to follow the path from.
|
||||
Maybe (V2Branch.Branch Sqlite.Transaction) ->
|
||||
V2Branch.Branch Sqlite.Transaction ->
|
||||
-- Path from the root to the branch to 'ls'
|
||||
Path.Absolute ->
|
||||
m [ShallowListEntry Symbol Ann]
|
||||
lsAtPath codebase mayRootBranch absPath = do
|
||||
b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) mayRootBranch)
|
||||
lsAtPath codebase rootBranch absPath = do
|
||||
b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) rootBranch)
|
||||
lsBranch codebase b
|
||||
|
||||
findDocInBranch ::
|
||||
@ -700,14 +694,12 @@ expandShortCausalHash hash = do
|
||||
|
||||
-- | Efficiently resolve a root hash and path to a shallow branch's causal.
|
||||
getShallowCausalAtPathFromRootHash ::
|
||||
Maybe CausalHash ->
|
||||
CausalHash ->
|
||||
Path ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalAtPathFromRootHash mayRootHash path = do
|
||||
shallowRoot <- case mayRootHash of
|
||||
Nothing -> Codebase.getShallowRootCausal
|
||||
Just h -> Codebase.expectCausalBranchByCausalHash h
|
||||
Codebase.getShallowCausalAtPath path (Just shallowRoot)
|
||||
getShallowCausalAtPathFromRootHash rootHash path = do
|
||||
shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash
|
||||
Codebase.getShallowCausalAtPath path shallowRoot
|
||||
|
||||
formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
|
||||
formatType' ppe w =
|
||||
@ -987,16 +979,12 @@ namesAtPathFromRootBranchHash ::
|
||||
forall m n v a.
|
||||
(MonadIO m) =>
|
||||
Codebase m v a ->
|
||||
Maybe (V2Branch.CausalBranch n) ->
|
||||
V2Branch.CausalBranch n ->
|
||||
Path ->
|
||||
Backend m (Names, PPED.PrettyPrintEnvDecl)
|
||||
namesAtPathFromRootBranchHash codebase mbh path = do
|
||||
namesAtPathFromRootBranchHash codebase cb path = do
|
||||
shouldUseNamesIndex <- asks useNamesIndex
|
||||
(rootBranchHash, rootCausalHash) <- case mbh of
|
||||
Just cb -> pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
||||
Nothing -> lift $ do
|
||||
cb <- Codebase.runTransaction codebase Operations.expectRootCausal
|
||||
pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
||||
let (rootBranchHash, rootCausalHash) = (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
||||
haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash)
|
||||
hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength
|
||||
names <-
|
||||
@ -1005,47 +993,34 @@ namesAtPathFromRootBranchHash codebase mbh path = do
|
||||
when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash
|
||||
lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path
|
||||
else do
|
||||
Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash (Just rootCausalHash) codebase
|
||||
Branch.toNames . Branch.getAt0 path . Branch.head <$> resolveCausalHash rootCausalHash codebase
|
||||
let pped = PPED.makePPED (PPE.hqNamer hashLen names) (PPE.suffixifyByHash names)
|
||||
pure (names, pped)
|
||||
|
||||
resolveCausalHash ::
|
||||
(Monad m) => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||
resolveCausalHash h codebase = case h of
|
||||
Nothing -> lift (Codebase.getRootBranch codebase)
|
||||
Just bhash -> do
|
||||
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
|
||||
whenNothing mayBranch (throwError $ NoBranchForHash bhash)
|
||||
|
||||
resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
resolveCausalHashV2 h = case h of
|
||||
Nothing -> Codebase.getShallowRootCausal
|
||||
Just ch -> Codebase.expectCausalBranchByCausalHash ch
|
||||
(Monad m) => CausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||
resolveCausalHash bhash codebase = do
|
||||
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
|
||||
whenNothing mayBranch (throwError $ NoBranchForHash bhash)
|
||||
|
||||
resolveRootBranchHash ::
|
||||
(MonadIO m) => Maybe ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||
resolveRootBranchHash mayRoot codebase = case mayRoot of
|
||||
Nothing ->
|
||||
lift (Codebase.getRootBranch codebase)
|
||||
Just sch -> do
|
||||
h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
|
||||
resolveCausalHash (Just h) codebase
|
||||
(MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||
resolveRootBranchHash sch codebase = do
|
||||
h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
|
||||
resolveCausalHash h codebase
|
||||
|
||||
resolveRootBranchHashV2 ::
|
||||
Maybe ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
resolveRootBranchHashV2 mayRoot = case mayRoot of
|
||||
Nothing -> lift Codebase.getShallowRootCausal
|
||||
Just sch -> do
|
||||
h <- expandShortCausalHash sch
|
||||
lift (resolveCausalHashV2 (Just h))
|
||||
ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
resolveRootBranchHashV2 sch = do
|
||||
h <- expandShortCausalHash sch
|
||||
lift (Codebase.expectCausalBranchByCausalHash h)
|
||||
|
||||
normaliseRootCausalHash :: Maybe (Either ShortCausalHash CausalHash) -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
normaliseRootCausalHash mayCh = case mayCh of
|
||||
Nothing -> lift $ resolveCausalHashV2 Nothing
|
||||
Just (Left sch) -> do
|
||||
normaliseRootCausalHash :: Either ShortCausalHash CausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
normaliseRootCausalHash = \case
|
||||
(Left sch) -> do
|
||||
ch <- expandShortCausalHash sch
|
||||
lift $ resolveCausalHashV2 (Just ch)
|
||||
Just (Right ch) -> lift $ resolveCausalHashV2 (Just ch)
|
||||
lift $ Codebase.expectCausalBranchByCausalHash ch
|
||||
(Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch
|
||||
|
||||
-- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?)
|
||||
--
|
||||
@ -1271,15 +1246,3 @@ loadTypeDisplayObject c = \case
|
||||
Reference.DerivedId id ->
|
||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||
<$> Codebase.getTypeDeclaration c id
|
||||
|
||||
-- | Get the causal hash a given project branch points to
|
||||
causalHashForProjectBranchName :: (MonadIO m) => ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe CausalHash)
|
||||
causalHashForProjectBranchName (ProjectAndBranch projectName branchName) = do
|
||||
Q.loadProjectBranchByNames projectName branchName >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just ProjectBranch {projectId, branchId} -> do
|
||||
let path = ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId)
|
||||
-- Use the default codebase root
|
||||
let codebaseRoot = Nothing
|
||||
mayCausal <- UCodebase.getShallowCausalFromRoot codebaseRoot (Path.unabsolute path)
|
||||
pure . Just $ V2Causal.causalHash mayCausal
|
||||
|
@ -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 ns def =
|
||||
path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment]
|
||||
path (Path.Absolute ns) def =
|
||||
let nsPath = namespacePath ns
|
||||
in case definitionPath def of
|
||||
Just defPath -> case nsPath of
|
||||
@ -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)
|
||||
:<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left <$> mayRoot) renderWidth)
|
||||
:<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left <$> mayRoot) relativePath rawHqns renderWidth suff)
|
||||
:<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left <$> mayRoot) relativePath limit renderWidth query)
|
||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
|
||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
|
||||
(\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left root) rel name)
|
||||
:<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left mayRoot) renderWidth)
|
||||
:<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left mayRoot) relativePath rawHqns renderWidth suff)
|
||||
:<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left mayRoot) relativePath limit renderWidth query)
|
||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
|
||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
|
||||
|
||||
serveProjectsCodebaseServerAPI ::
|
||||
Codebase IO Symbol Ann ->
|
||||
@ -588,34 +587,38 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do
|
||||
where
|
||||
projectAndBranchName = ProjectAndBranch projectName branchName
|
||||
namespaceListingEndpoint _rootParam rel name = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name
|
||||
namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth
|
||||
|
||||
serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff
|
||||
|
||||
serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query
|
||||
|
||||
serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth
|
||||
|
||||
serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
||||
root <- resolveProjectRoot codebase projectAndBranchName
|
||||
setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
|
||||
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||
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
|
||||
case mayCH of
|
||||
mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName
|
||||
case mayCB of
|
||||
Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName)
|
||||
Just ch -> pure ch
|
||||
Just cb -> pure cb
|
||||
|
||||
resolveProjectRootHash :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash
|
||||
resolveProjectRootHash codebase projectAndBranchName = do
|
||||
resolveProjectRoot codebase projectAndBranchName <&> Causal.causalHash
|
||||
|
||||
serveProjectDiffTermsEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse
|
||||
serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do
|
||||
@ -638,7 +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)
|
||||
|
@ -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
|
||||
|
@ -7,17 +7,12 @@ import Data.Aeson
|
||||
import Data.OpenApi (ToSchema (..))
|
||||
import Servant ((:>))
|
||||
import Servant.Docs (ToSample (..))
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project qualified as Project
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment)
|
||||
import Unison.Server.Backend
|
||||
import Unison.Server.Types (APIGet)
|
||||
|
||||
@ -39,7 +34,7 @@ instance ToSample Current where
|
||||
Current
|
||||
(Just $ UnsafeProjectName "@unison/base")
|
||||
(Just $ UnsafeProjectBranchName "main")
|
||||
(Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1")
|
||||
(Path.Absolute $ Path.unsafeParseText ".my.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
|
||||
let absolutePath = toPath segments
|
||||
case toIds segments of
|
||||
ProjectAndBranch (Just projectId) branchId ->
|
||||
Codebase.runTransaction codebase do
|
||||
project <- Queries.expectProject projectId
|
||||
branch <- traverse (Queries.expectProjectBranch projectId) branchId
|
||||
pure $ Current (Just $ Project.name project) (ProjectBranch.name <$> branch) absolutePath
|
||||
ProjectAndBranch _ _ ->
|
||||
pure $ Current Nothing Nothing absolutePath
|
||||
where
|
||||
toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId)
|
||||
toIds segments =
|
||||
case segments of
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ ->
|
||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId}
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : _ ->
|
||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing}
|
||||
_ ->
|
||||
ProjectAndBranch {project = Nothing, branch = Nothing}
|
||||
|
||||
toPath :: [NameSegment] -> Path.Absolute
|
||||
toPath = Path.Absolute . Path.fromList
|
||||
pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath
|
||||
let (PP.ProjectPath projName branchName path) = PP.toNames pp
|
||||
pure $ Current (Just projName) (Just branchName) path
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
(localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path
|
||||
Backend.normaliseRootCausalHash root
|
||||
(localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal path
|
||||
let alignments ::
|
||||
( [ ( FZF.Alignment,
|
||||
UnisonName,
|
||||
|
@ -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
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user