mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +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
|
module U.Codebase.Sqlite.Operations
|
||||||
( -- * branches
|
( -- * branches
|
||||||
saveRootBranch,
|
|
||||||
loadRootCausalHash,
|
|
||||||
expectRootCausalHash,
|
|
||||||
expectRootCausal,
|
|
||||||
expectRootBranchHash,
|
|
||||||
loadCausalHashAtPath,
|
loadCausalHashAtPath,
|
||||||
expectCausalHashAtPath,
|
expectCausalHashAtPath,
|
||||||
loadCausalBranchAtPath,
|
loadCausalBranchAtPath,
|
||||||
@ -13,6 +8,7 @@ module U.Codebase.Sqlite.Operations
|
|||||||
saveBranchV3,
|
saveBranchV3,
|
||||||
loadCausalBranchByCausalHash,
|
loadCausalBranchByCausalHash,
|
||||||
expectCausalBranchByCausalHash,
|
expectCausalBranchByCausalHash,
|
||||||
|
expectBranchByCausalHashId,
|
||||||
expectBranchByBranchHash,
|
expectBranchByBranchHash,
|
||||||
expectBranchByBranchHashId,
|
expectBranchByBranchHashId,
|
||||||
expectNamespaceStatsByHash,
|
expectNamespaceStatsByHash,
|
||||||
@ -100,9 +96,15 @@ module U.Codebase.Sqlite.Operations
|
|||||||
fuzzySearchDefinitions,
|
fuzzySearchDefinitions,
|
||||||
namesPerspectiveForRootAndPath,
|
namesPerspectiveForRootAndPath,
|
||||||
|
|
||||||
|
-- * Projects
|
||||||
|
expectProjectAndBranchNames,
|
||||||
|
expectProjectBranchHead,
|
||||||
|
|
||||||
-- * reflog
|
-- * reflog
|
||||||
getReflog,
|
getReflog,
|
||||||
appendReflog,
|
appendReflog,
|
||||||
|
getProjectReflog,
|
||||||
|
appendProjectReflog,
|
||||||
|
|
||||||
-- * low-level stuff
|
-- * low-level stuff
|
||||||
expectDbBranch,
|
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.TermEdit qualified as S.TermEdit
|
||||||
import U.Codebase.Sqlite.Patch.TypeEdit qualified as S
|
import U.Codebase.Sqlite.Patch.TypeEdit qualified as S
|
||||||
import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit
|
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.Queries qualified as Q
|
||||||
import U.Codebase.Sqlite.Reference qualified as S
|
import U.Codebase.Sqlite.Reference qualified as S
|
||||||
import U.Codebase.Sqlite.Reference qualified as S.Reference
|
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.Codebase.WatchKind (WatchKind)
|
||||||
import U.Util.Base32Hex qualified as Base32Hex
|
import U.Util.Base32Hex qualified as Base32Hex
|
||||||
import U.Util.Serialization qualified as S
|
import U.Util.Serialization qualified as S
|
||||||
|
import Unison.Core.Project (ProjectBranchName, ProjectName)
|
||||||
import Unison.Hash qualified as H
|
import Unison.Hash qualified as H
|
||||||
import Unison.Hash32 qualified as Hash32
|
import Unison.Hash32 qualified as Hash32
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
@ -232,23 +238,10 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId
|
|||||||
loadValueHashById :: Db.BranchHashId -> Transaction BranchHash
|
loadValueHashById :: Db.BranchHashId -> Transaction BranchHash
|
||||||
loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId
|
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
|
-- | Load the causal hash at the given path from the provided root, if Nothing, use the
|
||||||
-- codebase root.
|
-- codebase root.
|
||||||
loadCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
|
loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
|
||||||
loadCausalHashAtPath mayRootCausalHash =
|
loadCausalHashAtPath rootCausalHash =
|
||||||
let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
|
let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
|
||||||
go hashId = \case
|
go hashId = \case
|
||||||
[] -> lift (Q.expectCausalHash hashId)
|
[] -> lift (Q.expectCausalHash hashId)
|
||||||
@ -258,15 +251,13 @@ loadCausalHashAtPath mayRootCausalHash =
|
|||||||
(_, hashId') <- MaybeT (pure (Map.lookup tid children))
|
(_, hashId') <- MaybeT (pure (Map.lookup tid children))
|
||||||
go hashId' ts
|
go hashId' ts
|
||||||
in \path -> do
|
in \path -> do
|
||||||
hashId <- case mayRootCausalHash of
|
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
|
||||||
Nothing -> Q.expectNamespaceRoot
|
|
||||||
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
|
|
||||||
runMaybeT (go hashId path)
|
runMaybeT (go hashId path)
|
||||||
|
|
||||||
-- | Expect the causal hash at the given path from the provided root, if Nothing, use the
|
-- | Expect the causal hash at the given path from the provided root, if Nothing, use the
|
||||||
-- codebase root.
|
-- codebase root.
|
||||||
expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash
|
expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash
|
||||||
expectCausalHashAtPath mayRootCausalHash =
|
expectCausalHashAtPath rootCausalHash =
|
||||||
let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
|
let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
|
||||||
go hashId = \case
|
go hashId = \case
|
||||||
[] -> Q.expectCausalHash hashId
|
[] -> Q.expectCausalHash hashId
|
||||||
@ -276,23 +267,21 @@ expectCausalHashAtPath mayRootCausalHash =
|
|||||||
let (_, hashId') = children Map.! tid
|
let (_, hashId') = children Map.! tid
|
||||||
go hashId' ts
|
go hashId' ts
|
||||||
in \path -> do
|
in \path -> do
|
||||||
hashId <- case mayRootCausalHash of
|
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
|
||||||
Nothing -> Q.expectNamespaceRoot
|
|
||||||
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
|
|
||||||
go hashId path
|
go hashId path
|
||||||
|
|
||||||
loadCausalBranchAtPath ::
|
loadCausalBranchAtPath ::
|
||||||
Maybe CausalHash ->
|
CausalHash ->
|
||||||
[NameSegment] ->
|
[NameSegment] ->
|
||||||
Transaction (Maybe (C.Branch.CausalBranch Transaction))
|
Transaction (Maybe (C.Branch.CausalBranch Transaction))
|
||||||
loadCausalBranchAtPath maybeRootCausalHash path =
|
loadCausalBranchAtPath rootCausalHash path =
|
||||||
loadCausalHashAtPath maybeRootCausalHash path >>= \case
|
loadCausalHashAtPath rootCausalHash path >>= \case
|
||||||
Nothing -> pure Nothing
|
Nothing -> pure Nothing
|
||||||
Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
|
Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
|
||||||
|
|
||||||
loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
|
loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
|
||||||
loadBranchAtPath maybeRootCausalHash path =
|
loadBranchAtPath rootCausalHash path =
|
||||||
loadCausalBranchAtPath maybeRootCausalHash path >>= \case
|
loadCausalBranchAtPath rootCausalHash path >>= \case
|
||||||
Nothing -> pure Nothing
|
Nothing -> pure Nothing
|
||||||
Just causal -> Just <$> C.Causal.value causal
|
Just causal -> Just <$> C.Causal.value causal
|
||||||
|
|
||||||
@ -613,16 +602,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
|
|||||||
boId <- Q.expectBranchObjectIdByCausalHashId chId
|
boId <- Q.expectBranchObjectIdByCausalHashId chId
|
||||||
expectBranch boId
|
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"
|
-- saveBranch is kind of a "deep save causal"
|
||||||
|
|
||||||
-- we want a "shallow save causal" that could take a
|
-- 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
|
Q.saveCausal hh chId bhId parentCausalHashIds
|
||||||
pure (chId, bhId)
|
pure (chId, bhId)
|
||||||
|
|
||||||
expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction)
|
|
||||||
expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId
|
|
||||||
|
|
||||||
loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction))
|
loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction))
|
||||||
loadCausalBranchByCausalHash hc = do
|
loadCausalBranchByCausalHash hc = do
|
||||||
Q.loadCausalHashIdByCausalHash hc >>= \case
|
Q.loadCausalHashIdByCausalHash hc >>= \case
|
||||||
@ -1520,6 +1496,17 @@ appendReflog entry = do
|
|||||||
dbEntry <- (bitraverse Q.saveCausalHash pure) entry
|
dbEntry <- (bitraverse Q.saveCausalHash pure) entry
|
||||||
Q.appendReflog dbEntry
|
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.
|
-- | Delete any name lookup that's not in the provided list.
|
||||||
--
|
--
|
||||||
-- This can be used to garbage collect unreachable name lookups.
|
-- This can be used to garbage collect unreachable name lookups.
|
||||||
@ -1584,3 +1571,14 @@ stripPrefixFromNamedRef (PathSegments prefix) namedRef =
|
|||||||
Nothing -> reversedName
|
Nothing -> reversedName
|
||||||
Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath)
|
Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath)
|
||||||
in namedRef {S.reversedSegments = newReversedName}
|
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,
|
{ projectId :: !ProjectId,
|
||||||
name :: !ProjectName
|
name :: !ProjectName
|
||||||
}
|
}
|
||||||
deriving stock (Generic, Show)
|
deriving stock (Generic, Show, Eq)
|
||||||
deriving anyclass (ToRow, FromRow)
|
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,
|
loadTermObject,
|
||||||
expectTermObject,
|
expectTermObject,
|
||||||
|
|
||||||
-- * namespace_root table
|
|
||||||
loadNamespaceRoot,
|
|
||||||
setNamespaceRoot,
|
|
||||||
expectNamespaceRoot,
|
|
||||||
expectNamespaceRootBranchHashId,
|
|
||||||
|
|
||||||
-- * namespace_statistics table
|
-- * namespace_statistics table
|
||||||
saveNamespaceStats,
|
saveNamespaceStats,
|
||||||
loadNamespaceStatsByHashId,
|
loadNamespaceStatsByHashId,
|
||||||
@ -135,6 +129,8 @@ module U.Codebase.Sqlite.Queries
|
|||||||
insertProjectBranch,
|
insertProjectBranch,
|
||||||
renameProjectBranch,
|
renameProjectBranch,
|
||||||
deleteProjectBranch,
|
deleteProjectBranch,
|
||||||
|
setProjectBranchHead,
|
||||||
|
expectProjectBranchHead,
|
||||||
setMostRecentBranch,
|
setMostRecentBranch,
|
||||||
loadMostRecentBranch,
|
loadMostRecentBranch,
|
||||||
|
|
||||||
@ -217,6 +213,8 @@ module U.Codebase.Sqlite.Queries
|
|||||||
-- * Reflog
|
-- * Reflog
|
||||||
appendReflog,
|
appendReflog,
|
||||||
getReflog,
|
getReflog,
|
||||||
|
appendProjectReflog,
|
||||||
|
getProjectReflog,
|
||||||
|
|
||||||
-- * garbage collection
|
-- * garbage collection
|
||||||
garbageCollectObjectsWithoutHashes,
|
garbageCollectObjectsWithoutHashes,
|
||||||
@ -237,12 +235,12 @@ module U.Codebase.Sqlite.Queries
|
|||||||
-- * elaborate hashes
|
-- * elaborate hashes
|
||||||
elaborateHashes,
|
elaborateHashes,
|
||||||
|
|
||||||
-- * most recent namespace
|
-- * current project path
|
||||||
expectMostRecentNamespace,
|
expectCurrentProjectPath,
|
||||||
setMostRecentNamespace,
|
setCurrentProjectPath,
|
||||||
|
|
||||||
-- * migrations
|
-- * migrations
|
||||||
createSchema,
|
runCreateSql,
|
||||||
addTempEntityTables,
|
addTempEntityTables,
|
||||||
addReflogTable,
|
addReflogTable,
|
||||||
addNamespaceStatsTables,
|
addNamespaceStatsTables,
|
||||||
@ -254,6 +252,9 @@ module U.Codebase.Sqlite.Queries
|
|||||||
addSquashResultTable,
|
addSquashResultTable,
|
||||||
addSquashResultTableIfNotExists,
|
addSquashResultTableIfNotExists,
|
||||||
cdToProjectRoot,
|
cdToProjectRoot,
|
||||||
|
addCurrentProjectPathTable,
|
||||||
|
addProjectBranchReflogTable,
|
||||||
|
addProjectBranchCausalHashIdColumn,
|
||||||
|
|
||||||
-- ** schema version
|
-- ** schema version
|
||||||
currentSchemaVersion,
|
currentSchemaVersion,
|
||||||
@ -315,6 +316,7 @@ import Data.Set qualified as Set
|
|||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Text.Encoding qualified as Text
|
import Data.Text.Encoding qualified as Text
|
||||||
import Data.Text.Lazy qualified as Text.Lazy
|
import Data.Text.Lazy qualified as Text.Lazy
|
||||||
|
import Data.Time qualified as Time
|
||||||
import Data.Vector qualified as Vector
|
import Data.Vector qualified as Vector
|
||||||
import GHC.Stack (callStack)
|
import GHC.Stack (callStack)
|
||||||
import Network.URI (URI)
|
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.Patch.Format qualified as PatchFormat
|
||||||
import U.Codebase.Sqlite.Project (Project (..))
|
import U.Codebase.Sqlite.Project (Project (..))
|
||||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
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.Reference qualified as S.Reference
|
||||||
import U.Codebase.Sqlite.Referent qualified as S (TextReferent)
|
import U.Codebase.Sqlite.Referent qualified as S (TextReferent)
|
||||||
import U.Codebase.Sqlite.Referent qualified as S.Referent
|
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.NameSegment.Internal qualified as NameSegment
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Sqlite
|
import Unison.Sqlite
|
||||||
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Unison.Util.Alternative qualified as Alternative
|
import Unison.Util.Alternative qualified as Alternative
|
||||||
import Unison.Util.Defns (Defns (..), DefnsF)
|
import Unison.Util.Defns (Defns (..), DefnsF)
|
||||||
import Unison.Util.FileEmbed (embedProjectStringFile)
|
import Unison.Util.FileEmbed (embedProjectStringFile)
|
||||||
@ -414,27 +418,11 @@ type TextPathSegments = [Text]
|
|||||||
-- * main squeeze
|
-- * main squeeze
|
||||||
|
|
||||||
currentSchemaVersion :: SchemaVersion
|
currentSchemaVersion :: SchemaVersion
|
||||||
currentSchemaVersion = 16
|
currentSchemaVersion = 17
|
||||||
|
|
||||||
createSchema :: Transaction ()
|
runCreateSql :: Transaction ()
|
||||||
createSchema = do
|
runCreateSql =
|
||||||
executeStatements $(embedProjectStringFile "sql/create.sql")
|
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 :: Transaction ()
|
||||||
addTempEntityTables =
|
addTempEntityTables =
|
||||||
@ -444,6 +432,7 @@ addNamespaceStatsTables :: Transaction ()
|
|||||||
addNamespaceStatsTables =
|
addNamespaceStatsTables =
|
||||||
executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql")
|
executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql")
|
||||||
|
|
||||||
|
-- | Deprecated in favour of project-branch reflog
|
||||||
addReflogTable :: Transaction ()
|
addReflogTable :: Transaction ()
|
||||||
addReflogTable =
|
addReflogTable =
|
||||||
executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql")
|
executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql")
|
||||||
@ -482,6 +471,19 @@ cdToProjectRoot :: Transaction ()
|
|||||||
cdToProjectRoot =
|
cdToProjectRoot =
|
||||||
executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql")
|
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 :: Transaction SchemaVersion
|
||||||
schemaVersion =
|
schemaVersion =
|
||||||
queryOneCol
|
queryOneCol
|
||||||
@ -1337,32 +1339,6 @@ loadCausalParentsByHash hash =
|
|||||||
WHERE h1.base32 = :hash COLLATE NOCASE
|
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 :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction ()
|
||||||
saveWatch k r blob = do
|
saveWatch k r blob = do
|
||||||
execute
|
execute
|
||||||
@ -3514,6 +3490,24 @@ getReflog numEntries =
|
|||||||
LIMIT :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?
|
-- | Does a project exist with this id?
|
||||||
projectExists :: ProjectId -> Transaction Bool
|
projectExists :: ProjectId -> Transaction Bool
|
||||||
projectExists projectId =
|
projectExists projectId =
|
||||||
@ -3803,12 +3797,15 @@ loadProjectAndBranchNames projectId branchId =
|
|||||||
|]
|
|]
|
||||||
|
|
||||||
-- | Insert a project branch.
|
-- | Insert a project branch.
|
||||||
insertProjectBranch :: ProjectBranch -> Transaction ()
|
insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
|
||||||
insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
||||||
|
-- Ensure we never point at a causal we don't have the branch for.
|
||||||
|
_ <- expectBranchObjectIdByCausalHashId causalHashId
|
||||||
|
|
||||||
execute
|
execute
|
||||||
[sql|
|
[sql|
|
||||||
INSERT INTO project_branch (project_id, branch_id, name)
|
INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
|
||||||
VALUES (:projectId, :branchId, :branchName)
|
VALUES (:projectId, :branchId, :branchName, :causalHashId)
|
||||||
|]
|
|]
|
||||||
whenJust maybeParentBranchId \parentBranchId ->
|
whenJust maybeParentBranchId \parentBranchId ->
|
||||||
execute
|
execute
|
||||||
@ -3816,6 +3813,16 @@ insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBran
|
|||||||
INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id)
|
INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id)
|
||||||
VALUES (:projectId, :parentBranchId, :branchId)
|
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.
|
-- | Rename a project branch.
|
||||||
--
|
--
|
||||||
@ -3888,6 +3895,38 @@ deleteProjectBranch projectId branchId = do
|
|||||||
WHERE project_id = :projectId AND branch_id = :branchId
|
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
|
data LoadRemoteBranchFlag
|
||||||
= IncludeSelfRemote
|
= IncludeSelfRemote
|
||||||
| ExcludeSelfRemote
|
| ExcludeSelfRemote
|
||||||
@ -4372,33 +4411,39 @@ data JsonParseFailure = JsonParseFailure
|
|||||||
deriving anyclass (SqliteExceptionReason)
|
deriving anyclass (SqliteExceptionReason)
|
||||||
|
|
||||||
-- | Get the most recent namespace the user has visited.
|
-- | Get the most recent namespace the user has visited.
|
||||||
expectMostRecentNamespace :: Transaction [NameSegment]
|
expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
|
||||||
expectMostRecentNamespace =
|
expectCurrentProjectPath =
|
||||||
queryOneColCheck
|
queryOneRowCheck
|
||||||
[sql|
|
[sql|
|
||||||
SELECT namespace
|
SELECT project_id, branch_id, path
|
||||||
FROM most_recent_namespace
|
FROM current_project_path
|
||||||
|]
|
|]
|
||||||
check
|
check
|
||||||
where
|
where
|
||||||
check :: Text -> Either JsonParseFailure [NameSegment]
|
check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
|
||||||
check bytes =
|
check (projId, branchId, pathText) =
|
||||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
|
case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of
|
||||||
Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
|
Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure}
|
||||||
Right namespace -> Right (map NameSegment namespace)
|
Right namespace -> Right (projId, branchId, map NameSegment namespace)
|
||||||
|
|
||||||
-- | Set the most recent namespace the user has visited.
|
-- | Set the most recent namespace the user has visited.
|
||||||
setMostRecentNamespace :: [NameSegment] -> Transaction ()
|
setCurrentProjectPath ::
|
||||||
setMostRecentNamespace namespace =
|
ProjectId ->
|
||||||
|
ProjectBranchId ->
|
||||||
|
[NameSegment] ->
|
||||||
|
Transaction ()
|
||||||
|
setCurrentProjectPath projId branchId path = do
|
||||||
|
execute
|
||||||
|
[sql| DELETE FROM current_project_path |]
|
||||||
execute
|
execute
|
||||||
[sql|
|
[sql|
|
||||||
UPDATE most_recent_namespace
|
INSERT INTO current_project_path(project_id, branch_id, path)
|
||||||
SET namespace = :json
|
VALUES (:projId, :branchId, :jsonPath)
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
json :: Text
|
jsonPath :: Text
|
||||||
json =
|
jsonPath =
|
||||||
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace)
|
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path)
|
||||||
|
|
||||||
-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
|
-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
|
||||||
-- at some point in the past.
|
-- at some point in the past.
|
||||||
|
@ -27,6 +27,7 @@ dependencies:
|
|||||||
- nonempty-containers
|
- nonempty-containers
|
||||||
- safe
|
- safe
|
||||||
- text
|
- text
|
||||||
|
- time
|
||||||
- transformers
|
- transformers
|
||||||
- unison-codebase
|
- unison-codebase
|
||||||
- unison-codebase-sync
|
- 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
|
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
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
@ -21,6 +21,9 @@ extra-source-files:
|
|||||||
sql/009-add-squash-cache-table.sql
|
sql/009-add-squash-cache-table.sql
|
||||||
sql/010-ensure-squash-cache-table.sql
|
sql/010-ensure-squash-cache-table.sql
|
||||||
sql/011-cd-to-project-root.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
|
sql/create.sql
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
@ -54,6 +57,7 @@ library
|
|||||||
U.Codebase.Sqlite.Patch.TypeEdit
|
U.Codebase.Sqlite.Patch.TypeEdit
|
||||||
U.Codebase.Sqlite.Project
|
U.Codebase.Sqlite.Project
|
||||||
U.Codebase.Sqlite.ProjectBranch
|
U.Codebase.Sqlite.ProjectBranch
|
||||||
|
U.Codebase.Sqlite.ProjectReflog
|
||||||
U.Codebase.Sqlite.Queries
|
U.Codebase.Sqlite.Queries
|
||||||
U.Codebase.Sqlite.Reference
|
U.Codebase.Sqlite.Reference
|
||||||
U.Codebase.Sqlite.Referent
|
U.Codebase.Sqlite.Referent
|
||||||
@ -121,6 +125,7 @@ library
|
|||||||
, nonempty-containers
|
, nonempty-containers
|
||||||
, safe
|
, safe
|
||||||
, text
|
, text
|
||||||
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, unison-codebase
|
, unison-codebase
|
||||||
, unison-codebase-sync
|
, unison-codebase-sync
|
||||||
|
@ -151,7 +151,7 @@ logQuery (Sql sql params) result =
|
|||||||
|
|
||||||
-- Without results
|
-- Without results
|
||||||
|
|
||||||
execute :: Connection -> Sql -> IO ()
|
execute :: HasCallStack => Connection -> Sql -> IO ()
|
||||||
execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||||
logQuery sql Nothing
|
logQuery sql Nothing
|
||||||
doExecute `catch` \(exception :: Sqlite.SQLError) ->
|
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.
|
-- | Execute one or more semicolon-delimited statements.
|
||||||
--
|
--
|
||||||
-- This function does not support parameters, and is mostly useful for executing DDL and migrations.
|
-- 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
|
executeStatements conn@(Connection _ _ (Sqlite.Connection database)) sql = do
|
||||||
logQuery (Sql sql []) Nothing
|
logQuery (Sql sql []) Nothing
|
||||||
Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) ->
|
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
|
-- 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 =
|
queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
|
||||||
run `catch` \(exception :: Sqlite.SQLError) ->
|
run `catch` \(exception :: Sqlite.SQLError) ->
|
||||||
throwSqliteQueryException
|
throwSqliteQueryException
|
||||||
@ -201,7 +201,7 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
|
|||||||
|
|
||||||
queryStreamCol ::
|
queryStreamCol ::
|
||||||
forall a r.
|
forall a r.
|
||||||
(Sqlite.FromField a) =>
|
(HasCallStack, Sqlite.FromField a) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
(IO (Maybe a) -> IO r) ->
|
(IO (Maybe a) -> IO r) ->
|
||||||
@ -212,7 +212,7 @@ queryStreamCol =
|
|||||||
@(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r)
|
@(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r)
|
||||||
queryStreamRow
|
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
|
queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||||
result <-
|
result <-
|
||||||
doQuery
|
doQuery
|
||||||
@ -237,35 +237,35 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
|||||||
Just row -> loop (row : rows)
|
Just row -> loop (row : rows)
|
||||||
loop []
|
loop []
|
||||||
|
|
||||||
queryListCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a]
|
queryListCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO [a]
|
||||||
queryListCol =
|
queryListCol =
|
||||||
coerce @(Connection -> Sql -> IO [Sqlite.Only a]) @(Connection -> Sql -> IO [a]) queryListRow
|
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 =
|
queryMaybeRow conn s =
|
||||||
queryListRowCheck conn s \case
|
queryListRowCheck conn s \case
|
||||||
[] -> Right Nothing
|
[] -> Right Nothing
|
||||||
[x] -> Right (Just x)
|
[x] -> Right (Just x)
|
||||||
xs -> Left (ExpectedAtMostOneRowException (anythingToString xs))
|
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 =
|
queryMaybeCol conn s =
|
||||||
coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow 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 =
|
queryOneRow conn s =
|
||||||
queryListRowCheck conn s \case
|
queryListRowCheck conn s \case
|
||||||
[x] -> Right x
|
[x] -> Right x
|
||||||
xs -> Left (ExpectedExactlyOneRowException (anythingToString xs))
|
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
|
queryOneCol conn s = do
|
||||||
coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s)
|
coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s)
|
||||||
|
|
||||||
-- With results, with checks
|
-- With results, with checks
|
||||||
|
|
||||||
queryListRowCheck ::
|
queryListRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
([a] -> Either e r) ->
|
([a] -> Either e r) ->
|
||||||
@ -274,7 +274,7 @@ queryListRowCheck conn s check =
|
|||||||
gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check)
|
gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check)
|
||||||
|
|
||||||
gqueryListCheck ::
|
gqueryListCheck ::
|
||||||
(Sqlite.FromRow a) =>
|
(Sqlite.FromRow a, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
([a] -> Either SomeSqliteExceptionReason r) ->
|
([a] -> Either SomeSqliteExceptionReason r) ->
|
||||||
@ -293,7 +293,7 @@ gqueryListCheck conn sql check = do
|
|||||||
|
|
||||||
queryListColCheck ::
|
queryListColCheck ::
|
||||||
forall a e r.
|
forall a e r.
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
([a] -> Either e r) ->
|
([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)
|
queryListRowCheck conn s (coerce @([a] -> Either e r) @([Sqlite.Only a] -> Either e r) check)
|
||||||
|
|
||||||
queryMaybeRowCheck ::
|
queryMaybeRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
@ -315,7 +315,7 @@ queryMaybeRowCheck conn s check =
|
|||||||
|
|
||||||
queryMaybeColCheck ::
|
queryMaybeColCheck ::
|
||||||
forall a e r.
|
forall a e r.
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(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)
|
queryMaybeRowCheck conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check)
|
||||||
|
|
||||||
queryOneRowCheck ::
|
queryOneRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
@ -336,7 +336,7 @@ queryOneRowCheck conn s check =
|
|||||||
|
|
||||||
queryOneColCheck ::
|
queryOneColCheck ::
|
||||||
forall a e r.
|
forall a e r.
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
|
@ -24,7 +24,8 @@ where
|
|||||||
import Control.Concurrent (ThreadId, myThreadId)
|
import Control.Concurrent (ThreadId, myThreadId)
|
||||||
import Data.Typeable (cast)
|
import Data.Typeable (cast)
|
||||||
import Database.SQLite.Simple qualified as Sqlite
|
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.Prelude
|
||||||
import Unison.Sqlite.Connection.Internal (Connection)
|
import Unison.Sqlite.Connection.Internal (Connection)
|
||||||
import Unison.Sqlite.Sql (Sql (..))
|
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
|
-- | 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.
|
-- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
|
||||||
exception :: SomeSqliteExceptionReason,
|
exception :: SomeSqliteExceptionReason,
|
||||||
callStack :: [String],
|
callStack :: CallStack,
|
||||||
connection :: Connection,
|
connection :: Connection,
|
||||||
threadId :: ThreadId
|
threadId :: ThreadId
|
||||||
}
|
}
|
||||||
@ -137,16 +138,15 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo
|
|||||||
exception :: SomeSqliteExceptionReason
|
exception :: SomeSqliteExceptionReason
|
||||||
}
|
}
|
||||||
|
|
||||||
throwSqliteQueryException :: SqliteQueryExceptionInfo -> IO a
|
throwSqliteQueryException :: HasCallStack => SqliteQueryExceptionInfo -> IO a
|
||||||
throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do
|
throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do
|
||||||
threadId <- myThreadId
|
threadId <- myThreadId
|
||||||
callStack <- currentCallStack
|
|
||||||
throwIO
|
throwIO
|
||||||
SqliteQueryException
|
SqliteQueryException
|
||||||
{ sql,
|
{ sql,
|
||||||
params,
|
params,
|
||||||
exception,
|
exception,
|
||||||
callStack,
|
callStack = Stack.callStack,
|
||||||
connection,
|
connection,
|
||||||
threadId
|
threadId
|
||||||
}
|
}
|
||||||
|
@ -88,7 +88,7 @@ instance MonadIO TransactionWithMonadIO where
|
|||||||
coerce @(IO a -> Transaction a) unsafeIO
|
coerce @(IO a -> Transaction a) unsafeIO
|
||||||
|
|
||||||
-- | Run a transaction on the given connection.
|
-- | 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
|
runTransaction conn (Transaction f) = liftIO do
|
||||||
uninterruptibleMask \restore -> do
|
uninterruptibleMask \restore -> do
|
||||||
Connection.begin conn
|
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
|
-- | Run a transaction on the given connection, providing a function that can short-circuit (and roll back) the
|
||||||
-- transaction.
|
-- transaction.
|
||||||
runTransactionWithRollback ::
|
runTransactionWithRollback ::
|
||||||
(MonadIO m) =>
|
(MonadIO m, HasCallStack) =>
|
||||||
Connection ->
|
Connection ->
|
||||||
((forall void. a -> Transaction void) -> Transaction a) ->
|
((forall void. a -> Transaction void) -> Transaction a) ->
|
||||||
m 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
|
-- 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!
|
-- 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 =
|
runReadOnlyTransaction conn f =
|
||||||
withRunInIO \runInIO ->
|
withRunInIO \runInIO ->
|
||||||
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||||
{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
{-# 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
|
runReadOnlyTransaction_ conn action = do
|
||||||
bracketOnError_
|
bracketOnError_
|
||||||
(Connection.begin conn)
|
(Connection.begin conn)
|
||||||
@ -160,7 +160,7 @@ runReadOnlyTransaction_ conn action = do
|
|||||||
-- BEGIN/COMMIT statements.
|
-- BEGIN/COMMIT statements.
|
||||||
--
|
--
|
||||||
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions.
|
-- 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 =
|
runWriteTransaction conn f =
|
||||||
withRunInIO \runInIO ->
|
withRunInIO \runInIO ->
|
||||||
uninterruptibleMask \restore ->
|
uninterruptibleMask \restore ->
|
||||||
@ -170,7 +170,7 @@ runWriteTransaction conn f =
|
|||||||
(runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
(runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||||
{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
{-# 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
|
runWriteTransaction_ restore conn transaction = do
|
||||||
keepTryingToBeginImmediate restore conn
|
keepTryingToBeginImmediate restore conn
|
||||||
result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn)
|
result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn)
|
||||||
@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do
|
|||||||
pure result
|
pure result
|
||||||
|
|
||||||
-- @BEGIN IMMEDIATE@ until success.
|
-- @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 =
|
keepTryingToBeginImmediate restore conn =
|
||||||
let loop =
|
let loop =
|
||||||
try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case
|
try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case
|
||||||
@ -217,7 +217,7 @@ savepoint (Transaction action) = do
|
|||||||
-- transaction needs to retry.
|
-- transaction needs to retry.
|
||||||
--
|
--
|
||||||
-- /Warning/: attempting to run a transaction inside a transaction will cause an exception!
|
-- /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 =
|
unsafeIO action =
|
||||||
Transaction \_ -> action
|
Transaction \_ -> action
|
||||||
|
|
||||||
@ -232,18 +232,18 @@ unsafeUnTransaction (Transaction action) =
|
|||||||
|
|
||||||
-- Without results
|
-- Without results
|
||||||
|
|
||||||
execute :: Sql -> Transaction ()
|
execute :: HasCallStack => Sql -> Transaction ()
|
||||||
execute s =
|
execute s =
|
||||||
Transaction \conn -> Connection.execute conn s
|
Transaction \conn -> Connection.execute conn s
|
||||||
|
|
||||||
executeStatements :: Text -> Transaction ()
|
executeStatements :: HasCallStack => Text -> Transaction ()
|
||||||
executeStatements s =
|
executeStatements s =
|
||||||
Transaction \conn -> Connection.executeStatements conn s
|
Transaction \conn -> Connection.executeStatements conn s
|
||||||
|
|
||||||
-- With results, without checks
|
-- With results, without checks
|
||||||
|
|
||||||
queryStreamRow ::
|
queryStreamRow ::
|
||||||
(Sqlite.FromRow a) =>
|
(Sqlite.FromRow a, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(Transaction (Maybe a) -> Transaction r) ->
|
(Transaction (Maybe a) -> Transaction r) ->
|
||||||
Transaction r
|
Transaction r
|
||||||
@ -254,7 +254,7 @@ queryStreamRow sql callback =
|
|||||||
|
|
||||||
queryStreamCol ::
|
queryStreamCol ::
|
||||||
forall a r.
|
forall a r.
|
||||||
(Sqlite.FromField a) =>
|
(Sqlite.FromField a, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(Transaction (Maybe a) -> Transaction r) ->
|
(Transaction (Maybe a) -> Transaction r) ->
|
||||||
Transaction r
|
Transaction r
|
||||||
@ -264,34 +264,34 @@ queryStreamCol =
|
|||||||
@(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r)
|
@(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r)
|
||||||
queryStreamRow
|
queryStreamRow
|
||||||
|
|
||||||
queryListRow :: (Sqlite.FromRow a) => Sql -> Transaction [a]
|
queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a]
|
||||||
queryListRow s =
|
queryListRow s =
|
||||||
Transaction \conn -> Connection.queryListRow conn s
|
Transaction \conn -> Connection.queryListRow conn s
|
||||||
|
|
||||||
queryListCol :: (Sqlite.FromField a) => Sql -> Transaction [a]
|
queryListCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction [a]
|
||||||
queryListCol s =
|
queryListCol s =
|
||||||
Transaction \conn -> Connection.queryListCol conn 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 =
|
queryMaybeRow s =
|
||||||
Transaction \conn -> Connection.queryMaybeRow conn 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 =
|
queryMaybeCol s =
|
||||||
Transaction \conn -> Connection.queryMaybeCol conn s
|
Transaction \conn -> Connection.queryMaybeCol conn s
|
||||||
|
|
||||||
queryOneRow :: (Sqlite.FromRow a) => Sql -> Transaction a
|
queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction a
|
||||||
queryOneRow s =
|
queryOneRow s =
|
||||||
Transaction \conn -> Connection.queryOneRow conn s
|
Transaction \conn -> Connection.queryOneRow conn s
|
||||||
|
|
||||||
queryOneCol :: (Sqlite.FromField a) => Sql -> Transaction a
|
queryOneCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction a
|
||||||
queryOneCol s =
|
queryOneCol s =
|
||||||
Transaction \conn -> Connection.queryOneCol conn s
|
Transaction \conn -> Connection.queryOneCol conn s
|
||||||
|
|
||||||
-- With results, with parameters, with checks
|
-- With results, with parameters, with checks
|
||||||
|
|
||||||
queryListRowCheck ::
|
queryListRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
([a] -> Either e r) ->
|
([a] -> Either e r) ->
|
||||||
Transaction r
|
Transaction r
|
||||||
@ -299,7 +299,7 @@ queryListRowCheck sql check =
|
|||||||
Transaction \conn -> Connection.queryListRowCheck conn sql check
|
Transaction \conn -> Connection.queryListRowCheck conn sql check
|
||||||
|
|
||||||
queryListColCheck ::
|
queryListColCheck ::
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
([a] -> Either e r) ->
|
([a] -> Either e r) ->
|
||||||
Transaction r
|
Transaction r
|
||||||
@ -307,7 +307,7 @@ queryListColCheck sql check =
|
|||||||
Transaction \conn -> Connection.queryListColCheck conn sql check
|
Transaction \conn -> Connection.queryListColCheck conn sql check
|
||||||
|
|
||||||
queryMaybeRowCheck ::
|
queryMaybeRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
Transaction (Maybe r)
|
Transaction (Maybe r)
|
||||||
@ -315,7 +315,7 @@ queryMaybeRowCheck s check =
|
|||||||
Transaction \conn -> Connection.queryMaybeRowCheck conn s check
|
Transaction \conn -> Connection.queryMaybeRowCheck conn s check
|
||||||
|
|
||||||
queryMaybeColCheck ::
|
queryMaybeColCheck ::
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
Transaction (Maybe r)
|
Transaction (Maybe r)
|
||||||
@ -323,7 +323,7 @@ queryMaybeColCheck s check =
|
|||||||
Transaction \conn -> Connection.queryMaybeColCheck conn s check
|
Transaction \conn -> Connection.queryMaybeColCheck conn s check
|
||||||
|
|
||||||
queryOneRowCheck ::
|
queryOneRowCheck ::
|
||||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
Transaction r
|
Transaction r
|
||||||
@ -331,7 +331,7 @@ queryOneRowCheck s check =
|
|||||||
Transaction \conn -> Connection.queryOneRowCheck conn s check
|
Transaction \conn -> Connection.queryOneRowCheck conn s check
|
||||||
|
|
||||||
queryOneColCheck ::
|
queryOneColCheck ::
|
||||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||||
Sql ->
|
Sql ->
|
||||||
(a -> Either e r) ->
|
(a -> Either e r) ->
|
||||||
Transaction 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
|
module Unison.Codebase
|
||||||
( Codebase,
|
( Codebase,
|
||||||
|
|
||||||
|
-- * UCM session state
|
||||||
|
expectCurrentProjectPath,
|
||||||
|
setCurrentProjectPath,
|
||||||
|
|
||||||
-- * Terms
|
-- * Terms
|
||||||
getTerm,
|
getTerm,
|
||||||
unsafeGetTerm,
|
unsafeGetTerm,
|
||||||
@ -43,18 +47,19 @@ module Unison.Codebase
|
|||||||
lca,
|
lca,
|
||||||
SqliteCodebase.Operations.before,
|
SqliteCodebase.Operations.before,
|
||||||
getShallowBranchAtPath,
|
getShallowBranchAtPath,
|
||||||
|
getMaybeShallowBranchAtPath,
|
||||||
getShallowCausalAtPath,
|
getShallowCausalAtPath,
|
||||||
getBranchAtPath,
|
|
||||||
Operations.expectCausalBranchByCausalHash,
|
Operations.expectCausalBranchByCausalHash,
|
||||||
getShallowCausalFromRoot,
|
getShallowCausalAtPathFromRootHash,
|
||||||
getShallowRootBranch,
|
getShallowProjectBranchRoot,
|
||||||
getShallowRootCausal,
|
expectShallowProjectBranchRoot,
|
||||||
|
getShallowBranchAtProjectPath,
|
||||||
|
getMaybeShallowBranchAtProjectPath,
|
||||||
|
getShallowProjectRootByNames,
|
||||||
|
expectProjectBranchRoot,
|
||||||
|
getBranchAtProjectPath,
|
||||||
|
|
||||||
-- * Root branch
|
-- * Root branch
|
||||||
getRootBranch,
|
|
||||||
SqliteCodebase.Operations.getRootBranchExists,
|
|
||||||
Operations.expectRootCausalHash,
|
|
||||||
putRootBranch,
|
|
||||||
SqliteCodebase.Operations.namesAtPath,
|
SqliteCodebase.Operations.namesAtPath,
|
||||||
|
|
||||||
-- * Patches
|
-- * Patches
|
||||||
@ -103,16 +108,19 @@ module Unison.Codebase
|
|||||||
toCodeLookup,
|
toCodeLookup,
|
||||||
typeLookupForDependencies,
|
typeLookupForDependencies,
|
||||||
unsafeGetComponentLength,
|
unsafeGetComponentLength,
|
||||||
|
SqliteCodebase.Operations.emptyCausalHash,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import U.Codebase.Branch qualified as V2
|
|
||||||
import U.Codebase.Branch qualified as V2Branch
|
import U.Codebase.Branch qualified as V2Branch
|
||||||
import U.Codebase.Causal qualified as V2Causal
|
import U.Codebase.Causal qualified as V2Causal
|
||||||
import U.Codebase.HashTags (CausalHash)
|
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.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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Builtin qualified as Builtin
|
import Unison.Builtin qualified as Builtin
|
||||||
import Unison.Builtin.Terms 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.CodeLookup qualified as CL
|
||||||
import Unison.Codebase.Path
|
import Unison.Codebase.Path
|
||||||
import Unison.Codebase.Path qualified as 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.Conversions qualified as Cv
|
||||||
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
|
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
|
||||||
import Unison.Codebase.Type (Codebase (..))
|
import Unison.Codebase.Type (Codebase (..))
|
||||||
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
|
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
|
||||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||||
|
import Unison.Core.Project (ProjectAndBranch)
|
||||||
import Unison.DataDeclaration (Decl)
|
import Unison.DataDeclaration (Decl)
|
||||||
import Unison.DataDeclaration qualified as DD
|
import Unison.DataDeclaration qualified as DD
|
||||||
import Unison.Hash (Hash)
|
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 (Ann)
|
||||||
import Unison.Parser.Ann qualified as Parser
|
import Unison.Parser.Ann qualified as Parser
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
|
import Unison.Project (ProjectAndBranch (ProjectAndBranch), ProjectBranchName, ProjectName)
|
||||||
import Unison.Reference (Reference, TermReferenceId, TypeReference)
|
import Unison.Reference (Reference, TermReferenceId, TypeReference)
|
||||||
import Unison.Reference qualified as Reference
|
import Unison.Reference qualified as Reference
|
||||||
import Unison.Referent qualified as Referent
|
import Unison.Referent qualified as Referent
|
||||||
@ -164,72 +175,105 @@ runTransactionWithRollback ::
|
|||||||
runTransactionWithRollback Codebase {withConnection} action =
|
runTransactionWithRollback Codebase {withConnection} action =
|
||||||
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
||||||
|
|
||||||
getShallowCausalFromRoot ::
|
getShallowCausalAtPathFromRootHash ::
|
||||||
-- Optional root branch, if Nothing use the codebase's root branch.
|
-- Causal to start at, if Nothing use the codebase's root branch.
|
||||||
Maybe CausalHash ->
|
CausalHash ->
|
||||||
Path.Path ->
|
Path.Path ->
|
||||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
getShallowCausalFromRoot mayRootHash p = do
|
getShallowCausalAtPathFromRootHash rootCausalHash p = do
|
||||||
rootCausal <- case mayRootHash of
|
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
|
||||||
Nothing -> getShallowRootCausal
|
getShallowCausalAtPath p rootCausal
|
||||||
Just ch -> Operations.expectCausalBranchByCausalHash ch
|
|
||||||
getShallowCausalAtPath p (Just rootCausal)
|
|
||||||
|
|
||||||
-- | Get the shallow representation of the root branches without loading the children or
|
|
||||||
-- history.
|
|
||||||
getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
|
||||||
getShallowRootBranch = do
|
|
||||||
getShallowRootCausal >>= V2Causal.value
|
|
||||||
|
|
||||||
-- | Get the shallow representation of the root branches without loading the children or
|
|
||||||
-- history.
|
|
||||||
getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction)
|
|
||||||
getShallowRootCausal = do
|
|
||||||
hash <- Operations.expectRootCausalHash
|
|
||||||
Operations.expectCausalBranchByCausalHash hash
|
|
||||||
|
|
||||||
-- | Recursively descend into causals following the given path,
|
-- | Recursively descend into causals following the given path,
|
||||||
-- Use the root causal if none is provided.
|
-- Use the root causal if none is provided.
|
||||||
getShallowCausalAtPath ::
|
getShallowCausalAtPath ::
|
||||||
Path ->
|
Path ->
|
||||||
Maybe (V2Branch.CausalBranch Sqlite.Transaction) ->
|
(V2Branch.CausalBranch Sqlite.Transaction) ->
|
||||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
getShallowCausalAtPath path mayCausal = do
|
getShallowCausalAtPath path causal = do
|
||||||
causal <- whenNothing mayCausal getShallowRootCausal
|
|
||||||
case path of
|
case path of
|
||||||
Path.Empty -> pure causal
|
Path.Empty -> pure causal
|
||||||
ns Path.:< p -> do
|
ns Path.:< p -> do
|
||||||
b <- V2Causal.value causal
|
b <- V2Causal.value causal
|
||||||
case V2Branch.childAt ns b of
|
case V2Branch.childAt ns b of
|
||||||
Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
|
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,
|
-- | Recursively descend into causals following the given path,
|
||||||
-- Use the root causal if none is provided.
|
-- Use the root causal if none is provided.
|
||||||
getShallowBranchAtPath ::
|
getShallowBranchAtPath ::
|
||||||
Path ->
|
Path ->
|
||||||
Maybe (V2Branch.Branch Sqlite.Transaction) ->
|
V2Branch.Branch Sqlite.Transaction ->
|
||||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||||
getShallowBranchAtPath path mayBranch = do
|
getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch
|
||||||
branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
|
|
||||||
|
-- | Recursively descend into causals following the given path,
|
||||||
|
-- Use the root causal if none is provided.
|
||||||
|
getMaybeShallowBranchAtPath ::
|
||||||
|
Path ->
|
||||||
|
V2Branch.Branch Sqlite.Transaction ->
|
||||||
|
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||||
|
getMaybeShallowBranchAtPath path branch = do
|
||||||
case path of
|
case path of
|
||||||
Path.Empty -> pure branch
|
Path.Empty -> pure $ Just branch
|
||||||
ns Path.:< p -> do
|
ns Path.:< p -> do
|
||||||
case V2Branch.childAt ns branch of
|
case V2Branch.childAt ns branch of
|
||||||
Nothing -> pure V2Branch.empty
|
Nothing -> pure Nothing
|
||||||
Just childCausal -> do
|
Just childCausal -> do
|
||||||
childBranch <- V2Causal.value childCausal
|
childBranch <- V2Causal.value childCausal
|
||||||
getShallowBranchAtPath p (Just childBranch)
|
getMaybeShallowBranchAtPath p childBranch
|
||||||
|
|
||||||
-- | Get a v1 branch from the root following the given path.
|
-- | Recursively descend into causals following the given path,
|
||||||
getBranchAtPath ::
|
-- Use the root causal if none is provided.
|
||||||
|
getShallowBranchAtProjectPath ::
|
||||||
|
PP.ProjectPath ->
|
||||||
|
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||||
|
getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp
|
||||||
|
|
||||||
|
-- | Recursively descend into causals following the given path,
|
||||||
|
-- Use the root causal if none is provided.
|
||||||
|
getMaybeShallowBranchAtProjectPath ::
|
||||||
|
PP.ProjectPath ->
|
||||||
|
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||||
|
getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
|
||||||
|
getShallowProjectBranchRoot projectBranch >>= \case
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
||||||
|
|
||||||
|
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
||||||
|
getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do
|
||||||
|
ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName
|
||||||
|
causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId
|
||||||
|
causalHash <- lift $ Q.expectCausalHash causalHashId
|
||||||
|
lift $ Operations.expectCausalBranchByCausalHash causalHash
|
||||||
|
|
||||||
|
expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m)
|
||||||
|
expectProjectBranchRoot codebase projectId branchId = do
|
||||||
|
causalHash <- runTransaction codebase $ do
|
||||||
|
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||||
|
Q.expectCausalHash causalHashId
|
||||||
|
expectBranchForHash codebase causalHash
|
||||||
|
|
||||||
|
expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||||
|
expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||||
|
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||||
|
causalHash <- Q.expectCausalHash causalHashId
|
||||||
|
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
||||||
|
|
||||||
|
getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||||
|
getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||||
|
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||||
|
causalHash <- Q.expectCausalHash causalHashId
|
||||||
|
Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value
|
||||||
|
|
||||||
|
getBranchAtProjectPath ::
|
||||||
(MonadIO m) =>
|
(MonadIO m) =>
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m (Branch m)
|
m (Maybe (Branch m))
|
||||||
getBranchAtPath codebase path = do
|
getBranchAtProjectPath codebase pp = runMaybeT do
|
||||||
V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing
|
rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId
|
||||||
expectBranchForHash codebase causalHash
|
hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch
|
||||||
|
|
||||||
-- | Like 'getBranchForHash', but for when the hash is known to be in the codebase.
|
-- | Like 'getBranchForHash', but for when the hash is known to be in the codebase.
|
||||||
expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m)
|
expectBranchForHash :: (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.TypeLookup Symbol a -> Reference -> Bool
|
||||||
unseen tl r =
|
unseen tl r =
|
||||||
isNothing
|
isNothing
|
||||||
( Map.lookup r (TL.dataDecls tl) $> ()
|
( Map.lookup r (TL.dataDecls tl)
|
||||||
<|> Map.lookup r (TL.typeOfTerms tl) $> ()
|
$> ()
|
||||||
<|> Map.lookup r (TL.effectDecls tl) $> ()
|
<|> Map.lookup r (TL.typeOfTerms tl)
|
||||||
|
$> ()
|
||||||
|
<|> Map.lookup r (TL.effectDecls tl)
|
||||||
|
$> ()
|
||||||
)
|
)
|
||||||
|
|
||||||
toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
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
|
getTermComponentWithTypes codebase hash <&> \case
|
||||||
Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found"))
|
Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found"))
|
||||||
Just terms -> terms
|
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 (Path)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.HashQualified' (HashQualified (HashQualified, NameOnly))
|
import Unison.HashQualified' (HashQualified (HashQualified, NameOnly))
|
||||||
|
import Unison.NameSegment (NameSegment)
|
||||||
import Unison.Names (Names)
|
import Unison.Names (Names)
|
||||||
import Unison.Names qualified as Names
|
import Unison.Names qualified as Names
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
@ -69,10 +70,10 @@ getBranch (p, seg) b = case Path.toList p of
|
|||||||
(Branch.head <$> Map.lookup h (b ^. Branch.children))
|
(Branch.head <$> Map.lookup h (b ^. Branch.children))
|
||||||
>>= getBranch (Path.fromList p, seg)
|
>>= 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)
|
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)
|
makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name)
|
||||||
|
|
||||||
makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
|
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 :: Path.Split -> (Path, Branch0 m -> Branch0 m)
|
||||||
makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name)
|
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)
|
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)
|
makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name)
|
||||||
|
|
||||||
makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)
|
makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)
|
||||||
|
@ -1,8 +1,5 @@
|
|||||||
module Unison.Codebase.Editor.RemoteRepo where
|
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 (Path)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path =
|
|||||||
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
|
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
|
||||||
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
|
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
|
-- | print remote namespace
|
||||||
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
|
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
|
||||||
printReadRemoteNamespace printProject = \case
|
printReadRemoteNamespace printProject = \case
|
||||||
@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case
|
|||||||
ReadShare'ProjectBranch project -> printProject project
|
ReadShare'ProjectBranch project -> printProject project
|
||||||
|
|
||||||
-- | Render a 'WriteRemoteNamespace' as text.
|
-- | Render a 'WriteRemoteNamespace' as text.
|
||||||
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||||
printWriteRemoteNamespace = \case
|
printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
|
||||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
|
|
||||||
displayShareCodeserver server repo path
|
|
||||||
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
|
|
||||||
|
|
||||||
maybePrintPath :: Path -> Text
|
maybePrintPath :: Path -> Text
|
||||||
maybePrintPath path =
|
maybePrintPath path =
|
||||||
@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} =
|
|||||||
case path of
|
case path of
|
||||||
(segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
|
(segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
|
||||||
_ -> False
|
_ -> 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
|
module Unison.Codebase.Execute where
|
||||||
|
|
||||||
import Control.Exception (finally)
|
import Control.Exception (finally)
|
||||||
import Control.Monad.Except (throwError, runExceptT)
|
import Control.Monad.Except
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import U.Codebase.Sqlite.Project (Project (..))
|
||||||
|
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||||
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Branch.Names qualified as Branch
|
import Unison.Codebase.Branch.Names qualified as Branch
|
||||||
import Unison.Codebase.MainTerm (getMainTerm)
|
import Unison.Codebase.MainTerm (getMainTerm)
|
||||||
import Unison.Codebase.MainTerm qualified as MainTerm
|
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 (Runtime)
|
||||||
import Unison.Codebase.Runtime qualified as Runtime
|
import Unison.Codebase.Runtime qualified as Runtime
|
||||||
import Unison.HashQualified qualified as HQ
|
import Unison.HashQualified qualified as HQ
|
||||||
import Unison.Name (Name)
|
|
||||||
import Unison.Names qualified as Names
|
|
||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnv qualified as PPE
|
import Unison.PrettyPrintEnv qualified as PPE
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||||
@ -27,15 +31,22 @@ import Unison.Util.Pretty qualified as P
|
|||||||
execute ::
|
execute ::
|
||||||
Codebase.Codebase IO Symbol Ann ->
|
Codebase.Codebase IO Symbol Ann ->
|
||||||
Runtime Symbol ->
|
Runtime Symbol ->
|
||||||
HQ.HashQualified Name ->
|
PP.ProjectPathNames ->
|
||||||
IO (Either Runtime.Error ())
|
IO (Either Runtime.Error ())
|
||||||
execute codebase runtime mainName =
|
execute codebase runtime mainPath =
|
||||||
(`finally` Runtime.terminate runtime) . runExceptT $ do
|
(`finally` Runtime.terminate runtime) . runExceptT $ do
|
||||||
root <- liftIO $ Codebase.getRootBranch codebase
|
(project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do
|
||||||
let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
|
project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project))
|
||||||
loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch))
|
||||||
|
pure . Right $ (project, branch)
|
||||||
|
projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId
|
||||||
|
let loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||||
let mainType = Runtime.mainType runtime
|
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
|
case mt of
|
||||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s))
|
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} ()")
|
MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()")
|
||||||
|
@ -5,7 +5,9 @@ module Unison.Codebase.Path
|
|||||||
Path' (..),
|
Path' (..),
|
||||||
Absolute (..),
|
Absolute (..),
|
||||||
pattern AbsolutePath',
|
pattern AbsolutePath',
|
||||||
|
absPath_,
|
||||||
Relative (..),
|
Relative (..),
|
||||||
|
relPath_,
|
||||||
pattern RelativePath',
|
pattern RelativePath',
|
||||||
Resolve (..),
|
Resolve (..),
|
||||||
pattern Empty,
|
pattern Empty,
|
||||||
@ -30,6 +32,8 @@ module Unison.Codebase.Path
|
|||||||
prefixNameIfRel,
|
prefixNameIfRel,
|
||||||
unprefixName,
|
unprefixName,
|
||||||
HQSplit,
|
HQSplit,
|
||||||
|
HQSplitAbsolute,
|
||||||
|
AbsSplit,
|
||||||
Split,
|
Split,
|
||||||
Split',
|
Split',
|
||||||
HQSplit',
|
HQSplit',
|
||||||
@ -58,6 +62,8 @@ module Unison.Codebase.Path
|
|||||||
toName',
|
toName',
|
||||||
toText,
|
toText,
|
||||||
toText',
|
toText',
|
||||||
|
absToText,
|
||||||
|
relToText,
|
||||||
unsplit,
|
unsplit,
|
||||||
unsplit',
|
unsplit',
|
||||||
unsplitAbsolute,
|
unsplitAbsolute,
|
||||||
@ -113,12 +119,19 @@ instance GHC.IsList Path where
|
|||||||
toList (Path segs) = Foldable.toList segs
|
toList (Path segs) = Foldable.toList segs
|
||||||
fromList = Path . Seq.fromList
|
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)
|
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.
|
-- | 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)
|
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.
|
-- | 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}
|
newtype Path' = Path' {unPath' :: Either Absolute Relative}
|
||||||
deriving (Eq, Ord)
|
deriving (Eq, Ord)
|
||||||
@ -148,14 +161,14 @@ absoluteToPath' = AbsolutePath'
|
|||||||
|
|
||||||
instance Show Path' where
|
instance Show Path' where
|
||||||
show = \case
|
show = \case
|
||||||
AbsolutePath' abs -> show abs
|
AbsolutePath' abs -> Text.unpack $ absToText abs
|
||||||
RelativePath' rel -> show rel
|
RelativePath' rel -> Text.unpack $ relToText rel
|
||||||
|
|
||||||
instance Show Absolute where
|
instance Show Absolute where
|
||||||
show s = "." ++ show (unabsolute s)
|
show s = Text.unpack $ absToText s
|
||||||
|
|
||||||
instance Show Relative where
|
instance Show Relative where
|
||||||
show = show . unrelative
|
show = Text.unpack . relToText
|
||||||
|
|
||||||
unsplit' :: Split' -> Path'
|
unsplit' :: Split' -> Path'
|
||||||
unsplit' = \case
|
unsplit' = \case
|
||||||
@ -175,6 +188,8 @@ nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative)
|
|||||||
nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
|
nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
|
||||||
nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
|
nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
|
||||||
|
|
||||||
|
type AbsSplit = (Absolute, NameSegment)
|
||||||
|
|
||||||
type Split = (Path, NameSegment)
|
type Split = (Path, NameSegment)
|
||||||
|
|
||||||
type HQSplit = (Path, HQ'.HQSegment)
|
type HQSplit = (Path, HQ'.HQSegment)
|
||||||
@ -368,11 +383,29 @@ empty = Path mempty
|
|||||||
instance Show Path where
|
instance Show Path where
|
||||||
show = Text.unpack . toText
|
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.
|
-- | Note: This treats the path as relative.
|
||||||
toText :: Path -> Text
|
toText :: Path -> Text
|
||||||
toText =
|
toText =
|
||||||
maybe Text.empty Name.toText . toName
|
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 :: Text -> Path
|
||||||
unsafeParseText = \case
|
unsafeParseText = \case
|
||||||
"" -> empty
|
"" -> empty
|
||||||
@ -509,6 +542,9 @@ instance Resolve Absolute Relative Absolute where
|
|||||||
instance Resolve Absolute Relative Path' where
|
instance Resolve Absolute Relative Path' where
|
||||||
resolve l r = AbsolutePath' (resolve l r)
|
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
|
instance Resolve Path' Path' Path' where
|
||||||
resolve _ a@(AbsolutePath' {}) = a
|
resolve _ a@(AbsolutePath' {}) = a
|
||||||
resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
|
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.IORef
|
||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Time (getCurrentTime)
|
|
||||||
import System.Console.ANSI qualified as ANSI
|
import System.Console.ANSI qualified as ANSI
|
||||||
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
|
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
|
||||||
import U.Codebase.HashTags (CausalHash, PatchHash (..))
|
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.Queries qualified as Q
|
||||||
import U.Codebase.Sqlite.Sync22 qualified as Sync22
|
import U.Codebase.Sqlite.Sync22 qualified as Sync22
|
||||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
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.CreateCodebaseError qualified as Codebase1
|
||||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||||
import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1
|
import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1
|
||||||
import Unison.Codebase.RootBranchCache
|
|
||||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||||
import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
|
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.Migrations qualified as Migrations
|
||||||
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
||||||
import Unison.Codebase.SqliteCodebase.Paths
|
import Unison.Codebase.SqliteCodebase.Paths
|
||||||
@ -106,8 +101,7 @@ createCodebaseOrError onCreate debugName path lockOption action = do
|
|||||||
withConnection (debugName ++ ".createSchema") path \conn -> do
|
withConnection (debugName ++ ".createSchema") path \conn -> do
|
||||||
Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
|
Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
|
||||||
Sqlite.runTransaction conn do
|
Sqlite.runTransaction conn do
|
||||||
Q.createSchema
|
CodebaseOps.createSchema
|
||||||
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
|
|
||||||
onCreate
|
onCreate
|
||||||
|
|
||||||
sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case
|
sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case
|
||||||
@ -136,7 +130,7 @@ initSchemaIfNotExist path = liftIO do
|
|||||||
createDirectoryIfMissing True (makeCodebaseDirPath path)
|
createDirectoryIfMissing True (makeCodebaseDirPath path)
|
||||||
unlessM (doesFileExist $ makeCodebasePath path) $
|
unlessM (doesFileExist $ makeCodebasePath path) $
|
||||||
withConnection "initSchemaIfNotExist" path \conn ->
|
withConnection "initSchemaIfNotExist" path \conn ->
|
||||||
Sqlite.runTransaction conn Q.createSchema
|
Sqlite.runTransaction conn CodebaseOps.createSchema
|
||||||
|
|
||||||
-- 1) buffer up the component
|
-- 1) buffer up the component
|
||||||
-- 2) in the event that the component is complete, then what?
|
-- 2) in the event that the component is complete, then what?
|
||||||
@ -167,7 +161,6 @@ sqliteCodebase ::
|
|||||||
(Codebase m Symbol Ann -> m r) ->
|
(Codebase m Symbol Ann -> m r) ->
|
||||||
m (Either Codebase1.OpenCodebaseError r)
|
m (Either Codebase1.OpenCodebaseError r)
|
||||||
sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do
|
sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do
|
||||||
rootBranchCache <- newEmptyRootBranchCacheIO
|
|
||||||
branchCache <- newBranchCache
|
branchCache <- newBranchCache
|
||||||
getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
|
getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
|
||||||
-- The v1 codebase interface has operations to read and write individual definitions
|
-- The v1 codebase interface has operations to read and write individual definitions
|
||||||
@ -238,37 +231,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
|||||||
putTypeDeclarationComponent =
|
putTypeDeclarationComponent =
|
||||||
CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer
|
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`
|
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||||
-- to one that returns Maybe.
|
-- to one that returns Maybe.
|
||||||
getBranchForHash :: CausalHash -> m (Maybe (Branch m))
|
getBranchForHash :: CausalHash -> m (Maybe (Branch m))
|
||||||
@ -334,8 +296,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
|||||||
putTypeDeclaration,
|
putTypeDeclaration,
|
||||||
putTypeDeclarationComponent,
|
putTypeDeclarationComponent,
|
||||||
getTermComponentWithTypes,
|
getTermComponentWithTypes,
|
||||||
getRootBranch,
|
|
||||||
putRootBranch,
|
|
||||||
getBranchForHash,
|
getBranchForHash,
|
||||||
putBranch,
|
putBranch,
|
||||||
syncFromDirectory,
|
syncFromDirectory,
|
||||||
|
@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase
|
|||||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
|
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
|
||||||
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
|
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
|
||||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12)
|
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.MigrateSchema1To2 (migrateSchema1To2)
|
||||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
|
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
|
||||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6)
|
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.SqliteCodebase.Paths (backupCodebasePath)
|
||||||
import Unison.Codebase.Type (LocalOrRemote (..))
|
import Unison.Codebase.Type (LocalOrRemote (..))
|
||||||
import Unison.ConstructorType qualified as CT
|
import Unison.ConstructorType qualified as CT
|
||||||
|
import Unison.Debug qualified as Debug
|
||||||
import Unison.Hash (Hash)
|
import Unison.Hash (Hash)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Unison.Sqlite.Connection qualified as Sqlite.Connection
|
import Unison.Sqlite.Connection qualified as Sqlite.Connection
|
||||||
import Unison.Util.Monoid (foldMapM)
|
import Unison.Util.Monoid (foldMapM)
|
||||||
import Unison.Util.Monoid qualified as Monoid
|
|
||||||
import Unison.Util.Pretty qualified as Pretty
|
import Unison.Util.Pretty qualified as Pretty
|
||||||
import UnliftIO qualified
|
import UnliftIO qualified
|
||||||
|
|
||||||
-- | Mapping from schema version to the migration required to get there.
|
-- | 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.
|
-- E.g. The migration at index 2 must be run on a codebase at version 1.
|
||||||
migrations ::
|
migrations ::
|
||||||
|
(MVar Region.ConsoleRegion) ->
|
||||||
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
|
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
|
||||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||||
TVar (Map Hash Ops2.TermBufferEntry) ->
|
TVar (Map Hash Ops2.TermBufferEntry) ->
|
||||||
TVar (Map Hash Ops2.DeclBufferEntry) ->
|
TVar (Map Hash Ops2.DeclBufferEntry) ->
|
||||||
CodebasePath ->
|
CodebasePath ->
|
||||||
Map SchemaVersion (Sqlite.Transaction ())
|
Map SchemaVersion (Sqlite.Connection -> IO ())
|
||||||
migrations getDeclType termBuffer declBuffer rootCodebasePath =
|
migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
|
||||||
Map.fromList
|
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
|
-- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this
|
||||||
-- caused an issue:
|
-- 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
|
-- This migration drops all the v1 hash objects to avoid this issue, since these hash objects
|
||||||
-- weren't being used for anything anyways.
|
-- weren't being used for anything anyways.
|
||||||
sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)),
|
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
|
-- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
|
||||||
sqlMigration 5 Q.addTempEntityTables,
|
sqlMigration 5 Q.addTempEntityTables,
|
||||||
(6, migrateSchema5To6 rootCodebasePath),
|
(6, runT $ migrateSchema5To6 rootCodebasePath),
|
||||||
(7, migrateSchema6To7),
|
(7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)),
|
||||||
(8, migrateSchema7To8),
|
(8, runT migrateSchema7To8),
|
||||||
-- Recreates the name lookup tables because the primary key was missing the root hash id.
|
-- Recreates the name lookup tables because the primary key was missing the root hash id.
|
||||||
sqlMigration 9 Q.fixScopedNameLookupTables,
|
sqlMigration 9 Q.fixScopedNameLookupTables,
|
||||||
sqlMigration 10 Q.addProjectTables,
|
sqlMigration 10 Q.addProjectTables,
|
||||||
sqlMigration 11 Q.addMostRecentBranchTable,
|
sqlMigration 11 Q.addMostRecentBranchTable,
|
||||||
(12, migrateSchema11To12),
|
(12, runT migrateSchema11To12),
|
||||||
sqlMigration 13 Q.addMostRecentNamespaceTable,
|
sqlMigration 13 Q.addMostRecentNamespaceTable,
|
||||||
sqlMigration 14 Q.addSquashResultTable,
|
sqlMigration 14 Q.addSquashResultTable,
|
||||||
sqlMigration 15 Q.addSquashResultTableIfNotExists,
|
sqlMigration 15 Q.addSquashResultTableIfNotExists,
|
||||||
sqlMigration 16 Q.cdToProjectRoot
|
sqlMigration 16 Q.cdToProjectRoot,
|
||||||
|
(17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn)
|
||||||
]
|
]
|
||||||
where
|
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 =
|
sqlMigration ver migration =
|
||||||
( ver,
|
( ver,
|
||||||
do
|
\conn -> Sqlite.runWriteTransaction conn \run -> run
|
||||||
Q.expectSchemaVersion (ver - 1)
|
do
|
||||||
migration
|
Q.expectSchemaVersion (ver - 1)
|
||||||
Q.setSchemaVersion ver
|
migration
|
||||||
|
Q.setSchemaVersion ver
|
||||||
)
|
)
|
||||||
|
|
||||||
data CodebaseVersionStatus
|
data CodebaseVersionStatus
|
||||||
@ -140,7 +146,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
|||||||
|
|
||||||
Region.displayConsoleRegions do
|
Region.displayConsoleRegions do
|
||||||
(`UnliftIO.finally` finalizeRegion) 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.
|
-- The highest schema that this ucm knows how to migrate to.
|
||||||
let highestKnownSchemaVersion = fst . head $ Map.toDescList migs
|
let highestKnownSchemaVersion = fst . head $ Map.toDescList migs
|
||||||
currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion
|
currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion
|
||||||
@ -149,11 +155,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
|||||||
when shouldPrompt do
|
when shouldPrompt do
|
||||||
putStrLn "Press <enter> to start the migration once all other ucm processes are shutdown..."
|
putStrLn "Press <enter> to start the migration once all other ucm processes are shutdown..."
|
||||||
void $ liftIO getLine
|
void $ liftIO getLine
|
||||||
ranMigrations <-
|
ranMigrations <- do
|
||||||
Sqlite.runWriteTransaction conn \run -> do
|
currentSchemaVersion <- Sqlite.runTransaction conn $ do
|
||||||
-- Get the schema version again now that we're in a transaction.
|
-- Get the schema version again now that we're in a transaction.
|
||||||
currentSchemaVersion <- run Q.schemaVersion
|
Q.schemaVersion
|
||||||
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
|
||||||
-- This is a bit of a hack, hopefully we can remove this when we have a more
|
-- 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.
|
-- reliable way to freeze old migration code in time.
|
||||||
-- The problem is that 'saveObject' has been changed to flush temp entity tables,
|
-- 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
|
-- Hopefully we can remove this once we've got better methods of freezing migration
|
||||||
-- code in time.
|
-- code in time.
|
||||||
when (currentSchemaVersion < 5) $ run Q.addTempEntityTables
|
when (currentSchemaVersion < 5) Q.addTempEntityTables
|
||||||
when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables
|
when (currentSchemaVersion < 6) Q.addNamespaceStatsTables
|
||||||
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
pure currentSchemaVersion
|
||||||
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
||||||
run migration
|
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
||||||
let ranMigrations = not (null migrationsToRun)
|
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
||||||
when ranMigrations do
|
migration conn
|
||||||
region <-
|
let ranMigrations = not (null migrationsToRun)
|
||||||
UnliftIO.mask_ do
|
pure ranMigrations
|
||||||
region <- Region.openConsoleRegion Region.Linear
|
Debug.debugLogM Debug.Migration "Migrations complete"
|
||||||
putMVar regionVar region
|
|
||||||
pure region
|
|
||||||
result <- do
|
|
||||||
-- Ideally we'd check everything here, but certain codebases are known to have objects
|
|
||||||
-- with missing Hash Objects, we'll want to clean that up in a future migration.
|
|
||||||
-- integrityCheckAllHashObjects,
|
|
||||||
let checks =
|
|
||||||
Monoid.whenM
|
|
||||||
(currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked
|
|
||||||
[ integrityCheckAllBranches,
|
|
||||||
integrityCheckAllCausals
|
|
||||||
]
|
|
||||||
|
|
||||||
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
|
|
||||||
Region.setConsoleRegion
|
|
||||||
region
|
|
||||||
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
|
|
||||||
run check
|
|
||||||
case result of
|
|
||||||
NoIntegrityErrors -> pure ()
|
|
||||||
IntegrityErrorDetected errs -> do
|
|
||||||
let msg = prettyPrintIntegrityErrors errs
|
|
||||||
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
|
|
||||||
Region.setConsoleRegion region (Text.pack rendered)
|
|
||||||
run (abortMigration "Codebase integrity error detected.")
|
|
||||||
pure ranMigrations
|
|
||||||
when ranMigrations do
|
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.
|
-- Vacuum once now that any migrations have taken place.
|
||||||
Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text)
|
Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text)
|
||||||
case vacuumStrategy of
|
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 ()
|
NoVacuum -> pure ()
|
||||||
Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text)
|
Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text)
|
||||||
|
|
||||||
@ -224,3 +210,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion
|
|||||||
Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL
|
Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL
|
||||||
putStrLn ("📋 I backed up your codebase to " ++ (root </> backupPath))
|
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."
|
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 ApplicativeDo #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
|
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 "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones."
|
||||||
|
|
||||||
log "Updating Namespace Root..."
|
log "Updating Namespace Root..."
|
||||||
rootCausalHashId <- Q.expectNamespaceRoot
|
rootCausalHashId <- expectNamespaceRoot
|
||||||
numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches]
|
numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches]
|
||||||
v2EmptyBranchHashInfo <- saveV2EmptyBranch
|
v2EmptyBranchHashInfo <- saveV2EmptyBranch
|
||||||
watches <-
|
watches <-
|
||||||
@ -115,7 +116,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
|
|||||||
`execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo
|
`execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo
|
||||||
let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId
|
let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId
|
||||||
log "Updating Namespace Root..."
|
log "Updating Namespace Root..."
|
||||||
Q.setNamespaceRoot newRootCausalHashId
|
setNamespaceRoot newRootCausalHashId
|
||||||
log "Rewriting old object IDs..."
|
log "Rewriting old object IDs..."
|
||||||
ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do
|
ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do
|
||||||
Q.recordObjectRehash oldObjId newObjId
|
Q.recordObjectRehash oldObjId newObjId
|
||||||
@ -149,6 +150,23 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
|
|||||||
allDone = lift $ log $ "\nFinished migrating, initiating cleanup."
|
allDone = lift $ log $ "\nFinished migrating, initiating cleanup."
|
||||||
in Sync.Progress {need, done, error = errorHandler, allDone}
|
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 :: String -> Sqlite.Transaction ()
|
||||||
log =
|
log =
|
||||||
Sqlite.unsafeIO . putStrLn
|
Sqlite.unsafeIO . putStrLn
|
||||||
|
@ -81,7 +81,7 @@ numMigrated =
|
|||||||
migrateSchema3To4 :: Sqlite.Transaction ()
|
migrateSchema3To4 :: Sqlite.Transaction ()
|
||||||
migrateSchema3To4 = do
|
migrateSchema3To4 = do
|
||||||
Q.expectSchemaVersion 3
|
Q.expectSchemaVersion 3
|
||||||
rootCausalHashId <- Q.expectNamespaceRoot
|
rootCausalHashId <- expectNamespaceRoot
|
||||||
totalCausals <- causalCount
|
totalCausals <- causalCount
|
||||||
migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId]
|
migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId]
|
||||||
let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState
|
let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState
|
||||||
@ -98,6 +98,17 @@ migrateSchema3To4 = do
|
|||||||
SELECT count(*) FROM causal;
|
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 :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId
|
||||||
migrationProgress totalCausals =
|
migrationProgress totalCausals =
|
||||||
Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone}
|
Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone}
|
||||||
|
@ -1,4 +1,6 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
|
-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
|
||||||
-- monad.
|
-- monad.
|
||||||
@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
|
|||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
|
import Data.UUID.V4 qualified as UUID
|
||||||
import U.Codebase.Branch qualified as V2Branch
|
import U.Codebase.Branch qualified as V2Branch
|
||||||
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
|
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
|
||||||
import U.Codebase.Branch.Diff qualified as BranchDiff
|
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.ObjectType qualified as OT
|
||||||
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
|
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
|
||||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
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.ProjectBranch (ProjectBranch (..))
|
||||||
import U.Codebase.Sqlite.Queries qualified as Q
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||||
import Unison.Builtin qualified as Builtins
|
import Unison.Builtin qualified as Builtins
|
||||||
import Unison.Codebase.Branch (Branch (..))
|
import Unison.Codebase.Branch (Branch (..))
|
||||||
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Patch (Patch)
|
import Unison.Codebase.Patch (Patch)
|
||||||
import Unison.Codebase.Path (Path)
|
import Unison.Codebase.Path (Path)
|
||||||
import Unison.Codebase.Path qualified as 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.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||||
import Unison.ConstructorReference (GConstructorReference (..))
|
import Unison.ConstructorReference (GConstructorReference (..))
|
||||||
import Unison.ConstructorType qualified as CT
|
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 (Decl)
|
||||||
import Unison.DataDeclaration qualified as Decl
|
import Unison.DataDeclaration qualified as Decl
|
||||||
import Unison.Hash (Hash)
|
import Unison.Hash (Hash)
|
||||||
@ -74,6 +80,35 @@ import Unison.Util.Set qualified as Set
|
|||||||
import Unison.WatchKind qualified as UF
|
import Unison.WatchKind qualified as UF
|
||||||
import UnliftIO.STM
|
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
|
-- Buffer entry
|
||||||
|
|
||||||
@ -382,25 +417,6 @@ tryFlushDeclBuffer termBuffer declBuffer =
|
|||||||
h
|
h
|
||||||
in loop
|
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`
|
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||||
-- to one that returns Maybe.
|
-- to one that returns Maybe.
|
||||||
getBranchForHash ::
|
getBranchForHash ::
|
||||||
@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do
|
|||||||
conn <- Sqlite.unsafeGetConnection
|
conn <- Sqlite.unsafeGetConnection
|
||||||
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||||
|
|
||||||
insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project.
|
||||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch)
|
||||||
Q.insertProject projectId projectName
|
insertProjectAndBranch projectName branchName chId = do
|
||||||
|
projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do
|
||||||
|
projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom)
|
||||||
|
Q.insertProject projectId projectName
|
||||||
|
pure projectId
|
||||||
|
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
||||||
|
let projectBranch =
|
||||||
|
ProjectBranch
|
||||||
|
{ projectId,
|
||||||
|
branchId,
|
||||||
|
name = branchName,
|
||||||
|
parentBranchId = Nothing
|
||||||
|
}
|
||||||
Q.insertProjectBranch
|
Q.insertProjectBranch
|
||||||
ProjectBranch
|
"Project Created"
|
||||||
{ projectId,
|
chId
|
||||||
branchId,
|
projectBranch
|
||||||
name = branchName,
|
|
||||||
parentBranchId = Nothing
|
|
||||||
}
|
|
||||||
Q.setMostRecentBranch projectId branchId
|
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 (),
|
putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
|
||||||
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
|
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
|
||||||
getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type 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)),
|
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
|
-- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't
|
||||||
-- already exist.
|
-- 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.Decl qualified as Codebase.Decl
|
||||||
import U.Codebase.Reference qualified as Codebase.Reference
|
import U.Codebase.Reference qualified as Codebase.Reference
|
||||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||||
|
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Sqlite qualified as Sqlite
|
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
|
-- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed
|
||||||
-- by a cache.
|
-- by a cache.
|
||||||
loadUniqueTypeGuid ::
|
loadUniqueTypeGuid ::
|
||||||
([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
(ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
||||||
[NameSegment] ->
|
ProjectPath ->
|
||||||
NameSegment ->
|
NameSegment ->
|
||||||
Sqlite.Transaction (Maybe Text)
|
Sqlite.Transaction (Maybe Text)
|
||||||
loadUniqueTypeGuid loadNamespaceAtPath path name =
|
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.Patch
|
||||||
Unison.Codebase.Path
|
Unison.Codebase.Path
|
||||||
Unison.Codebase.Path.Parse
|
Unison.Codebase.Path.Parse
|
||||||
|
Unison.Codebase.ProjectPath
|
||||||
Unison.Codebase.PushBehavior
|
Unison.Codebase.PushBehavior
|
||||||
Unison.Codebase.RootBranchCache
|
|
||||||
Unison.Codebase.Runtime
|
Unison.Codebase.Runtime
|
||||||
Unison.Codebase.Serialization
|
Unison.Codebase.Serialization
|
||||||
Unison.Codebase.ShortCausalHash
|
Unison.Codebase.ShortCausalHash
|
||||||
@ -72,6 +72,7 @@ library
|
|||||||
Unison.Codebase.SqliteCodebase.Migrations
|
Unison.Codebase.SqliteCodebase.Migrations
|
||||||
Unison.Codebase.SqliteCodebase.Migrations.Helpers
|
Unison.Codebase.SqliteCodebase.Migrations.Helpers
|
||||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
|
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
|
||||||
|
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17
|
||||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
|
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
|
||||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
|
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
|
||||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4
|
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4
|
||||||
@ -131,7 +132,6 @@ library
|
|||||||
Unison.PrettyPrintEnvDecl.Names
|
Unison.PrettyPrintEnvDecl.Names
|
||||||
Unison.PrettyPrintEnvDecl.Sqlite
|
Unison.PrettyPrintEnvDecl.Sqlite
|
||||||
Unison.PrintError
|
Unison.PrintError
|
||||||
Unison.Project.Util
|
|
||||||
Unison.Result
|
Unison.Result
|
||||||
Unison.Runtime.ANF
|
Unison.Runtime.ANF
|
||||||
Unison.Runtime.ANF.Rehash
|
Unison.Runtime.ANF.Rehash
|
||||||
|
@ -52,14 +52,19 @@ import Options.Applicative.Help (bold, (<+>))
|
|||||||
import Options.Applicative.Help.Pretty qualified as P
|
import Options.Applicative.Help.Pretty qualified as P
|
||||||
import Stats
|
import Stats
|
||||||
import System.Environment (lookupEnv)
|
import System.Environment (lookupEnv)
|
||||||
|
import Text.Megaparsec qualified as Megaparsec
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Codebase.Path.Parse 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.CommandLine.Types (ShouldWatchFiles (..))
|
||||||
|
import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||||
import Unison.HashQualified (HashQualified)
|
import Unison.HashQualified (HashQualified)
|
||||||
import Unison.LSP (LspFormattingConfig (..))
|
import Unison.LSP (LspFormattingConfig (..))
|
||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyTerminal qualified as PT
|
import Unison.PrettyTerminal qualified as PT
|
||||||
|
import Unison.Project qualified as Project
|
||||||
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
||||||
import Unison.Server.CodebaseServer qualified as Server
|
import Unison.Server.CodebaseServer qualified as Server
|
||||||
import Unison.Syntax.HashQualified qualified as HQ
|
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
|
-- | Valid ways to provide source code to the run command
|
||||||
data RunSource
|
data RunSource
|
||||||
= RunFromPipe (HashQualified Name)
|
= RunFromPipe (HashQualified Name)
|
||||||
| RunFromSymbol (HashQualified Name)
|
| RunFromSymbol ProjectPathNames
|
||||||
| RunFromFile FilePath (HashQualified Name)
|
| RunFromFile FilePath (HashQualified Name)
|
||||||
| RunCompiled FilePath
|
| RunCompiled FilePath
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
@ -102,8 +107,8 @@ data Command
|
|||||||
= Launch
|
= Launch
|
||||||
IsHeadless
|
IsHeadless
|
||||||
CodebaseServerOpts
|
CodebaseServerOpts
|
||||||
-- Starting path
|
-- Starting project
|
||||||
(Maybe Path.Absolute)
|
(Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||||
ShouldWatchFiles
|
ShouldWatchFiles
|
||||||
| PrintVersion
|
| PrintVersion
|
||||||
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
|
| -- @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
|
launchParser envOpts isHeadless = do
|
||||||
-- ApplicativeDo
|
-- ApplicativeDo
|
||||||
codebaseServerOpts <- codebaseServerOptsParser envOpts
|
codebaseServerOpts <- codebaseServerOptsParser envOpts
|
||||||
startingPath <- startingPathOption
|
startingProject <- startingProjectOption
|
||||||
shouldWatchFiles <- noFileWatchFlag
|
shouldWatchFiles <- noFileWatchFlag
|
||||||
pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles)
|
pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles)
|
||||||
|
|
||||||
initParser :: Parser Command
|
initParser :: Parser Command
|
||||||
initParser = pure Init
|
initParser = pure Init
|
||||||
@ -374,9 +379,13 @@ runHQParser :: Parser (HashQualified Name)
|
|||||||
runHQParser =
|
runHQParser =
|
||||||
argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL")
|
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 :: Parser Command
|
||||||
runSymbolParser =
|
runSymbolParser =
|
||||||
Run . RunFromSymbol <$> runHQParser <*> runArgumentParser
|
Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser
|
||||||
|
|
||||||
runFileParser :: Parser Command
|
runFileParser :: Parser Command
|
||||||
runFileParser =
|
runFileParser =
|
||||||
@ -422,15 +431,15 @@ saveCodebaseToFlag = do
|
|||||||
_ -> DontSaveCodebase
|
_ -> DontSaveCodebase
|
||||||
)
|
)
|
||||||
|
|
||||||
startingPathOption :: Parser (Maybe Path.Absolute)
|
startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||||
startingPathOption =
|
startingProjectOption =
|
||||||
let meta =
|
let meta =
|
||||||
metavar ".path.in.codebase"
|
metavar "project/branch"
|
||||||
<> long "path"
|
<> long "project"
|
||||||
<> short 'p'
|
<> short 'p'
|
||||||
<> help "Launch the UCM session at the provided path location."
|
<> help "Launch the UCM session at the provided project and branch."
|
||||||
<> noGlobal
|
<> noGlobal
|
||||||
in optional $ option readAbsolutePath meta
|
in optional (option readProjectAndBranchNames meta)
|
||||||
|
|
||||||
noFileWatchFlag :: Parser ShouldWatchFiles
|
noFileWatchFlag :: Parser ShouldWatchFiles
|
||||||
noFileWatchFlag =
|
noFileWatchFlag =
|
||||||
@ -469,6 +478,13 @@ readPath' = do
|
|||||||
Left err -> OptParse.readerError (Text.unpack err)
|
Left err -> OptParse.readerError (Text.unpack err)
|
||||||
Right path' -> pure path'
|
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 :: String -> Parser FilePath
|
||||||
fileArgument varName =
|
fileArgument varName =
|
||||||
strArgument
|
strArgument
|
||||||
|
@ -14,6 +14,7 @@ module Unison.Cli.Monad
|
|||||||
-- * Immutable state
|
-- * Immutable state
|
||||||
LoopState (..),
|
LoopState (..),
|
||||||
loopState0,
|
loopState0,
|
||||||
|
getProjectPathIds,
|
||||||
|
|
||||||
-- * Lifting IO actions
|
-- * Lifting IO actions
|
||||||
ioE,
|
ioE,
|
||||||
@ -33,6 +34,7 @@ module Unison.Cli.Monad
|
|||||||
-- * Changing the current directory
|
-- * Changing the current directory
|
||||||
cd,
|
cd,
|
||||||
popd,
|
popd,
|
||||||
|
switchProject,
|
||||||
|
|
||||||
-- * Communicating output to the user
|
-- * Communicating output to the user
|
||||||
respond,
|
respond,
|
||||||
@ -46,28 +48,32 @@ module Unison.Cli.Monad
|
|||||||
runTransaction,
|
runTransaction,
|
||||||
runTransactionWithRollback,
|
runTransactionWithRollback,
|
||||||
|
|
||||||
|
-- * Internal
|
||||||
|
setMostRecentProjectPath,
|
||||||
|
setInMemoryCurrentProjectRoot,
|
||||||
|
|
||||||
-- * Misc types
|
-- * Misc types
|
||||||
LoadSourceResult (..),
|
LoadSourceResult (..),
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Exception (throwIO)
|
import Control.Exception (throwIO)
|
||||||
import Control.Lens (lens, (.=))
|
import Control.Lens
|
||||||
import Control.Monad.Reader (MonadReader (..))
|
import Control.Monad.Reader (MonadReader (..))
|
||||||
import Control.Monad.State.Strict (MonadState)
|
import Control.Monad.State.Strict (MonadState)
|
||||||
import Control.Monad.State.Strict qualified as State
|
import Control.Monad.State.Strict qualified as State
|
||||||
import Data.Configurator.Types qualified as Configurator
|
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 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 (DiffTime, diffTimeToPicoseconds)
|
||||||
import Data.Time.Clock.System (getSystemTime, systemToTAITime)
|
import Data.Time.Clock.System (getSystemTime, systemToTAITime)
|
||||||
import Data.Time.Clock.TAI (diffAbsoluteTime)
|
import Data.Time.Clock.TAI (diffAbsoluteTime)
|
||||||
import Data.Unique (Unique, newUnique)
|
import Data.Unique (Unique, newUnique)
|
||||||
import GHC.OverloadedLabels (IsLabel (..))
|
|
||||||
import System.CPUTime (getCPUTime)
|
import System.CPUTime (getCPUTime)
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
import U.Codebase.HashTags (CausalHash)
|
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import Unison.Auth.CredentialManager (CredentialManager)
|
import Unison.Auth.CredentialManager (CredentialManager)
|
||||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||||
import Unison.Codebase (Codebase)
|
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.Output (NumberedArgs, NumberedOutput, Output)
|
||||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.Runtime (Runtime)
|
import Unison.Codebase.Runtime (Runtime)
|
||||||
|
import Unison.Core.Project (ProjectAndBranch (..))
|
||||||
import Unison.Debug qualified as Debug
|
import Unison.Debug qualified as Debug
|
||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
@ -178,10 +186,9 @@ data Env = Env
|
|||||||
--
|
--
|
||||||
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
|
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
|
||||||
data LoopState = LoopState
|
data LoopState = LoopState
|
||||||
{ root :: TMVar (Branch IO),
|
{ currentProjectRoot :: TMVar (Branch IO),
|
||||||
lastSavedRootHash :: CausalHash,
|
-- the current position in the codebase, with the head being the most recent lcoation.
|
||||||
-- the current position in the namespace
|
projectPathStack :: List.NonEmpty PP.ProjectPathIds,
|
||||||
currentPathStack :: List.NonEmpty Path.Absolute,
|
|
||||||
-- TBD
|
-- TBD
|
||||||
-- , _activeEdits :: Set Branch.EditGuid
|
-- , _activeEdits :: Set Branch.EditGuid
|
||||||
|
|
||||||
@ -206,26 +213,12 @@ data LoopState = LoopState
|
|||||||
}
|
}
|
||||||
deriving stock (Generic)
|
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.
|
-- | Create an initial loop state given a root branch and the current path.
|
||||||
loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
|
loopState0 :: TMVar (Branch IO) -> PP.ProjectPathIds -> LoopState
|
||||||
loopState0 lastSavedRootHash b p = do
|
loopState0 b p = do
|
||||||
LoopState
|
LoopState
|
||||||
{ root = b,
|
{ currentProjectRoot = b,
|
||||||
lastSavedRootHash = lastSavedRootHash,
|
projectPathStack = pure p,
|
||||||
currentPathStack = pure p,
|
|
||||||
latestFile = Nothing,
|
latestFile = Nothing,
|
||||||
latestTypecheckedFile = Nothing,
|
latestTypecheckedFile = Nothing,
|
||||||
lastInput = Nothing,
|
lastInput = Nothing,
|
||||||
@ -387,11 +380,33 @@ time label action =
|
|||||||
ms = ns / 1_000_000
|
ms = ns / 1_000_000
|
||||||
s = ns / 1_000_000_000
|
s = ns / 1_000_000_000
|
||||||
|
|
||||||
|
getProjectPathIds :: Cli PP.ProjectPathIds
|
||||||
|
getProjectPathIds = do
|
||||||
|
NonEmpty.head <$> use #projectPathStack
|
||||||
|
|
||||||
cd :: Path.Absolute -> Cli ()
|
cd :: Path.Absolute -> Cli ()
|
||||||
cd path = do
|
cd path = do
|
||||||
setMostRecentNamespace path
|
pp <- getProjectPathIds
|
||||||
State.modify' \state ->
|
let newPP = pp & PP.absPath_ .~ path
|
||||||
state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)}
|
setMostRecentProjectPath newPP
|
||||||
|
#projectPathStack %= NonEmpty.cons newPP
|
||||||
|
|
||||||
|
-- | Set the in-memory project root to the given branch, without updating the database.
|
||||||
|
setInMemoryCurrentProjectRoot :: Branch IO -> Cli ()
|
||||||
|
setInMemoryCurrentProjectRoot !newRoot = do
|
||||||
|
rootVar <- use #currentProjectRoot
|
||||||
|
atomically do
|
||||||
|
void $ swapTMVar rootVar newRoot
|
||||||
|
|
||||||
|
switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
|
||||||
|
switchProject (ProjectAndBranch projectId branchId) = do
|
||||||
|
Env {codebase} <- ask
|
||||||
|
let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty
|
||||||
|
#projectPathStack %= NonEmpty.cons newPP
|
||||||
|
runTransaction $ do Q.setMostRecentBranch projectId branchId
|
||||||
|
pbr <- liftIO $ Codebase.expectProjectBranchRoot codebase projectId branchId
|
||||||
|
setInMemoryCurrentProjectRoot pbr
|
||||||
|
setMostRecentProjectPath newPP
|
||||||
|
|
||||||
-- | Pop the latest path off the stack, if it's not the only path in the stack.
|
-- | 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 :: Cli Bool
|
||||||
popd = do
|
popd = do
|
||||||
state <- State.get
|
state <- State.get
|
||||||
case List.NonEmpty.uncons (currentPathStack state) of
|
case List.NonEmpty.uncons (projectPathStack state) of
|
||||||
(_, Nothing) -> pure False
|
(_, Nothing) -> pure False
|
||||||
(_, Just paths) -> do
|
(_, Just paths) -> do
|
||||||
setMostRecentNamespace (List.NonEmpty.head paths)
|
setMostRecentProjectPath (List.NonEmpty.head paths)
|
||||||
State.put state {currentPathStack = paths}
|
State.put state {projectPathStack = paths}
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
setMostRecentNamespace :: Path.Absolute -> Cli ()
|
setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
|
||||||
setMostRecentNamespace =
|
setMostRecentProjectPath loc =
|
||||||
runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute
|
runTransaction $ Codebase.setCurrentProjectPath loc
|
||||||
|
|
||||||
respond :: Output -> Cli ()
|
respond :: Output -> Cli ()
|
||||||
respond output = do
|
respond output = do
|
||||||
|
@ -6,10 +6,18 @@ module Unison.Cli.MonadUtils
|
|||||||
|
|
||||||
-- * Paths
|
-- * Paths
|
||||||
getCurrentPath,
|
getCurrentPath,
|
||||||
|
getCurrentProjectName,
|
||||||
|
getCurrentProjectBranchName,
|
||||||
|
getCurrentProjectPath,
|
||||||
resolvePath,
|
resolvePath,
|
||||||
resolvePath',
|
resolvePath',
|
||||||
|
resolvePath'ToAbsolute,
|
||||||
resolveSplit',
|
resolveSplit',
|
||||||
|
|
||||||
|
-- * Project and branch resolution
|
||||||
|
getCurrentProjectAndBranch,
|
||||||
|
getCurrentProjectBranch,
|
||||||
|
|
||||||
-- * Branches
|
-- * Branches
|
||||||
|
|
||||||
-- ** Resolving branch identifiers
|
-- ** Resolving branch identifiers
|
||||||
@ -20,18 +28,15 @@ module Unison.Cli.MonadUtils
|
|||||||
resolveShortCausalHash,
|
resolveShortCausalHash,
|
||||||
|
|
||||||
-- ** Getting/setting branches
|
-- ** Getting/setting branches
|
||||||
getRootBranch,
|
getCurrentProjectRoot,
|
||||||
setRootBranch,
|
getCurrentProjectRoot0,
|
||||||
modifyRootBranch,
|
|
||||||
getRootBranch0,
|
|
||||||
getCurrentBranch,
|
getCurrentBranch,
|
||||||
getCurrentBranch0,
|
getCurrentBranch0,
|
||||||
getBranchAt,
|
getProjectBranchRoot,
|
||||||
getBranch0At,
|
getBranchFromProjectPath,
|
||||||
getLastSavedRootHash,
|
getBranch0FromProjectPath,
|
||||||
setLastSavedRootHash,
|
getMaybeBranchFromProjectPath,
|
||||||
getMaybeBranchAt,
|
getMaybeBranch0FromProjectPath,
|
||||||
getMaybeBranch0At,
|
|
||||||
expectBranchAtPath,
|
expectBranchAtPath,
|
||||||
expectBranchAtPath',
|
expectBranchAtPath',
|
||||||
expectBranch0AtPath,
|
expectBranch0AtPath,
|
||||||
@ -43,13 +48,10 @@ module Unison.Cli.MonadUtils
|
|||||||
stepAt',
|
stepAt',
|
||||||
stepAt,
|
stepAt,
|
||||||
stepAtM,
|
stepAtM,
|
||||||
stepAtNoSync',
|
|
||||||
stepAtNoSync,
|
|
||||||
stepManyAt,
|
stepManyAt,
|
||||||
stepManyAtMNoSync,
|
stepManyAtM,
|
||||||
stepManyAtNoSync,
|
updateProjectBranchRoot,
|
||||||
syncRoot,
|
updateProjectBranchRoot_,
|
||||||
updateRoot,
|
|
||||||
updateAtM,
|
updateAtM,
|
||||||
updateAt,
|
updateAt,
|
||||||
updateAndStepAt,
|
updateAndStepAt,
|
||||||
@ -91,6 +93,9 @@ import U.Codebase.Branch qualified as V2 (Branch)
|
|||||||
import U.Codebase.Branch qualified as V2Branch
|
import U.Codebase.Branch qualified as V2Branch
|
||||||
import U.Codebase.Causal qualified as V2Causal
|
import U.Codebase.Causal qualified as V2Causal
|
||||||
import U.Codebase.HashTags (CausalHash (..))
|
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 (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Codebase qualified as Codebase
|
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.Patch qualified as Patch
|
||||||
import Unison.Codebase.Path (Path, Path' (..))
|
import Unison.Codebase.Path (Path, Path' (..))
|
||||||
import Unison.Codebase.Path qualified as 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 (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
import Unison.HashQualified qualified as HQ
|
import Unison.HashQualified qualified as HQ
|
||||||
@ -112,6 +119,7 @@ import Unison.NameSegment qualified as NameSegment
|
|||||||
import Unison.Names (Names)
|
import Unison.Names (Names)
|
||||||
import Unison.Parser.Ann (Ann (..))
|
import Unison.Parser.Ann (Ann (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||||
import Unison.Reference (TypeReference)
|
import Unison.Reference (TypeReference)
|
||||||
import Unison.Referent (Referent)
|
import Unison.Referent (Referent)
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
@ -137,25 +145,55 @@ getConfig key = do
|
|||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Getting paths, path resolution, etc.
|
-- 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 :: Cli Path.Absolute
|
||||||
getCurrentPath = do
|
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.
|
-- | 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
|
resolvePath path = do
|
||||||
currentPath <- getCurrentPath
|
pp <- getCurrentProjectPath
|
||||||
pure (Path.resolve currentPath (Path.Relative path))
|
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path
|
||||||
|
|
||||||
-- | Resolve a @Path'@ to a @Path.Absolute@, per the current path.
|
-- | Resolve a @Path'@ to a @Path.Absolute@, per the current path.
|
||||||
resolvePath' :: Path' -> Cli Path.Absolute
|
resolvePath' :: Path' -> Cli PP.ProjectPath
|
||||||
resolvePath' path = do
|
resolvePath' path' = do
|
||||||
currentPath <- getCurrentPath
|
pp <- getCurrentProjectPath
|
||||||
pure (Path.resolve currentPath path)
|
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path'
|
||||||
|
|
||||||
|
resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute
|
||||||
|
resolvePath'ToAbsolute path' = do
|
||||||
|
view PP.absPath_ <$> resolvePath' path'
|
||||||
|
|
||||||
-- | Resolve a path split, per the current path.
|
-- | Resolve a path split, per the current path.
|
||||||
resolveSplit' :: (Path', a) -> Cli (Path.Absolute, a)
|
resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a)
|
||||||
resolveSplit' =
|
resolveSplit' =
|
||||||
traverseOf _1 resolvePath'
|
traverseOf _1 resolvePath'
|
||||||
|
|
||||||
@ -166,23 +204,27 @@ resolveSplit' =
|
|||||||
-- branches by path are OK - the empty branch will be returned).
|
-- branches by path are OK - the empty branch will be returned).
|
||||||
resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO)
|
resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO)
|
||||||
resolveAbsBranchId = \case
|
resolveAbsBranchId = \case
|
||||||
Left hash -> resolveShortCausalHash hash
|
Input.BranchAtSCH hash -> resolveShortCausalHash hash
|
||||||
Right path -> getBranchAt path
|
Input.BranchAtPath absPath -> do
|
||||||
|
pp <- resolvePath' (Path' (Left absPath))
|
||||||
|
getBranchFromProjectPath pp
|
||||||
|
Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp
|
||||||
|
|
||||||
-- | V2 version of 'resolveAbsBranchId2'.
|
-- | V2 version of 'resolveAbsBranchId2'.
|
||||||
resolveAbsBranchIdV2 ::
|
resolveAbsBranchIdV2 ::
|
||||||
(forall void. Output.Output -> Sqlite.Transaction void) ->
|
(forall void. Output.Output -> Sqlite.Transaction void) ->
|
||||||
|
ProjectAndBranch Project ProjectBranch ->
|
||||||
Input.AbsBranchId ->
|
Input.AbsBranchId ->
|
||||||
Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
||||||
resolveAbsBranchIdV2 rollback = \case
|
resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case
|
||||||
Left shortHash -> do
|
Input.BranchAtSCH shortHash -> do
|
||||||
hash <- resolveShortCausalHashToCausalHash rollback shortHash
|
hash <- resolveShortCausalHashToCausalHash rollback shortHash
|
||||||
succeed (Codebase.expectCausalBranchByCausalHash hash)
|
causal <- (Codebase.expectCausalBranchByCausalHash hash)
|
||||||
Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
|
V2Causal.value causal
|
||||||
where
|
Input.BranchAtPath absPath -> do
|
||||||
succeed getCausal = do
|
let pp = PP.ProjectPath proj branch absPath
|
||||||
causal <- getCausal
|
Codebase.getShallowBranchAtProjectPath pp
|
||||||
V2Causal.value causal
|
Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp
|
||||||
|
|
||||||
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
|
-- | 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).
|
-- branches by path are OK - the empty branch will be returned).
|
||||||
@ -194,7 +236,7 @@ resolveBranchId branchId = do
|
|||||||
-- | Resolve a @BranchId@ to an @AbsBranchId@.
|
-- | Resolve a @BranchId@ to an @AbsBranchId@.
|
||||||
resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId
|
resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId
|
||||||
resolveBranchIdToAbsBranchId =
|
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.
|
-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
|
||||||
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
|
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
|
||||||
@ -222,77 +264,52 @@ resolveShortCausalHashToCausalHash rollback shortHash = do
|
|||||||
-- Getting/Setting branches
|
-- Getting/Setting branches
|
||||||
|
|
||||||
-- | Get the root branch.
|
-- | Get the root branch.
|
||||||
getRootBranch :: Cli (Branch IO)
|
getCurrentProjectRoot :: Cli (Branch IO)
|
||||||
getRootBranch = do
|
getCurrentProjectRoot = do
|
||||||
use #root >>= atomically . readTMVar
|
use #currentProjectRoot >>= atomically . readTMVar
|
||||||
|
|
||||||
-- | Get the root branch0.
|
-- | Get the root branch0.
|
||||||
getRootBranch0 :: Cli (Branch0 IO)
|
getCurrentProjectRoot0 :: Cli (Branch0 IO)
|
||||||
getRootBranch0 =
|
getCurrentProjectRoot0 =
|
||||||
Branch.head <$> getRootBranch
|
Branch.head <$> getCurrentProjectRoot
|
||||||
|
|
||||||
-- | Set a new root branch.
|
|
||||||
--
|
|
||||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
|
||||||
setRootBranch :: Branch IO -> Cli ()
|
|
||||||
setRootBranch b = do
|
|
||||||
void $ modifyRootBranch (const b)
|
|
||||||
|
|
||||||
-- | Modify the root branch.
|
|
||||||
--
|
|
||||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
|
||||||
modifyRootBranch :: (Branch IO -> Branch IO) -> Cli (Branch IO)
|
|
||||||
modifyRootBranch f = do
|
|
||||||
rootVar <- use #root
|
|
||||||
atomically do
|
|
||||||
root <- takeTMVar rootVar
|
|
||||||
let !newRoot = f root
|
|
||||||
putTMVar rootVar newRoot
|
|
||||||
pure newRoot
|
|
||||||
|
|
||||||
-- | Get the current branch.
|
-- | Get the current branch.
|
||||||
getCurrentBranch :: Cli (Branch IO)
|
getCurrentBranch :: Cli (Branch IO)
|
||||||
getCurrentBranch = do
|
getCurrentBranch = do
|
||||||
path <- getCurrentPath
|
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
liftIO $ Codebase.getBranchAtPath codebase path
|
pp <- getCurrentProjectPath
|
||||||
|
fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp)
|
||||||
|
|
||||||
-- | Get the current branch0.
|
-- | Get the current branch0.
|
||||||
getCurrentBranch0 :: Cli (Branch0 IO)
|
getCurrentBranch0 :: Cli (Branch0 IO)
|
||||||
getCurrentBranch0 = do
|
getCurrentBranch0 = do
|
||||||
Branch.head <$> getCurrentBranch
|
Branch.head <$> getCurrentBranch
|
||||||
|
|
||||||
-- | Get the last saved root hash.
|
-- | Get the branch at an absolute path from the project root.
|
||||||
getLastSavedRootHash :: Cli CausalHash
|
getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO)
|
||||||
getLastSavedRootHash = do
|
getBranchFromProjectPath pp =
|
||||||
use #lastSavedRootHash
|
getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty
|
||||||
|
|
||||||
-- | Set a new root branch.
|
|
||||||
-- Note: This does _not_ update the codebase, the caller is responsible for that.
|
|
||||||
setLastSavedRootHash :: CausalHash -> Cli ()
|
|
||||||
setLastSavedRootHash ch = do
|
|
||||||
#lastSavedRootHash .= ch
|
|
||||||
|
|
||||||
-- | Get the branch at an absolute path.
|
|
||||||
getBranchAt :: Path.Absolute -> Cli (Branch IO)
|
|
||||||
getBranchAt path =
|
|
||||||
getMaybeBranchAt path <&> fromMaybe Branch.empty
|
|
||||||
|
|
||||||
-- | Get the branch0 at an absolute path.
|
-- | Get the branch0 at an absolute path.
|
||||||
getBranch0At :: Path.Absolute -> Cli (Branch0 IO)
|
getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO)
|
||||||
getBranch0At path =
|
getBranch0FromProjectPath pp =
|
||||||
Branch.head <$> getBranchAt path
|
Branch.head <$> getBranchFromProjectPath pp
|
||||||
|
|
||||||
|
getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO)
|
||||||
|
getProjectBranchRoot projectBranch = do
|
||||||
|
Cli.Env {codebase} <- ask
|
||||||
|
liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId
|
||||||
|
|
||||||
-- | Get the maybe-branch at an absolute path.
|
-- | Get the maybe-branch at an absolute path.
|
||||||
getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO))
|
getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO))
|
||||||
getMaybeBranchAt path = do
|
getMaybeBranchFromProjectPath pp = do
|
||||||
rootBranch <- getRootBranch
|
Cli.Env {codebase} <- ask
|
||||||
pure (Branch.getAt (Path.unabsolute path) rootBranch)
|
liftIO $ Codebase.getBranchAtProjectPath codebase pp
|
||||||
|
|
||||||
-- | Get the maybe-branch0 at an absolute path.
|
-- | Get the maybe-branch0 at an absolute path.
|
||||||
getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO))
|
getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO))
|
||||||
getMaybeBranch0At path =
|
getMaybeBranch0FromProjectPath pp =
|
||||||
fmap Branch.head <$> getMaybeBranchAt path
|
fmap Branch.head <$> getMaybeBranchFromProjectPath pp
|
||||||
|
|
||||||
-- | Get the branch at a relative path, or return early if there's no such branch.
|
-- | Get the branch at a relative path, or return early if there's no such branch.
|
||||||
expectBranchAtPath :: Path -> Cli (Branch IO)
|
expectBranchAtPath :: Path -> Cli (Branch IO)
|
||||||
@ -303,7 +320,7 @@ expectBranchAtPath =
|
|||||||
expectBranchAtPath' :: Path' -> Cli (Branch IO)
|
expectBranchAtPath' :: Path' -> Cli (Branch IO)
|
||||||
expectBranchAtPath' path0 = do
|
expectBranchAtPath' path0 = do
|
||||||
path <- resolvePath' path0
|
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.
|
-- | Get the branch0 at an absolute or relative path, or return early if there's no such branch.
|
||||||
expectBranch0AtPath' :: Path' -> Cli (Branch0 IO)
|
expectBranch0AtPath' :: Path' -> Cli (Branch0 IO)
|
||||||
@ -329,167 +346,138 @@ assertNoBranchAtPath' path' = do
|
|||||||
-- current terms/types etc).
|
-- current terms/types etc).
|
||||||
branchExistsAtPath' :: Path' -> Cli Bool
|
branchExistsAtPath' :: Path' -> Cli Bool
|
||||||
branchExistsAtPath' path' = do
|
branchExistsAtPath' path' = do
|
||||||
absPath <- resolvePath' path'
|
pp <- resolvePath' path'
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute absPath)
|
branch <- Codebase.getShallowBranchAtProjectPath pp
|
||||||
branch <- V2Causal.value causal
|
|
||||||
isEmpty <- V2Branch.isEmpty branch
|
isEmpty <- V2Branch.isEmpty branch
|
||||||
pure (not isEmpty)
|
pure (not isEmpty)
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Updating branches
|
-- Updating branches
|
||||||
|
|
||||||
|
makeActionsUnabsolute :: Functor f => f (Path.Absolute, x) -> f (Path, x)
|
||||||
|
makeActionsUnabsolute = fmap (first Path.unabsolute)
|
||||||
|
|
||||||
stepAt ::
|
stepAt ::
|
||||||
Text ->
|
Text ->
|
||||||
(Path, Branch0 IO -> Branch0 IO) ->
|
(ProjectPath, Branch0 IO -> Branch0 IO) ->
|
||||||
Cli ()
|
Cli ()
|
||||||
stepAt cause = stepManyAt @[] cause . pure
|
stepAt cause (pp, action) = stepManyAt pp.branch cause [(pp.absPath, action)]
|
||||||
|
|
||||||
stepAt' ::
|
stepAt' ::
|
||||||
Text ->
|
Text ->
|
||||||
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
(ProjectPath, Branch0 IO -> Cli (Branch0 IO)) ->
|
||||||
Cli Bool
|
Cli Bool
|
||||||
stepAt' cause = stepManyAt' @[] cause . pure
|
stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)]
|
||||||
|
|
||||||
stepAtNoSync' ::
|
|
||||||
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
|
||||||
Cli Bool
|
|
||||||
stepAtNoSync' = stepManyAtNoSync' @[] . pure
|
|
||||||
|
|
||||||
stepAtNoSync ::
|
|
||||||
(Path, Branch0 IO -> Branch0 IO) ->
|
|
||||||
Cli ()
|
|
||||||
stepAtNoSync = stepManyAtNoSync @[] . pure
|
|
||||||
|
|
||||||
stepAtM ::
|
stepAtM ::
|
||||||
Text ->
|
Text ->
|
||||||
(Path, Branch0 IO -> IO (Branch0 IO)) ->
|
(ProjectPath, Branch0 IO -> IO (Branch0 IO)) ->
|
||||||
Cli ()
|
Cli ()
|
||||||
stepAtM cause = stepManyAtM @[] cause . pure
|
stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)]
|
||||||
|
|
||||||
stepManyAt ::
|
stepManyAt ::
|
||||||
(Foldable f) =>
|
ProjectBranch ->
|
||||||
Text ->
|
Text ->
|
||||||
f (Path, Branch0 IO -> Branch0 IO) ->
|
[(Path.Absolute, Branch0 IO -> Branch0 IO)] ->
|
||||||
Cli ()
|
Cli ()
|
||||||
stepManyAt reason actions = do
|
stepManyAt pb reason actions = do
|
||||||
stepManyAtNoSync actions
|
updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions)
|
||||||
syncRoot reason
|
|
||||||
|
|
||||||
stepManyAt' ::
|
stepManyAt' ::
|
||||||
(Foldable f) =>
|
ProjectBranch ->
|
||||||
Text ->
|
Text ->
|
||||||
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
[(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] ->
|
||||||
Cli Bool
|
Cli Bool
|
||||||
stepManyAt' reason actions = do
|
stepManyAt' pb reason actions = do
|
||||||
res <- stepManyAtNoSync' actions
|
origRoot <- getProjectBranchRoot pb
|
||||||
syncRoot reason
|
newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot
|
||||||
pure res
|
didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot))
|
||||||
|
pure didChange
|
||||||
stepManyAtNoSync' ::
|
|
||||||
(Foldable f) =>
|
|
||||||
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
|
|
||||||
Cli Bool
|
|
||||||
stepManyAtNoSync' actions = do
|
|
||||||
origRoot <- getRootBranch
|
|
||||||
newRoot <- Branch.stepManyAtM actions origRoot
|
|
||||||
setRootBranch newRoot
|
|
||||||
pure (origRoot /= newRoot)
|
|
||||||
|
|
||||||
-- Like stepManyAt, but doesn't update the last saved root
|
-- 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 ::
|
stepManyAtM ::
|
||||||
(Foldable f) =>
|
ProjectBranch ->
|
||||||
Text ->
|
Text ->
|
||||||
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
|
[(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] ->
|
||||||
Cli ()
|
Cli ()
|
||||||
stepManyAtM reason actions = do
|
stepManyAtM pb reason actions = do
|
||||||
stepManyAtMNoSync actions
|
updateProjectBranchRoot pb reason \oldRoot -> do
|
||||||
syncRoot reason
|
newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot)
|
||||||
|
pure (newRoot, ())
|
||||||
stepManyAtMNoSync ::
|
|
||||||
(Foldable f) =>
|
|
||||||
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
|
|
||||||
Cli ()
|
|
||||||
stepManyAtMNoSync actions = do
|
|
||||||
oldRoot <- getRootBranch
|
|
||||||
newRoot <- liftIO (Branch.stepManyAtM actions oldRoot)
|
|
||||||
setRootBranch newRoot
|
|
||||||
|
|
||||||
-- | Sync the in-memory root branch.
|
|
||||||
syncRoot :: Text -> Cli ()
|
|
||||||
syncRoot description = do
|
|
||||||
rootBranch <- getRootBranch
|
|
||||||
updateRoot rootBranch description
|
|
||||||
|
|
||||||
-- | Update a branch at the given path, returning `True` if
|
-- | Update a branch at the given path, returning `True` if
|
||||||
-- an update occurred and false otherwise
|
-- an update occurred and false otherwise
|
||||||
updateAtM ::
|
updateAtM ::
|
||||||
Text ->
|
Text ->
|
||||||
Path.Absolute ->
|
ProjectPath ->
|
||||||
(Branch IO -> Cli (Branch IO)) ->
|
(Branch IO -> Cli (Branch IO)) ->
|
||||||
Cli Bool
|
Cli Bool
|
||||||
updateAtM reason (Path.Absolute p) f = do
|
updateAtM reason pp f = do
|
||||||
b <- getRootBranch
|
oldRootBranch <- getProjectBranchRoot (pp ^. #branch)
|
||||||
b' <- Branch.modifyAtM p f b
|
newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch
|
||||||
updateRoot b' reason
|
updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch)
|
||||||
pure $ b /= b'
|
pure $ oldRootBranch /= newRootBranch
|
||||||
|
|
||||||
-- | Update a branch at the given path, returning `True` if
|
-- | Update a branch at the given path, returning `True` if
|
||||||
-- an update occurred and false otherwise
|
-- an update occurred and false otherwise
|
||||||
updateAt ::
|
updateAt ::
|
||||||
Text ->
|
Text ->
|
||||||
Path.Absolute ->
|
ProjectPath ->
|
||||||
(Branch IO -> Branch IO) ->
|
(Branch IO -> Branch IO) ->
|
||||||
Cli Bool
|
Cli Bool
|
||||||
updateAt reason p f = do
|
updateAt reason pp f = do
|
||||||
updateAtM reason p (pure . f)
|
updateAtM reason pp (pure . f)
|
||||||
|
|
||||||
updateAndStepAt ::
|
updateAndStepAt ::
|
||||||
(Foldable f, Foldable g) =>
|
(Foldable f, Foldable g, Functor g) =>
|
||||||
Text ->
|
Text ->
|
||||||
|
ProjectBranch ->
|
||||||
f (Path.Absolute, Branch IO -> Branch IO) ->
|
f (Path.Absolute, Branch IO -> Branch IO) ->
|
||||||
g (Path, Branch0 IO -> Branch0 IO) ->
|
g (Path.Absolute, Branch0 IO -> Branch0 IO) ->
|
||||||
Cli ()
|
Cli ()
|
||||||
updateAndStepAt reason updates steps = do
|
updateAndStepAt reason projectBranch updates steps = do
|
||||||
root <-
|
let f b =
|
||||||
(Branch.stepManyAt steps)
|
b
|
||||||
. (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
|
& (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
|
||||||
<$> getRootBranch
|
& (Branch.stepManyAt (first Path.unabsolute <$> steps))
|
||||||
updateRoot root reason
|
updateProjectBranchRoot_ projectBranch reason f
|
||||||
|
|
||||||
updateRoot :: Branch IO -> Text -> Cli ()
|
updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r
|
||||||
updateRoot new reason =
|
updateProjectBranchRoot projectBranch reason f = do
|
||||||
Cli.time "updateRoot" do
|
currentPB <- getCurrentProjectBranch
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
let newHash = Branch.headHash new
|
Cli.time "updateProjectBranchRoot" do
|
||||||
oldHash <- getLastSavedRootHash
|
old <- getProjectBranchRoot projectBranch
|
||||||
when (oldHash /= newHash) do
|
(new, result) <- f old
|
||||||
liftIO (Codebase.putRootBranch codebase reason new)
|
liftIO $ Codebase.putBranch codebase new
|
||||||
setRootBranch new
|
Cli.runTransaction $ do
|
||||||
setLastSavedRootHash newHash
|
causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new)
|
||||||
|
Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId
|
||||||
|
if projectBranch.branchId == currentPB.branchId
|
||||||
|
then Cli.setInMemoryCurrentProjectRoot new
|
||||||
|
else pure ()
|
||||||
|
pure result
|
||||||
|
|
||||||
|
updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli ()
|
||||||
|
updateProjectBranchRoot_ projectBranch reason f = do
|
||||||
|
updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ()))
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Getting terms
|
-- Getting terms
|
||||||
|
|
||||||
getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent)
|
getTermsAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent)
|
||||||
getTermsAt path = do
|
getTermsAt (pp, hqSeg) = do
|
||||||
rootBranch0 <- getRootBranch0
|
rootBranch0 <- getBranch0FromProjectPath pp
|
||||||
pure (BranchUtil.getTerm (first Path.unabsolute path) rootBranch0)
|
pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0)
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Getting types
|
-- Getting types
|
||||||
|
|
||||||
getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference)
|
getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference)
|
||||||
getTypesAt path = do
|
getTypesAt (pp, hqSeg) = do
|
||||||
rootBranch0 <- getRootBranch0
|
rootBranch0 <- getBranch0FromProjectPath pp
|
||||||
pure (BranchUtil.getType (first Path.unabsolute path) rootBranch0)
|
pure (BranchUtil.getType (mempty, hqSeg) rootBranch0)
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Getting patches
|
-- Getting patches
|
||||||
@ -507,8 +495,8 @@ getPatchAt path =
|
|||||||
-- | Get the patch at a path.
|
-- | Get the patch at a path.
|
||||||
getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch)
|
getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch)
|
||||||
getMaybePatchAt path0 = do
|
getMaybePatchAt path0 = do
|
||||||
(path, name) <- resolveSplit' path0
|
(pp, name) <- resolveSplit' path0
|
||||||
branch <- getBranch0At path
|
branch <- getBranch0FromProjectPath pp
|
||||||
liftIO (Branch.getMaybePatch name branch)
|
liftIO (Branch.getMaybePatch name branch)
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
|
@ -1,15 +1,27 @@
|
|||||||
-- | Utilities that have to do with constructing names objects.
|
-- | Utilities that have to do with constructing names objects.
|
||||||
module Unison.Cli.NamesUtils
|
module Unison.Cli.NamesUtils
|
||||||
( currentNames,
|
( currentNames,
|
||||||
|
currentProjectRootNames,
|
||||||
|
projectBranchNames,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
|
||||||
import Unison.Cli.Monad (Cli)
|
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.Codebase.Branch.Names qualified as Branch
|
||||||
import Unison.Names (Names)
|
import Unison.Names (Names)
|
||||||
|
|
||||||
-- | Produce a 'Names' object which contains names for the current branch.
|
-- | Produce a 'Names' object which contains names for the current branch.
|
||||||
currentNames :: Cli Names
|
currentNames :: Cli Names
|
||||||
currentNames = do
|
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
|
module Unison.Cli.Pretty
|
||||||
( displayBranchHash,
|
( displayBranchHash,
|
||||||
prettyAbsolute,
|
prettyAbsolute,
|
||||||
prettyAbsoluteStripProject,
|
prettyProjectPath,
|
||||||
|
prettyBranchRelativePath,
|
||||||
prettyBase32Hex#,
|
prettyBase32Hex#,
|
||||||
prettyBase32Hex,
|
prettyBase32Hex,
|
||||||
prettyBranchId,
|
prettyBranchId,
|
||||||
@ -33,7 +34,6 @@ module Unison.Cli.Pretty
|
|||||||
prettyRepoInfo,
|
prettyRepoInfo,
|
||||||
prettySCH,
|
prettySCH,
|
||||||
prettySemver,
|
prettySemver,
|
||||||
prettyShareLink,
|
|
||||||
prettySharePath,
|
prettySharePath,
|
||||||
prettyShareURI,
|
prettyShareURI,
|
||||||
prettySlashProjectBranchName,
|
prettySlashProjectBranchName,
|
||||||
@ -57,12 +57,10 @@ import Control.Monad.Writer (Writer, runWriter)
|
|||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Map qualified as Map
|
import Data.Map qualified as Map
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Text qualified as Text
|
|
||||||
import Data.Time (UTCTime)
|
import Data.Time (UTCTime)
|
||||||
import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
|
import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
|
||||||
import Network.URI (URI)
|
import Network.URI (URI)
|
||||||
import Network.URI qualified as URI
|
import Network.URI qualified as URI
|
||||||
import Network.URI.Encode qualified as URI
|
|
||||||
import U.Codebase.HashTags (CausalHash (..))
|
import U.Codebase.HashTags (CausalHash (..))
|
||||||
import U.Codebase.Reference qualified as Reference
|
import U.Codebase.Reference qualified as Reference
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
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 (Base32Hex)
|
||||||
import U.Util.Base32Hex qualified as Base32Hex
|
import U.Util.Base32Hex qualified as Base32Hex
|
||||||
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
|
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
|
||||||
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
|
|
||||||
import Unison.Cli.Share.Projects.Types qualified as Share
|
import Unison.Cli.Share.Projects.Types qualified as Share
|
||||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
import Unison.Codebase.Editor.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
import Unison.Codebase.Editor.RemoteRepo
|
import Unison.Codebase.Editor.RemoteRepo
|
||||||
( ReadRemoteNamespace (..),
|
( ReadRemoteNamespace (..),
|
||||||
ShareUserHandle (..),
|
|
||||||
WriteRemoteNamespace (..),
|
|
||||||
WriteShareRemoteNamespace (..),
|
|
||||||
shareUserHandleToText,
|
|
||||||
)
|
)
|
||||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||||
import Unison.Codebase.Path (Path')
|
|
||||||
import Unison.Codebase.Path qualified as 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 (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
|
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||||
import Unison.Core.Project (ProjectBranchName)
|
import Unison.Core.Project (ProjectBranchName)
|
||||||
import Unison.DataDeclaration qualified as DD
|
import Unison.DataDeclaration qualified as DD
|
||||||
import Unison.Debug qualified as Debug
|
import Unison.Debug qualified as Debug
|
||||||
@ -126,6 +121,7 @@ import Unison.Term (Term)
|
|||||||
import Unison.Type (Type)
|
import Unison.Type (Type)
|
||||||
import Unison.UnisonFile qualified as UF
|
import Unison.UnisonFile qualified as UF
|
||||||
import Unison.UnisonFile.Names 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.Util.Pretty qualified as P
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import Unison.Var qualified as Var
|
import Unison.Var qualified as Var
|
||||||
@ -150,7 +146,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty
|
|||||||
prettyReadRemoteNamespaceWith printProject =
|
prettyReadRemoteNamespaceWith printProject =
|
||||||
P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject
|
P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject
|
||||||
|
|
||||||
prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
||||||
prettyWriteRemoteNamespace =
|
prettyWriteRemoteNamespace =
|
||||||
P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace
|
P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace
|
||||||
|
|
||||||
@ -161,14 +157,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty
|
|||||||
prettyRepoInfo (Share.RepoInfo repoInfo) =
|
prettyRepoInfo (Share.RepoInfo repoInfo) =
|
||||||
P.blue (P.text 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 :: Share.Path -> Pretty
|
||||||
prettySharePath =
|
prettySharePath =
|
||||||
prettyRelative
|
prettyRelative
|
||||||
@ -194,16 +182,17 @@ prettyPath' p' =
|
|||||||
then "the current namespace"
|
then "the current namespace"
|
||||||
else P.blue (P.shown p')
|
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
|
prettyNamespaceKey = \case
|
||||||
Left path -> prettyPath' path
|
Left path -> prettyProjectPath path
|
||||||
Right (ProjectAndBranch project branch) ->
|
Right (ProjectAndBranch project branch) ->
|
||||||
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
|
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
|
||||||
|
|
||||||
prettyBranchId :: Input.AbsBranchId -> Pretty
|
prettyBranchId :: Input.AbsBranchId -> Pretty
|
||||||
prettyBranchId = \case
|
prettyBranchId = \case
|
||||||
Left sch -> prettySCH sch
|
Input.BranchAtSCH sch -> prettySCH sch
|
||||||
Right absPath -> prettyAbsolute $ absPath
|
Input.BranchAtPath absPath -> prettyAbsolute $ absPath
|
||||||
|
Input.BranchAtProjectPath pp -> prettyProjectPath pp
|
||||||
|
|
||||||
prettyRelative :: Path.Relative -> Pretty
|
prettyRelative :: Path.Relative -> Pretty
|
||||||
prettyRelative = P.blue . P.shown
|
prettyRelative = P.blue . P.shown
|
||||||
@ -211,6 +200,13 @@ prettyRelative = P.blue . P.shown
|
|||||||
prettyAbsolute :: Path.Absolute -> Pretty
|
prettyAbsolute :: Path.Absolute -> Pretty
|
||||||
prettyAbsolute = P.blue . P.shown
|
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 :: (IsString s) => ShortCausalHash -> P.Pretty s
|
||||||
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
|
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
|
||||||
|
|
||||||
@ -271,6 +267,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName ->
|
|||||||
prettyProjectAndBranchName (ProjectAndBranch project branch) =
|
prettyProjectAndBranchName (ProjectAndBranch project branch) =
|
||||||
P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch)
|
P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch)
|
||||||
|
|
||||||
|
prettyBranchRelativePath :: BranchRelativePath -> Pretty
|
||||||
|
prettyBranchRelativePath = P.blue . P.text . into @Text
|
||||||
|
|
||||||
-- produces:
|
-- produces:
|
||||||
-- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0
|
-- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0
|
||||||
-- Optional.None, Maybe.Nothing : Maybe a
|
-- Optional.None, Maybe.Nothing : Maybe a
|
||||||
@ -343,7 +342,7 @@ prettyTypeName ppe r =
|
|||||||
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
|
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
|
||||||
prettyWhichBranchEmpty = \case
|
prettyWhichBranchEmpty = \case
|
||||||
WhichBranchEmptyHash hash -> P.shown hash
|
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
|
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
|
||||||
displayBranchHash :: CausalHash -> Text
|
displayBranchHash :: CausalHash -> Text
|
||||||
@ -389,15 +388,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
|
|||||||
<> " on "
|
<> " on "
|
||||||
<> P.shown host
|
<> 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.PrettyPrintEnv -> Set LabeledDependency -> Pretty
|
||||||
prettyLabeledDependencies ppe lds =
|
prettyLabeledDependencies ppe lds =
|
||||||
P.syntaxToColor (P.sep ", " (ld <$> toList lds))
|
P.syntaxToColor (P.sep ", " (ld <$> toList lds))
|
||||||
|
@ -3,9 +3,11 @@
|
|||||||
module Unison.Cli.PrettyPrintUtils
|
module Unison.Cli.PrettyPrintUtils
|
||||||
( prettyPrintEnvDeclFromNames,
|
( prettyPrintEnvDeclFromNames,
|
||||||
currentPrettyPrintEnvDecl,
|
currentPrettyPrintEnvDecl,
|
||||||
|
projectBranchPPED,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.NamesUtils qualified as Cli
|
import Unison.Cli.NamesUtils qualified as Cli
|
||||||
@ -14,6 +16,7 @@ import Unison.Names (Names)
|
|||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnv.Names qualified as PPE
|
import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo)
|
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo)
|
||||||
|
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||||
|
|
||||||
-- | Builds a pretty print env decl from a names object.
|
-- | Builds a pretty print env decl from a names object.
|
||||||
@ -30,3 +33,7 @@ prettyPrintEnvDeclFromNames ns =
|
|||||||
currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl
|
currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl
|
||||||
currentPrettyPrintEnvDecl = do
|
currentPrettyPrintEnvDecl = do
|
||||||
Cli.currentNames >>= prettyPrintEnvDeclFromNames
|
Cli.currentNames >>= prettyPrintEnvDeclFromNames
|
||||||
|
|
||||||
|
projectBranchPPED :: ProjectBranch -> Cli PPED.PrettyPrintEnvDecl
|
||||||
|
projectBranchPPED pb = do
|
||||||
|
Cli.projectBranchNames pb >>= prettyPrintEnvDeclFromNames
|
||||||
|
@ -1,21 +1,10 @@
|
|||||||
-- | Project-related utilities.
|
-- | Project-related utilities.
|
||||||
module Unison.Cli.ProjectUtils
|
module Unison.Cli.ProjectUtils
|
||||||
( -- * Project/path helpers
|
( -- * Project/path helpers
|
||||||
getCurrentProject,
|
|
||||||
expectCurrentProject,
|
|
||||||
expectCurrentProjectIds,
|
|
||||||
getCurrentProjectIds,
|
|
||||||
getCurrentProjectBranch,
|
|
||||||
getProjectBranchForPath,
|
|
||||||
expectCurrentProjectBranch,
|
|
||||||
expectProjectBranchByName,
|
expectProjectBranchByName,
|
||||||
projectPath,
|
|
||||||
projectBranchesPath,
|
|
||||||
projectBranchPath,
|
|
||||||
projectBranchSegment,
|
|
||||||
projectBranchPathPrism,
|
|
||||||
resolveBranchRelativePath,
|
resolveBranchRelativePath,
|
||||||
branchRelativePathToAbsolute,
|
resolveProjectBranch,
|
||||||
|
resolveProjectBranchInProject,
|
||||||
|
|
||||||
-- * Name hydration
|
-- * Name hydration
|
||||||
hydrateNames,
|
hydrateNames,
|
||||||
@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils
|
|||||||
-- * Loading local project info
|
-- * Loading local project info
|
||||||
expectProjectAndBranchByIds,
|
expectProjectAndBranchByIds,
|
||||||
getProjectAndBranchByTheseNames,
|
getProjectAndBranchByTheseNames,
|
||||||
expectProjectAndBranchByTheseNames,
|
|
||||||
getProjectAndBranchByNames,
|
getProjectAndBranchByNames,
|
||||||
expectLooseCodeOrProjectBranch,
|
expectProjectAndBranchByTheseNames,
|
||||||
getProjectBranchCausalHash,
|
getProjectBranchCausalHash,
|
||||||
|
|
||||||
-- * Loading remote project info
|
-- * Loading remote project info
|
||||||
@ -59,65 +47,43 @@ import Data.Maybe (fromJust)
|
|||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.These (These (..))
|
import Data.These (These (..))
|
||||||
import U.Codebase.Causal qualified
|
|
||||||
import U.Codebase.HashTags (CausalHash)
|
import U.Codebase.HashTags (CausalHash)
|
||||||
import U.Codebase.Sqlite.DbId
|
import U.Codebase.Sqlite.DbId
|
||||||
|
import U.Codebase.Sqlite.Project (Project)
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
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.ProjectBranch qualified as Sqlite
|
||||||
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.Share.Projects (IncludeSquashedHead)
|
import Unison.Cli.Share.Projects (IncludeSquashedHead)
|
||||||
import Unison.Cli.Share.Projects qualified as Share
|
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 (Output (LocalProjectBranchDoesntExist))
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path (Path')
|
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath)
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
|
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
|
||||||
import Unison.Core.Project (ProjectBranchName (..))
|
import Unison.Core.Project (ProjectBranchName (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||||
import Unison.Project.Util
|
|
||||||
import Unison.Sqlite (Transaction)
|
import Unison.Sqlite (Transaction)
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Witch (unsafeFrom)
|
import Witch (unsafeFrom)
|
||||||
|
|
||||||
branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
|
resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath
|
||||||
branchRelativePathToAbsolute brp =
|
resolveBranchRelativePath brp = do
|
||||||
resolveBranchRelativePath brp <&> \case
|
case brp of
|
||||||
BranchRelativePath.ResolvedLoosePath p -> p
|
BranchPathInCurrentProject projBranchName path -> do
|
||||||
BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
|
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
||||||
let projectBranchIds = getIds projectBranch
|
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||||
handleRel = case mRel of
|
QualifiedBranchPath projName projBranchName path -> do
|
||||||
Nothing -> id
|
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
||||||
Just rel -> flip Path.resolve rel
|
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||||
in handleRel (projectBranchPath projectBranchIds)
|
UnqualifiedPath newPath' -> do
|
||||||
where
|
pp <- Cli.getCurrentProjectPath
|
||||||
getIds = \case
|
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||||
ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
|
|
||||||
|
|
||||||
resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath
|
|
||||||
resolveBranchRelativePath = \case
|
|
||||||
BranchRelativePath.BranchRelative brp -> case brp of
|
|
||||||
This projectBranch -> do
|
|
||||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
|
||||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing)
|
|
||||||
That path -> do
|
|
||||||
(projectBranch, _) <- expectCurrentProjectBranch
|
|
||||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
|
||||||
These projectBranch path -> do
|
|
||||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
|
||||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
|
||||||
BranchRelativePath.LoosePath path ->
|
|
||||||
BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path
|
|
||||||
where
|
|
||||||
toThese = \case
|
|
||||||
Left branchName -> That branchName
|
|
||||||
Right (projectName, branchName) -> These projectName branchName
|
|
||||||
|
|
||||||
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
|
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
|
||||||
justTheIds x =
|
justTheIds x =
|
||||||
@ -152,58 +118,11 @@ findTemporaryBranchName projectId preferred = do
|
|||||||
|
|
||||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
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 :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
||||||
expectProjectBranchByName project branchName =
|
expectProjectBranchByName project branchName =
|
||||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
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
|
-- 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
|
-- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following
|
||||||
-- defaults if a name is missing:
|
-- defaults if a name is missing:
|
||||||
@ -214,8 +133,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
|
|||||||
hydrateNames = \case
|
hydrateNames = \case
|
||||||
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
pp <- Cli.getCurrentProjectPath
|
||||||
pure (ProjectAndBranch (project ^. #name) branchName)
|
pure (ProjectAndBranch (pp ^. #project . #name) branchName)
|
||||||
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
||||||
|
|
||||||
getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||||
@ -244,11 +163,15 @@ getProjectAndBranchByTheseNames ::
|
|||||||
getProjectAndBranchByTheseNames = \case
|
getProjectAndBranchByTheseNames = \case
|
||||||
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> runMaybeT do
|
That branchName -> runMaybeT do
|
||||||
(ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch
|
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
|
||||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName))
|
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
|
||||||
pure (ProjectAndBranch project branch)
|
pure (ProjectAndBranch proj branch)
|
||||||
These projectName branchName ->
|
These projectName branchName -> do
|
||||||
Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName))
|
Cli.runTransaction do
|
||||||
|
runMaybeT do
|
||||||
|
project <- MaybeT (Queries.loadProjectByName projectName)
|
||||||
|
branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName)
|
||||||
|
pure (ProjectAndBranch project branch)
|
||||||
|
|
||||||
-- Expect a local project branch by a "these names", using the following defaults if a name is missing:
|
-- 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
|
expectProjectAndBranchByTheseNames = \case
|
||||||
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
|
||||||
branch <-
|
branch <-
|
||||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||||
@ -275,31 +198,33 @@ expectProjectAndBranchByTheseNames = \case
|
|||||||
maybeProjectAndBranch & onNothing do
|
maybeProjectAndBranch & onNothing do
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||||
|
|
||||||
-- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules:
|
-- | Expect/resolve branch reference with the following rules:
|
||||||
--
|
--
|
||||||
-- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database.
|
-- 1. If the project is missing, use the provided project.
|
||||||
-- 2. If we have an unambiguous `loose.code.path`, just return it.
|
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
||||||
-- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*,
|
-- project, defaulting to 'main' if branch is unspecified.
|
||||||
-- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash).
|
resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||||
expectLooseCodeOrProjectBranch ::
|
resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||||
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ->
|
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
||||||
Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
|
||||||
expectLooseCodeOrProjectBranch =
|
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||||
_Right expectProjectAndBranchByTheseNames . f
|
pure projectAndBranch
|
||||||
where
|
|
||||||
f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName)
|
-- | Expect/resolve branch reference with the following rules:
|
||||||
f = \case
|
--
|
||||||
This path -> Left path
|
-- 1. If the project is missing, use the current project.
|
||||||
That (ProjectAndBranch Nothing branch) -> Right (That branch)
|
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
||||||
That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
|
-- project, defaulting to 'main' if branch is unspecified.
|
||||||
These path _ -> Left path -- (3) above
|
resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||||
|
resolveProjectBranch pab = do
|
||||||
|
pp <- Cli.getCurrentProjectPath
|
||||||
|
resolveProjectBranchInProject (pp ^. #project) pab
|
||||||
|
|
||||||
-- | Get the causal hash of a project branch.
|
-- | Get the causal hash of a project branch.
|
||||||
getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash
|
getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash
|
||||||
getProjectBranchCausalHash branch = do
|
getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do
|
||||||
let path = projectBranchPath branch
|
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
|
Q.expectCausalHash causalHashId
|
||||||
pure causal.causalHash
|
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Remote project utils
|
-- Remote project utils
|
||||||
@ -384,7 +309,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
|||||||
let remoteBranchName = unsafeFrom @Text "main"
|
let remoteBranchName = unsafeFrom @Text "main"
|
||||||
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
(ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch
|
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
|
||||||
let localProjectId = localProject ^. #projectId
|
let localProjectId = localProject ^. #projectId
|
||||||
let localBranchId = localBranch ^. #branchId
|
let localBranchId = localBranch ^. #branchId
|
||||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||||
|
@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup
|
|||||||
)
|
)
|
||||||
where
|
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.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.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.Codebase.UniqueTypeGuidLookup qualified as Codebase
|
||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
import Unison.NameSegment (NameSegment)
|
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
|
|
||||||
loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text)
|
loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text)
|
||||||
loadUniqueTypeGuid currentPath name0 = do
|
loadUniqueTypeGuid pp name0 = do
|
||||||
-- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path
|
let (namePath, finalSegment) = Path.splitFromName name0
|
||||||
-- to the unique type, plus its final distinguished name segment.
|
let fullPP = pp & over PP.path_ (<> namePath)
|
||||||
let (branchPath, name) =
|
|
||||||
name0
|
|
||||||
& Path.fromName'
|
|
||||||
& Path.resolve currentPath
|
|
||||||
& Path.unabsolute
|
|
||||||
& Path.toSeq
|
|
||||||
& unsnoc
|
|
||||||
-- This is safe because we were handed a Name, which can't be empty
|
|
||||||
& fromJust
|
|
||||||
|
|
||||||
-- Define an operation to load a branch by its full path from the root namespace.
|
-- 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
|
-- 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).
|
-- an appropriate time, such as after the current unison file finishes parsing).
|
||||||
let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||||
loadBranchAtPath = Operations.loadBranchAtPath Nothing
|
loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath
|
||||||
|
|
||||||
Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name
|
Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment
|
||||||
|
@ -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 (NESet)
|
||||||
import Data.Set.NonEmpty qualified as NESet
|
import Data.Set.NonEmpty qualified as NESet
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.These (These (..))
|
|
||||||
import Data.Time (UTCTime)
|
import Data.Time (UTCTime)
|
||||||
import Data.Tuple.Extra (uncurry3)
|
import Data.Tuple.Extra (uncurry3)
|
||||||
import Text.Megaparsec qualified as Megaparsec
|
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.Causal qualified as V2Causal
|
||||||
import U.Codebase.HashTags (CausalHash (..))
|
import U.Codebase.HashTags (CausalHash (..))
|
||||||
import U.Codebase.Reflog qualified as Reflog
|
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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.ABT qualified as ABT
|
import Unison.ABT qualified as ABT
|
||||||
import Unison.Builtin qualified as Builtin
|
import Unison.Builtin qualified as Builtin
|
||||||
import Unison.Builtin.Terms qualified as Builtin
|
import Unison.Builtin.Terms qualified as Builtin
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
|
import Unison.Cli.MonadUtils (getCurrentProjectBranch)
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.NamesUtils qualified as Cli
|
import Unison.Cli.NamesUtils qualified as Cli
|
||||||
import Unison.Cli.PrettyPrintUtils 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.Update2 (handleUpdate2)
|
||||||
import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
|
import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
|
||||||
import Unison.Codebase.Editor.Input
|
import Unison.Codebase.Editor.Input
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN
|
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.Metadata qualified as Metadata
|
||||||
import Unison.Codebase.Path (Path, Path' (..))
|
import Unison.Codebase.Path (Path, Path' (..))
|
||||||
import Unison.Codebase.Path qualified as 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.Runtime qualified as Runtime
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
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.Completion qualified as Completion
|
||||||
import Unison.CommandLine.DisplayValues qualified as DisplayValues
|
import Unison.CommandLine.DisplayValues qualified as DisplayValues
|
||||||
import Unison.CommandLine.InputPattern qualified as IP
|
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.Parsers qualified as Parsers
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnv qualified as PPE
|
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 PPE hiding (biasTo, empty)
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
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 (Reference)
|
||||||
import Unison.Reference qualified as Reference
|
import Unison.Reference qualified as Reference
|
||||||
import Unison.Referent (Referent)
|
import Unison.Referent (Referent)
|
||||||
@ -251,83 +245,17 @@ loop e = do
|
|||||||
ResetI newRoot mtarget -> do
|
ResetI newRoot mtarget -> do
|
||||||
newRoot <-
|
newRoot <-
|
||||||
case newRoot of
|
case newRoot of
|
||||||
This newRoot -> case newRoot of
|
BranchAtPath p -> do
|
||||||
Left hash -> Cli.resolveShortCausalHash hash
|
pp <- Cli.resolvePath' p
|
||||||
Right path' -> Cli.expectBranchAtPath' path'
|
Cli.getBranchFromProjectPath pp
|
||||||
That (ProjectAndBranch mProjectName branchName) -> do
|
BranchAtSCH sch -> Cli.resolveShortCausalHash sch
|
||||||
let arg = case mProjectName of
|
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||||
Nothing -> That branchName
|
|
||||||
Just projectName -> These projectName branchName
|
|
||||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
|
||||||
Cli.expectBranchAtPath'
|
|
||||||
( Path.absoluteToPath'
|
|
||||||
( ProjectUtils.projectBranchPath
|
|
||||||
(ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
|
|
||||||
)
|
|
||||||
)
|
|
||||||
These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do
|
|
||||||
absPath <- case branchId of
|
|
||||||
Left hash -> jump =<< Cli.resolveShortCausalHash hash
|
|
||||||
Right path' -> Cli.resolvePath' path'
|
|
||||||
mrelativePath <-
|
|
||||||
Cli.getMaybeBranchAt absPath <&> \case
|
|
||||||
Nothing -> Nothing
|
|
||||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
|
||||||
projectAndBranch <- do
|
|
||||||
let arg = case mProjectName of
|
|
||||||
Nothing -> That branchName
|
|
||||||
Just projectName -> These projectName branchName
|
|
||||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
|
||||||
thePath <- case (mrelativePath, projectAndBranch) of
|
|
||||||
(Nothing, Nothing) ->
|
|
||||||
ProjectUtils.getCurrentProject >>= \case
|
|
||||||
Nothing -> pure absPath
|
|
||||||
Just project ->
|
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
|
||||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
|
||||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
|
||||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
|
||||||
Cli.returnEarlyWithoutOutput
|
|
||||||
(Just _relativePath, Nothing) -> pure absPath
|
|
||||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
|
||||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
|
||||||
Cli.expectBranchAtPath' (Path.absoluteToPath' thePath)
|
|
||||||
|
|
||||||
target <-
|
target <-
|
||||||
case mtarget of
|
case mtarget of
|
||||||
Nothing -> Cli.getCurrentPath
|
Nothing -> Cli.getCurrentProjectPath
|
||||||
Just looseCodeOrProject -> case looseCodeOrProject of
|
Just unresolvedProjectAndBranch -> do
|
||||||
This path' -> Cli.resolvePath' path'
|
targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch)
|
||||||
That (ProjectAndBranch mProjectName branchName) -> do
|
pure $ PP.projectBranchRoot targetProjectAndBranch
|
||||||
let arg = case mProjectName of
|
|
||||||
Nothing -> That branchName
|
|
||||||
Just projectName -> These projectName branchName
|
|
||||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
|
||||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
|
||||||
These path' (ProjectAndBranch mProjectName branchName) -> do
|
|
||||||
absPath <- Cli.resolvePath' path'
|
|
||||||
mrelativePath <-
|
|
||||||
Cli.getMaybeBranchAt absPath <&> \case
|
|
||||||
Nothing -> Nothing
|
|
||||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
|
||||||
projectAndBranch <- do
|
|
||||||
let arg = case mProjectName of
|
|
||||||
Nothing -> That branchName
|
|
||||||
Just projectName -> These projectName branchName
|
|
||||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
|
||||||
case (mrelativePath, projectAndBranch) of
|
|
||||||
(Nothing, Nothing) ->
|
|
||||||
ProjectUtils.getCurrentProject >>= \case
|
|
||||||
Nothing -> pure absPath
|
|
||||||
Just project ->
|
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
|
||||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
|
||||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
|
||||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
|
||||||
Cli.returnEarlyWithoutOutput
|
|
||||||
(Just _relativePath, Nothing) -> pure absPath
|
|
||||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
|
||||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
_ <- Cli.updateAt description target (const newRoot)
|
_ <- Cli.updateAt description target (const newRoot)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
@ -335,22 +263,23 @@ loop e = do
|
|||||||
Cli.time "reset-root" do
|
Cli.time "reset-root" do
|
||||||
newRoot <-
|
newRoot <-
|
||||||
case src0 of
|
case src0 of
|
||||||
Left hash -> Cli.resolveShortCausalHash hash
|
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||||
Right path' -> Cli.expectBranchAtPath' path'
|
BranchAtPath path' -> Cli.expectBranchAtPath' path'
|
||||||
|
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
Cli.updateRoot newRoot description
|
pb <- getCurrentProjectBranch
|
||||||
|
void $ Cli.updateProjectBranchRoot_ pb description (const newRoot)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
ForkLocalBranchI src0 dest0 -> do
|
ForkLocalBranchI src0 dest0 -> do
|
||||||
(srcb, branchEmpty) <-
|
(srcb, branchEmpty) <-
|
||||||
case src0 of
|
case src0 of
|
||||||
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
|
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
|
||||||
Right path' -> do
|
Right path' -> do
|
||||||
absPath <- ProjectUtils.branchRelativePathToAbsolute path'
|
srcPP <- ProjectUtils.resolveBranchRelativePath path'
|
||||||
let srcp = Path.AbsolutePath' absPath
|
srcb <- Cli.getBranchFromProjectPath srcPP
|
||||||
srcb <- Cli.expectBranchAtPath' srcp
|
pure (srcb, WhichBranchEmptyPath srcPP)
|
||||||
pure (srcb, WhichBranchEmptyPath srcp)
|
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
dest <- ProjectUtils.branchRelativePathToAbsolute dest0
|
dest <- ProjectUtils.resolveBranchRelativePath dest0
|
||||||
ok <- Cli.updateAtM description dest (const $ pure srcb)
|
ok <- Cli.updateAtM description dest (const $ pure srcb)
|
||||||
Cli.respond
|
Cli.respond
|
||||||
if ok
|
if ok
|
||||||
@ -358,54 +287,57 @@ loop e = do
|
|||||||
else BranchEmpty branchEmpty
|
else BranchEmpty branchEmpty
|
||||||
MergeI branch -> handleMerge branch
|
MergeI branch -> handleMerge branch
|
||||||
MergeCommitI -> handleCommitMerge
|
MergeCommitI -> handleCommitMerge
|
||||||
MergeLocalBranchI src0 dest0 mergeMode -> do
|
MergeLocalBranchI unresolvedSrc mayUnresolvedDest mergeMode -> do
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
(destPP, destBRP) <- case mayUnresolvedDest of
|
||||||
let srcp = looseCodeOrProjectToPath src0
|
Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_))
|
||||||
let destp = looseCodeOrProjectToPath dest0
|
Just unresolvedDest -> do
|
||||||
srcb <- Cli.expectBranchAtPath' srcp
|
ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest)
|
||||||
dest <- Cli.resolvePath' destp
|
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||||
let err =
|
let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP
|
||||||
Just $
|
mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP
|
||||||
MergeAlreadyUpToDate
|
PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do
|
||||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
|
|
||||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
|
|
||||||
mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
|
|
||||||
PreviewMergeLocalBranchI src0 dest0 -> do
|
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
destPP <- case mayUnresolvedDest of
|
||||||
srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0
|
Nothing -> Cli.getCurrentProjectPath
|
||||||
dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0
|
Just unresolvedDest -> do
|
||||||
destb <- Cli.getBranchAt dest
|
ProjectUtils.resolveBranchRelativePath unresolvedDest
|
||||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||||
if merged == destb
|
destBranch <- Cli.getProjectBranchRoot destPP.branch
|
||||||
then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0)
|
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch)
|
||||||
|
if merged == destBranch
|
||||||
|
then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP)
|
||||||
else do
|
else do
|
||||||
(ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged)
|
(ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged)
|
||||||
Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff)
|
Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff)
|
||||||
DiffNamespaceI before after -> do
|
DiffNamespaceI before after -> do
|
||||||
absBefore <- traverseOf _Right Cli.resolvePath' before
|
beforeLoc <- case before of
|
||||||
absAfter <- traverseOf _Right Cli.resolvePath' after
|
BranchAtSCH sch -> pure $ Left sch
|
||||||
beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore
|
BranchAtPath path' -> Right <$> Cli.resolvePath' path'
|
||||||
afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter
|
BranchAtProjectPath pp -> pure $ Right pp
|
||||||
|
afterLoc <- case after of
|
||||||
|
BranchAtSCH sch -> pure $ Left sch
|
||||||
|
BranchAtPath path' -> Right <$> Cli.resolvePath' path'
|
||||||
|
BranchAtProjectPath pp -> pure $ Right pp
|
||||||
|
beforeBranch0 <- Branch.head <$> Cli.resolveBranchId before
|
||||||
|
afterBranch0 <- Branch.head <$> Cli.resolveBranchId after
|
||||||
case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
|
case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
|
||||||
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
|
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc])
|
||||||
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [])
|
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [])
|
||||||
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| [])
|
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| [])
|
||||||
(False, False) -> pure ()
|
(False, False) -> pure ()
|
||||||
(ppe, diff) <- diffHelper beforeBranch0 afterBranch0
|
(ppe, diff) <- diffHelper beforeBranch0 afterBranch0
|
||||||
Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
|
Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff)
|
||||||
MoveBranchI src' dest' -> do
|
MoveBranchI src' dest' -> do
|
||||||
hasConfirmed <- confirmedCommand input
|
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
doMoveBranch description hasConfirmed src' dest'
|
doMoveBranch description src' dest'
|
||||||
SwitchBranchI path' -> do
|
SwitchBranchI path' -> do
|
||||||
path <- Cli.resolvePath' path'
|
path <- Cli.resolvePath' path'
|
||||||
branchExists <- Cli.branchExistsAtPath' path'
|
branchExists <- Cli.branchExistsAtPath' path'
|
||||||
when (not branchExists) (Cli.respond $ CreatedNewBranch path)
|
when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_))
|
||||||
Cli.cd path
|
Cli.cd (path ^. PP.absPath_)
|
||||||
UpI -> do
|
UpI -> do
|
||||||
path0 <- Cli.getCurrentPath
|
path0 <- Cli.getCurrentPath
|
||||||
whenJust (unsnoc path0) \(path, _) ->
|
whenJust (unsnoc path0) \(path, _) ->
|
||||||
@ -416,10 +348,11 @@ loop e = do
|
|||||||
HistoryI resultsCap diffCap from -> do
|
HistoryI resultsCap diffCap from -> do
|
||||||
branch <-
|
branch <-
|
||||||
case from of
|
case from of
|
||||||
Left hash -> Cli.resolveShortCausalHash hash
|
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||||
Right path' -> do
|
BranchAtPath path' -> do
|
||||||
path <- Cli.resolvePath' path'
|
pp <- Cli.resolvePath' path'
|
||||||
Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
|
Cli.getBranchFromProjectPath pp
|
||||||
|
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||||
schLength <- Cli.runTransaction Codebase.branchHashLength
|
schLength <- Cli.runTransaction Codebase.branchHashLength
|
||||||
history <- liftIO (doHistory schLength 0 branch [])
|
history <- liftIO (doHistory schLength 0 branch [])
|
||||||
Cli.respondNumbered history
|
Cli.respondNumbered history
|
||||||
@ -437,7 +370,7 @@ loop e = do
|
|||||||
let elem = (Branch.headHash b, Branch.namesDiff b' b)
|
let elem = (Branch.headHash b, Branch.namesDiff b' b)
|
||||||
doHistory schLength (n + 1) b' (elem : acc)
|
doHistory schLength (n + 1) b' (elem : acc)
|
||||||
UndoI -> do
|
UndoI -> do
|
||||||
rootBranch <- Cli.getRootBranch
|
rootBranch <- Cli.getCurrentProjectRoot
|
||||||
(_, prev) <-
|
(_, prev) <-
|
||||||
liftIO (Branch.uncons rootBranch) & onNothingM do
|
liftIO (Branch.uncons rootBranch) & onNothingM do
|
||||||
Cli.returnEarly . CantUndo $
|
Cli.returnEarly . CantUndo $
|
||||||
@ -445,7 +378,8 @@ loop e = do
|
|||||||
then CantUndoPastStart
|
then CantUndoPastStart
|
||||||
else CantUndoPastMerge
|
else CantUndoPastMerge
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
Cli.updateRoot prev description
|
pb <- getCurrentProjectBranch
|
||||||
|
Cli.updateProjectBranchRoot_ pb description (const prev)
|
||||||
(ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch)
|
(ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch)
|
||||||
Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff)
|
Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff)
|
||||||
UiI path' -> openUI path'
|
UiI path' -> openUI path'
|
||||||
@ -464,8 +398,8 @@ loop e = do
|
|||||||
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
|
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
|
||||||
DocsToHtmlI namespacePath' sourceDirectory -> do
|
DocsToHtmlI namespacePath' sourceDirectory -> do
|
||||||
Cli.Env {codebase, sandboxedRuntime} <- ask
|
Cli.Env {codebase, sandboxedRuntime} <- ask
|
||||||
absPath <- ProjectUtils.branchRelativePathToAbsolute namespacePath'
|
projPath <- ProjectUtils.resolveBranchRelativePath namespacePath'
|
||||||
branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
|
branch <- Cli.getBranchFromProjectPath projPath
|
||||||
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
|
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
|
||||||
pure ()
|
pure ()
|
||||||
AliasTermI force src' dest' -> do
|
AliasTermI force src' dest' -> do
|
||||||
@ -490,7 +424,7 @@ loop e = do
|
|||||||
when (not force && not (Set.null destTerms)) do
|
when (not force && not (Set.null destTerms)) do
|
||||||
Cli.returnEarly (TermAlreadyExists dest' destTerms)
|
Cli.returnEarly (TermAlreadyExists dest' destTerms)
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm)
|
Cli.stepAt description (BranchUtil.makeAddTermName dest srcTerm)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
AliasTypeI force src' dest' -> do
|
AliasTypeI force src' dest' -> do
|
||||||
src <- traverseOf _Right Cli.resolveSplit' src'
|
src <- traverseOf _Right Cli.resolveSplit' src'
|
||||||
@ -513,22 +447,22 @@ loop e = do
|
|||||||
when (not force && not (Set.null destTypes)) do
|
when (not force && not (Set.null destTypes)) do
|
||||||
Cli.returnEarly (TypeAlreadyExists dest' destTypes)
|
Cli.returnEarly (TypeAlreadyExists dest' destTypes)
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType)
|
Cli.stepAt description (BranchUtil.makeAddTypeName dest srcType)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
|
|
||||||
-- this implementation will happily produce name conflicts,
|
-- this implementation will happily produce name conflicts,
|
||||||
-- but will surface them in a normal diff at the end of the operation.
|
-- but will surface them in a normal diff at the end of the operation.
|
||||||
AliasManyI srcs dest' -> do
|
AliasManyI srcs dest' -> do
|
||||||
root0 <- Cli.getRootBranch0
|
root0 <- Cli.getCurrentProjectRoot0
|
||||||
currentBranch0 <- Cli.getCurrentBranch0
|
currentBranch0 <- Cli.getCurrentBranch0
|
||||||
destAbs <- Cli.resolvePath' dest'
|
destPP <- Cli.resolvePath' dest'
|
||||||
old <- Cli.getBranch0At destAbs
|
old <- Cli.getBranch0FromProjectPath destPP
|
||||||
description <- inputDescription input
|
description <- inputDescription input
|
||||||
let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs
|
let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs
|
||||||
Cli.stepManyAt description actions
|
Cli.stepManyAt destPP.branch description actions
|
||||||
new <- Cli.getBranch0At destAbs
|
new <- Cli.getBranch0FromProjectPath destPP
|
||||||
(ppe, diff) <- diffHelper old new
|
(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
|
when (not (null unknown)) do
|
||||||
Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown
|
Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown
|
||||||
where
|
where
|
||||||
@ -537,28 +471,29 @@ loop e = do
|
|||||||
Branch0 IO ->
|
Branch0 IO ->
|
||||||
Branch0 IO ->
|
Branch0 IO ->
|
||||||
Path.Absolute ->
|
Path.Absolute ->
|
||||||
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) ->
|
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) ->
|
||||||
Path.HQSplit ->
|
Path.HQSplit ->
|
||||||
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)])
|
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)])
|
||||||
go root0 currentBranch0 dest (missingSrcs, actions) hqsrc =
|
go root0 currentBranch0 dest (missingSrcs, actions) hqsrc =
|
||||||
let proposedDest :: Path.Split
|
let proposedDest :: Path.AbsSplit
|
||||||
proposedDest = second HQ'.toName hqProposedDest
|
proposedDest = second HQ'.toName hqProposedDest
|
||||||
hqProposedDest :: Path.HQSplit
|
hqProposedDest :: Path.HQSplitAbsolute
|
||||||
hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc
|
hqProposedDest = Path.resolve dest hqsrc
|
||||||
-- `Nothing` if src doesn't exist
|
-- `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,
|
doType = case ( BranchUtil.getType hqsrc currentBranch0,
|
||||||
BranchUtil.getType hqProposedDest root0
|
BranchUtil.getType (first Path.unabsolute hqProposedDest) root0
|
||||||
) of
|
) of
|
||||||
(null -> True, _) -> Nothing -- missing src
|
(null -> True, _) -> Nothing -- missing src
|
||||||
(rsrcs, existing) ->
|
(rsrcs, existing) ->
|
||||||
-- happy path
|
-- happy path
|
||||||
Just . map addAlias . toList $ Set.difference rsrcs existing
|
Just . map addAlias . toList $ Set.difference rsrcs existing
|
||||||
where
|
where
|
||||||
|
addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m)
|
||||||
addAlias r = BranchUtil.makeAddTypeName proposedDest r
|
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,
|
doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0,
|
||||||
BranchUtil.getTerm hqProposedDest root0
|
BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0
|
||||||
) of
|
) of
|
||||||
(null -> True, _) -> Nothing -- missing src
|
(null -> True, _) -> Nothing -- missing src
|
||||||
(rsrcs, existing) ->
|
(rsrcs, existing) ->
|
||||||
@ -575,15 +510,10 @@ loop e = do
|
|||||||
fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
|
fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
|
||||||
NamesI global query -> do
|
NamesI global query -> do
|
||||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||||
root <- Cli.getRootBranch
|
|
||||||
(names, pped) <-
|
(names, pped) <-
|
||||||
if global || any Name.isAbsolute query
|
if global
|
||||||
then do
|
then do
|
||||||
let root0 = Branch.head root
|
error "TODO: Implement names.global."
|
||||||
-- Use an absolutely qualified ppe for view.global
|
|
||||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
|
||||||
let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names)
|
|
||||||
pure (names, pped)
|
|
||||||
else do
|
else do
|
||||||
names <- Cli.currentNames
|
names <- Cli.currentNames
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||||
@ -613,11 +543,13 @@ loop e = do
|
|||||||
authorPath <- Cli.resolveSplit' authorPath'
|
authorPath <- Cli.resolveSplit' authorPath'
|
||||||
copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment)
|
copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment)
|
||||||
guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment)
|
guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment)
|
||||||
|
pb <- Cli.getCurrentProjectBranch
|
||||||
Cli.stepManyAt
|
Cli.stepManyAt
|
||||||
|
pb
|
||||||
description
|
description
|
||||||
[ BranchUtil.makeAddTermName (first Path.unabsolute authorPath) (d authorRef),
|
[ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef),
|
||||||
BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
|
BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef),
|
||||||
BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
|
BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef)
|
||||||
]
|
]
|
||||||
currentPath <- Cli.getCurrentPath
|
currentPath <- Cli.getCurrentPath
|
||||||
finalBranch <- Cli.getCurrentBranch0
|
finalBranch <- Cli.getCurrentBranch0
|
||||||
@ -637,51 +569,47 @@ loop e = do
|
|||||||
MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input
|
MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input
|
||||||
MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input
|
MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input
|
||||||
MoveAllI src' dest' -> do
|
MoveAllI src' dest' -> do
|
||||||
hasConfirmed <- confirmedCommand input
|
|
||||||
desc <- inputDescription input
|
desc <- inputDescription input
|
||||||
handleMoveAll hasConfirmed src' dest' desc
|
handleMoveAll src' dest' desc
|
||||||
DeleteI dtarget -> case dtarget of
|
DeleteI dtarget -> do
|
||||||
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
|
pp <- Cli.getCurrentProjectPath
|
||||||
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
|
let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg)
|
||||||
DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
|
let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg)
|
||||||
DeleteTarget'Namespace insistence Nothing -> do
|
case dtarget of
|
||||||
hasConfirmed <- confirmedCommand input
|
DeleteTarget'TermOrType doutput hqs -> do
|
||||||
if hasConfirmed || insistence == Force
|
delete input doutput getTerms getTypes hqs
|
||||||
then do
|
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs
|
||||||
description <- inputDescription input
|
DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs
|
||||||
Cli.updateRoot Branch.empty description
|
DeleteTarget'Namespace insistence p@(parentPath, childName) -> do
|
||||||
Cli.respond DeletedEverything
|
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
||||||
else Cli.respond DeleteEverythingConfirmation
|
description <- inputDescription input
|
||||||
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
|
let toDelete =
|
||||||
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
Names.prefix0
|
||||||
description <- inputDescription input
|
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
||||||
let toDelete =
|
(Branch.toNames (Branch.head branch))
|
||||||
Names.prefix0
|
afterDelete <- do
|
||||||
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
names <- Cli.currentNames
|
||||||
(Branch.toNames (Branch.head branch))
|
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
||||||
afterDelete <- do
|
case (null endangerments, insistence) of
|
||||||
names <- Cli.currentNames
|
(True, _) -> pure (Cli.respond Success)
|
||||||
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
(False, Force) -> do
|
||||||
case (null endangerments, insistence) of
|
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||||
(True, _) -> pure (Cli.respond Success)
|
pure do
|
||||||
(False, Force) -> do
|
Cli.respond Success
|
||||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
||||||
pure do
|
(False, Try) -> do
|
||||||
Cli.respond Success
|
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||||
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
||||||
(False, Try) -> do
|
Cli.returnEarlyWithoutOutput
|
||||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
parentPathAbs <- Cli.resolvePath parentPath
|
||||||
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
-- We have to modify the parent in order to also wipe out the history at the
|
||||||
Cli.returnEarlyWithoutOutput
|
-- child.
|
||||||
parentPathAbs <- Cli.resolvePath parentPath
|
Cli.updateAt description parentPathAbs \parentBranch ->
|
||||||
-- We have to modify the parent in order to also wipe out the history at the
|
parentBranch
|
||||||
-- child.
|
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
||||||
Cli.updateAt description parentPathAbs \parentBranch ->
|
afterDelete
|
||||||
parentBranch
|
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
||||||
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
DeleteTarget'Project name -> handleDeleteProject name
|
||||||
afterDelete
|
|
||||||
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
|
||||||
DeleteTarget'Project name -> handleDeleteProject name
|
|
||||||
DisplayI outputLoc namesToDisplay -> do
|
DisplayI outputLoc namesToDisplay -> do
|
||||||
traverse_ (displayI outputLoc) namesToDisplay
|
traverse_ (displayI outputLoc) namesToDisplay
|
||||||
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
|
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
|
||||||
@ -697,16 +625,15 @@ loop e = do
|
|||||||
let vars = Set.map Name.toVar requestedNames
|
let vars = Set.map Name.toVar requestedNames
|
||||||
uf <- Cli.expectLatestTypecheckedFile
|
uf <- Cli.expectLatestTypecheckedFile
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
currentNames <- Branch.toNames <$> Cli.getCurrentBranch0
|
currentNames <- Branch.toNames <$> Cli.getCurrentBranch0
|
||||||
let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
|
let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
|
||||||
let adds = SlurpResult.adds sr
|
let adds = SlurpResult.adds sr
|
||||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
|
||||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ 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
|
pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames
|
||||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||||
Cli.syncRoot description
|
|
||||||
SaveExecuteResultI resultName -> handleAddRun input resultName
|
SaveExecuteResultI resultName -> handleAddRun input resultName
|
||||||
PreviewAddI requestedNames -> do
|
PreviewAddI requestedNames -> do
|
||||||
(sourceName, _) <- Cli.expectLatestFile
|
(sourceName, _) <- Cli.expectLatestFile
|
||||||
@ -756,7 +683,8 @@ loop e = do
|
|||||||
let destPath = case opath of
|
let destPath = case opath of
|
||||||
Just path -> Path.resolve currentPath (Path.Relative path)
|
Just path -> Path.resolve currentPath (Path.Relative path)
|
||||||
Nothing -> currentPath `snoc` NameSegment.builtinSegment
|
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)
|
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
MergeIOBuiltinsI opath -> do
|
MergeIOBuiltinsI opath -> do
|
||||||
@ -783,7 +711,8 @@ loop e = do
|
|||||||
let destPath = case opath of
|
let destPath = case opath of
|
||||||
Just path -> Path.resolve currentPath (Path.Relative path)
|
Just path -> Path.resolve currentPath (Path.Relative path)
|
||||||
Nothing -> currentPath `snoc` NameSegment.builtinSegment
|
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)
|
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
|
PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
|
||||||
@ -805,20 +734,19 @@ loop e = do
|
|||||||
Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
|
Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
|
||||||
DebugTabCompletionI inputs -> do
|
DebugTabCompletionI inputs -> do
|
||||||
Cli.Env {authHTTPClient, codebase} <- ask
|
Cli.Env {authHTTPClient, codebase} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
|
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp
|
||||||
(_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
|
(_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
|
||||||
Cli.respond (DisplayDebugCompletions completions)
|
Cli.respond (DisplayDebugCompletions completions)
|
||||||
DebugFuzzyOptionsI command args -> do
|
DebugFuzzyOptionsI command args -> do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0
|
currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0
|
||||||
let projCtx = projectContextFromPath currentPath
|
|
||||||
case Map.lookup command InputPatterns.patternMap of
|
case Map.lookup command InputPatterns.patternMap of
|
||||||
Just (IP.InputPattern {args = argTypes}) -> do
|
Just (IP.InputPattern {args = argTypes}) -> do
|
||||||
zip argTypes args & Monoid.foldMapM \case
|
zip argTypes args & Monoid.foldMapM \case
|
||||||
((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do
|
((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))
|
Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results))
|
||||||
((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do
|
((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do
|
||||||
Cli.respond DebugFuzzyOptionsNoResolver
|
Cli.respond DebugFuzzyOptionsNoResolver
|
||||||
@ -888,13 +816,13 @@ loop e = do
|
|||||||
prettyRef renderR r = P.indentN 2 $ P.text (renderR r)
|
prettyRef renderR r = P.indentN 2 $ P.text (renderR r)
|
||||||
prettyDefn renderR (r, Foldable.toList -> names) =
|
prettyDefn renderR (r, Foldable.toList -> names) =
|
||||||
P.lines (P.text <$> if null names then ["<unnamed>"] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r
|
P.lines (P.text <$> if null names then ["<unnamed>"] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r
|
||||||
rootBranch <- Cli.getRootBranch
|
projectRoot <- Cli.getCurrentProjectRoot
|
||||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
|
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot]
|
||||||
DebugDumpNamespaceSimpleI -> do
|
DebugDumpNamespaceSimpleI -> do
|
||||||
rootBranch0 <- Cli.getRootBranch0
|
projectRootBranch0 <- Cli.getCurrentProjectRoot0
|
||||||
for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) ->
|
for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) ->
|
||||||
traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
|
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)
|
traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
|
||||||
DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
|
DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
|
||||||
DebugLSPFoldRangesI -> do
|
DebugLSPFoldRangesI -> do
|
||||||
@ -934,7 +862,7 @@ loop e = do
|
|||||||
Cli.respond $ PrintVersion ucmVersion
|
Cli.respond $ PrintVersion ucmVersion
|
||||||
ProjectRenameI name -> handleProjectRename name
|
ProjectRenameI name -> handleProjectRename name
|
||||||
ProjectSwitchI name -> projectSwitch name
|
ProjectSwitchI name -> projectSwitch name
|
||||||
ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name
|
ProjectCreateI tryDownloadingBase name -> void $ projectCreate tryDownloadingBase name
|
||||||
ProjectsI -> handleProjects
|
ProjectsI -> handleProjects
|
||||||
BranchI source name -> handleBranch source name
|
BranchI source name -> handleBranch source name
|
||||||
BranchRenameI name -> handleBranchRename name
|
BranchRenameI name -> handleBranchRename name
|
||||||
@ -954,8 +882,8 @@ inputDescription input =
|
|||||||
dest <- brp dest0
|
dest <- brp dest0
|
||||||
pure ("fork " <> src <> " " <> dest)
|
pure ("fork " <> src <> " " <> dest)
|
||||||
MergeLocalBranchI src0 dest0 mode -> do
|
MergeLocalBranchI src0 dest0 mode -> do
|
||||||
src <- looseCodeOrProjectToText src0
|
let src = into @Text src0
|
||||||
dest <- looseCodeOrProjectToText dest0
|
let dest = maybe "" (into @Text) dest0
|
||||||
let command =
|
let command =
|
||||||
case mode of
|
case mode of
|
||||||
Branch.RegularMerge -> "merge"
|
Branch.RegularMerge -> "merge"
|
||||||
@ -963,17 +891,17 @@ inputDescription input =
|
|||||||
pure (command <> " " <> src <> " " <> dest)
|
pure (command <> " " <> src <> " " <> dest)
|
||||||
ResetI hash tgt -> do
|
ResetI hash tgt -> do
|
||||||
hashTxt <- case hash of
|
hashTxt <- case hash of
|
||||||
This hash -> hp' hash
|
BranchAtSCH hash -> hp' $ Left hash
|
||||||
That pr -> pure (into @Text pr)
|
BranchAtPath pr -> pure $ into @Text pr
|
||||||
These hash _pr -> hp' hash
|
BranchAtProjectPath pp -> pure $ into @Text pp
|
||||||
tgt <- case tgt of
|
tgt <- case tgt of
|
||||||
Nothing -> pure ""
|
Nothing -> pure ""
|
||||||
Just tgt -> do
|
Just tgt -> do
|
||||||
tgt <- looseCodeOrProjectToText tgt
|
let tgtText = into @Text tgt
|
||||||
pure (" " <> tgt)
|
pure (" " <> tgtText)
|
||||||
pure ("reset " <> hashTxt <> tgt)
|
pure ("reset " <> hashTxt <> tgt)
|
||||||
ResetRootI src0 -> do
|
ResetRootI src0 -> do
|
||||||
src <- hp' src0
|
let src = into @Text src0
|
||||||
pure ("reset-root " <> src)
|
pure ("reset-root " <> src)
|
||||||
AliasTermI force src0 dest0 -> do
|
AliasTermI force src0 dest0 -> do
|
||||||
src <- hhqs' src0
|
src <- hhqs' src0
|
||||||
@ -1024,10 +952,10 @@ inputDescription input =
|
|||||||
thing <- traverse hqs' thing0
|
thing <- traverse hqs' thing0
|
||||||
pure ("delete.type.verbose " <> Text.intercalate " " thing)
|
pure ("delete.type.verbose " <> Text.intercalate " " thing)
|
||||||
DeleteTarget'Namespace Try opath0 -> do
|
DeleteTarget'Namespace Try opath0 -> do
|
||||||
opath <- ops opath0
|
opath <- ps opath0
|
||||||
pure ("delete.namespace " <> opath)
|
pure ("delete.namespace " <> opath)
|
||||||
DeleteTarget'Namespace Force opath0 -> do
|
DeleteTarget'Namespace Force opath0 -> do
|
||||||
opath <- ops opath0
|
opath <- ps opath0
|
||||||
pure ("delete.namespace.force " <> opath)
|
pure ("delete.namespace.force " <> opath)
|
||||||
DeleteTarget'ProjectBranch _ -> wat
|
DeleteTarget'ProjectBranch _ -> wat
|
||||||
DeleteTarget'Project _ -> wat
|
DeleteTarget'Project _ -> wat
|
||||||
@ -1129,9 +1057,7 @@ inputDescription input =
|
|||||||
p' :: Path' -> Cli Text
|
p' :: Path' -> Cli Text
|
||||||
p' = fmap tShow . Cli.resolvePath'
|
p' = fmap tShow . Cli.resolvePath'
|
||||||
brp :: BranchRelativePath -> Cli Text
|
brp :: BranchRelativePath -> Cli Text
|
||||||
brp = fmap from . ProjectUtils.resolveBranchRelativePath
|
brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath
|
||||||
ops :: Maybe Path.Split -> Cli Text
|
|
||||||
ops = maybe (pure ".") ps
|
|
||||||
wat = error $ show input ++ " is not expected to alter the branch"
|
wat = error $ show input ++ " is not expected to alter the branch"
|
||||||
hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
|
hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text
|
||||||
hhqs' = \case
|
hhqs' = \case
|
||||||
@ -1144,12 +1070,6 @@ inputDescription input =
|
|||||||
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
|
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
|
||||||
ps' = p' . Path.unsplit'
|
ps' = p' . Path.unsplit'
|
||||||
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 ::
|
handleFindI ::
|
||||||
Bool ->
|
Bool ->
|
||||||
@ -1162,7 +1082,7 @@ handleFindI isVerbose fscope ws input = do
|
|||||||
(pped, names, searchRoot, branch0) <- case fscope of
|
(pped, names, searchRoot, branch0) <- case fscope of
|
||||||
FindLocal p -> do
|
FindLocal p -> do
|
||||||
searchRoot <- Cli.resolvePath' p
|
searchRoot <- Cli.resolvePath' p
|
||||||
branch0 <- Cli.getBranch0At searchRoot
|
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||||
let names = Branch.toNames (Branch.withoutLib branch0)
|
let names = Branch.toNames (Branch.withoutLib branch0)
|
||||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||||
-- results may contain things in lib.
|
-- results may contain things in lib.
|
||||||
@ -1170,17 +1090,18 @@ handleFindI isVerbose fscope ws input = do
|
|||||||
pure (pped, names, Just p, branch0)
|
pure (pped, names, Just p, branch0)
|
||||||
FindLocalAndDeps p -> do
|
FindLocalAndDeps p -> do
|
||||||
searchRoot <- Cli.resolvePath' p
|
searchRoot <- Cli.resolvePath' p
|
||||||
branch0 <- Cli.getBranch0At searchRoot
|
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||||
let names = Branch.toNames (Branch.withoutTransitiveLibs branch0)
|
let names = Branch.toNames (Branch.withoutTransitiveLibs branch0)
|
||||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||||
-- results may contain things in lib.
|
-- results may contain things in lib.
|
||||||
pped <- Cli.currentPrettyPrintEnvDecl
|
pped <- Cli.currentPrettyPrintEnvDecl
|
||||||
pure (pped, names, Just p, branch0)
|
pure (pped, names, Just p, branch0)
|
||||||
FindGlobal -> do
|
FindGlobal -> do
|
||||||
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
|
-- TODO: Rewrite to be properly global again
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames globalNames
|
projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||||
|
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
|
||||||
currentBranch0 <- Cli.getCurrentBranch0
|
currentBranch0 <- Cli.getCurrentBranch0
|
||||||
pure (pped, globalNames, Nothing, currentBranch0)
|
pure (pped, projectRootNames, Nothing, currentBranch0)
|
||||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||||
let getResults :: Names -> Cli [SearchResult]
|
let getResults :: Names -> Cli [SearchResult]
|
||||||
getResults names =
|
getResults names =
|
||||||
@ -1316,16 +1237,16 @@ handleShowDefinition outputLoc showDefinitionScope query = do
|
|||||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||||
let hasAbsoluteQuery = any (any Name.isAbsolute) query
|
let hasAbsoluteQuery = any (any Name.isAbsolute) query
|
||||||
(names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of
|
(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.
|
-- TODO: We should instead print each definition using the names from its project-branch root.
|
||||||
(True, _) -> do
|
(True, _) -> do
|
||||||
root <- Cli.getRootBranch
|
root <- Cli.getCurrentProjectRoot
|
||||||
let root0 = Branch.head root
|
let root0 = Branch.head root
|
||||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||||
pure (names, pped)
|
pure (names, pped)
|
||||||
(_, ShowDefinitionGlobal) -> do
|
(_, ShowDefinitionGlobal) -> do
|
||||||
root <- Cli.getRootBranch
|
-- TODO: Maybe rewrite to be properly global
|
||||||
|
root <- Cli.getCurrentProjectRoot
|
||||||
let root0 = Branch.head root
|
let root0 = Branch.head root
|
||||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||||
@ -1410,11 +1331,6 @@ doDisplay outputLoc names tm = do
|
|||||||
else do
|
else do
|
||||||
writeUtf8 filePath txt
|
writeUtf8 filePath txt
|
||||||
|
|
||||||
confirmedCommand :: Input -> Cli Bool
|
|
||||||
confirmedCommand i = do
|
|
||||||
loopState <- State.get
|
|
||||||
pure $ Just i == (loopState ^. #lastInput)
|
|
||||||
|
|
||||||
-- return `name` and `name.<everything>...`
|
-- return `name` and `name.<everything>...`
|
||||||
_searchBranchPrefix :: Branch m -> Name -> [SearchResult]
|
_searchBranchPrefix :: Branch m -> Name -> [SearchResult]
|
||||||
_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
|
_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of
|
||||||
@ -1527,8 +1443,8 @@ delete input doutput getTerms getTypes hqs' = do
|
|||||||
traverse
|
traverse
|
||||||
( \hq -> do
|
( \hq -> do
|
||||||
absolute <- Cli.resolveSplit' hq
|
absolute <- Cli.resolveSplit' hq
|
||||||
types <- getTypes absolute
|
types <- getTypes (first PP.absPath absolute)
|
||||||
terms <- getTerms absolute
|
terms <- getTerms (first PP.absPath absolute)
|
||||||
return (hq, types, terms)
|
return (hq, types, terms)
|
||||||
)
|
)
|
||||||
hqs'
|
hqs'
|
||||||
@ -1547,25 +1463,20 @@ checkDeletes :: [(Path.HQSplit', Set Reference, Set Referent)] -> DeleteOutput -
|
|||||||
checkDeletes typesTermsTuples doutput inputs = do
|
checkDeletes typesTermsTuples doutput inputs = do
|
||||||
let toSplitName ::
|
let toSplitName ::
|
||||||
(Path.HQSplit', Set Reference, Set Referent) ->
|
(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
|
toSplitName hq = do
|
||||||
-- __FIXME__: `resolvedPath` is ostensiby `Absolute`, but the paths here must be `Relative` below
|
(pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||||
resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
let resolvedSplit = (pp.absPath, ns)
|
||||||
return
|
return
|
||||||
( resolvedPath,
|
(resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3)
|
||||||
Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
|
|
||||||
hq ^. _2,
|
|
||||||
hq ^. _3
|
|
||||||
)
|
|
||||||
-- get the splits and names with terms and types
|
-- get the splits and names with terms and types
|
||||||
splitsNames <- traverse toSplitName typesTermsTuples
|
splitsNames <- traverse toSplitName typesTermsTuples
|
||||||
let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref
|
let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref
|
||||||
toRel setRef name = R.fromList (fmap (name,) (toList setRef))
|
toRel setRef name = R.fromList (fmap (name,) (toList setRef))
|
||||||
let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames
|
let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames
|
||||||
-- make sure endangered is compeletely contained in paths
|
-- make sure endangered is compeletely contained in paths
|
||||||
-- TODO: We should just check for endangerments from the project root, not the
|
projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||||
-- global root!
|
|
||||||
rootNames <- Branch.toNames <$> Cli.getRootBranch0
|
|
||||||
-- get only once for the entire deletion set
|
-- get only once for the entire deletion set
|
||||||
let allTermsToDelete :: Set LabeledDependency
|
let allTermsToDelete :: Set LabeledDependency
|
||||||
allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
|
allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
|
||||||
@ -1574,7 +1485,7 @@ checkDeletes typesTermsTuples doutput inputs = do
|
|||||||
Cli.runTransaction $
|
Cli.runTransaction $
|
||||||
traverse
|
traverse
|
||||||
( \targetToDelete ->
|
( \targetToDelete ->
|
||||||
getEndangeredDependents targetToDelete (allTermsToDelete) rootNames
|
getEndangeredDependents targetToDelete (allTermsToDelete) projectNames
|
||||||
)
|
)
|
||||||
toDelete
|
toDelete
|
||||||
-- If the overall dependency map is not completely empty, abort deletion
|
-- If the overall dependency map is not completely empty, abort deletion
|
||||||
@ -1589,7 +1500,8 @@ checkDeletes typesTermsTuples doutput inputs = do
|
|||||||
)
|
)
|
||||||
before <- Cli.getCurrentBranch0
|
before <- Cli.getCurrentBranch0
|
||||||
description <- inputDescription inputs
|
description <- inputDescription inputs
|
||||||
Cli.stepManyAt description deleteTypesTerms
|
pb <- Cli.getCurrentProjectBranch
|
||||||
|
Cli.stepManyAt pb description deleteTypesTerms
|
||||||
case doutput of
|
case doutput of
|
||||||
DeleteOutput'Diff -> do
|
DeleteOutput'Diff -> do
|
||||||
after <- Cli.getCurrentBranch0
|
after <- Cli.getCurrentBranch0
|
||||||
@ -1598,7 +1510,7 @@ checkDeletes typesTermsTuples doutput inputs = do
|
|||||||
DeleteOutput'NoDiff -> do
|
DeleteOutput'NoDiff -> do
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
else do
|
else do
|
||||||
ppeDecl <- Cli.prettyPrintEnvDeclFromNames rootNames
|
ppeDecl <- Cli.prettyPrintEnvDeclFromNames projectNames
|
||||||
let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions
|
let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions
|
||||||
Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs)
|
Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs)
|
||||||
|
|
||||||
@ -1659,7 +1571,7 @@ displayI outputLoc hq = do
|
|||||||
(names, pped) <-
|
(names, pped) <-
|
||||||
if useRoot
|
if useRoot
|
||||||
then do
|
then do
|
||||||
root <- Cli.getRootBranch
|
root <- Cli.getCurrentProjectRoot
|
||||||
let root0 = Branch.head root
|
let root0 = Branch.head root
|
||||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
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)])])
|
(UF.watchComponents uf <> [(WK.RegularWatch, [(v2, ann, Term.var a v, ty)])])
|
||||||
)
|
)
|
||||||
_ -> addWatch watchName Nothing
|
_ -> 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.Output (Output (NoLastRunResult, SaveTermNameConflict, SlurpOutput))
|
||||||
import Unison.Codebase.Editor.Slurp qualified as Slurp
|
import Unison.Codebase.Editor.Slurp qualified as Slurp
|
||||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
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.InputPattern qualified as InputPattern
|
||||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
@ -37,16 +36,16 @@ handleAddRun input resultName = do
|
|||||||
let resultVar = Name.toVar resultName
|
let resultVar = Name.toVar resultName
|
||||||
uf <- addSavedTermToUnisonFile resultName
|
uf <- addSavedTermToUnisonFile resultName
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
currentNames <- Cli.currentNames
|
currentNames <- Cli.currentNames
|
||||||
let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
|
let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
|
||||||
let adds = SlurpResult.adds sr
|
let adds = SlurpResult.adds sr
|
||||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
|
||||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ 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
|
let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
|
pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
|
||||||
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||||
Cli.syncRoot (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName)
|
|
||||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||||
|
|
||||||
addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann)
|
addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann)
|
||||||
|
@ -1,44 +1,42 @@
|
|||||||
-- | @branch@ input handler
|
-- | @branch@ input handler
|
||||||
module Unison.Codebase.Editor.HandleInput.Branch
|
module Unison.Codebase.Editor.HandleInput.Branch
|
||||||
( handleBranch,
|
( CreateFrom (..),
|
||||||
CreateFrom (..),
|
handleBranch,
|
||||||
doCreateBranch,
|
createBranch,
|
||||||
doCreateBranch',
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.These (These (..))
|
import Control.Monad.Reader
|
||||||
import Data.UUID.V4 qualified as UUID
|
import Data.UUID.V4 qualified as UUID
|
||||||
import U.Codebase.Sqlite.DbId
|
import U.Codebase.Sqlite.DbId
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
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.ProjectBranch qualified as Sqlite
|
||||||
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch (Branch)
|
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.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
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.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
|
|
||||||
data CreateFrom
|
data CreateFrom
|
||||||
= CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
= CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
|
||||||
| CreateFrom'LooseCode Path.Absolute
|
| CreateFrom'ParentBranch Sqlite.ProjectBranch
|
||||||
|
| CreateFrom'Namespace (Branch IO)
|
||||||
| CreateFrom'Nothingness
|
| CreateFrom'Nothingness
|
||||||
|
|
||||||
-- | Create a new project branch from an existing project branch or namespace.
|
-- | Create a new project branch from an existing project branch or namespace.
|
||||||
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||||
handleBranch sourceI projectAndBranchNames0 = do
|
handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do
|
||||||
projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <-
|
|
||||||
case projectAndBranchNames0 of
|
|
||||||
ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName)
|
|
||||||
ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName)
|
|
||||||
|
|
||||||
-- You can only create release branches with `branch.clone`
|
-- 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
|
-- 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)
|
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
|
||||||
ProjectBranchNameKind'NothingSpecial -> pure ()
|
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.
|
-- Compute what we should create the branch from.
|
||||||
createFrom <-
|
maySrcProjectAndBranch <-
|
||||||
case sourceI of
|
case sourceI of
|
||||||
Input.BranchSourceI'CurrentContext ->
|
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
|
||||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
Input.BranchSourceI'Empty -> pure Nothing
|
||||||
Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath
|
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
||||||
Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch)
|
pp <- Cli.getCurrentProjectPath
|
||||||
Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness
|
Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
|
||||||
Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do
|
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath))
|
|
||||||
Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) ->
|
|
||||||
fmap CreateFrom'Branch do
|
|
||||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
|
||||||
case sourceBranch of
|
|
||||||
ProjectAndBranch Nothing b -> That b
|
|
||||||
ProjectAndBranch (Just p) b -> These p b
|
|
||||||
-- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a
|
|
||||||
-- branch from a relative one-segment namespace.
|
|
||||||
--
|
|
||||||
-- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they
|
|
||||||
-- really meant create a branch from that namespace.
|
|
||||||
Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) ->
|
|
||||||
fmap CreateFrom'Branch do
|
|
||||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
|
||||||
case sourceBranch of
|
|
||||||
ProjectAndBranch Nothing b -> That b
|
|
||||||
ProjectAndBranch (Just p) b -> These p b
|
|
||||||
|
|
||||||
project <-
|
case maySrcProjectAndBranch of
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Just srcProjectAndBranch -> do
|
||||||
Queries.loadProjectByName projectName & onNothingM do
|
let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name))
|
||||||
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
|
void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName)
|
||||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
Nothing -> do
|
||||||
|
let description = "Empty branch created"
|
||||||
_ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
|
void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName)
|
||||||
|
|
||||||
Cli.respond $
|
Cli.respond $
|
||||||
Output.CreatedProjectBranch
|
Output.CreatedProjectBranch
|
||||||
( case createFrom of
|
( case maySrcProjectAndBranch of
|
||||||
CreateFrom'Branch sourceBranch ->
|
Just sourceBranch ->
|
||||||
if sourceBranch ^. #project . #projectId == project ^. #projectId
|
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
|
||||||
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
||||||
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
||||||
CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path
|
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
||||||
CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness
|
|
||||||
)
|
)
|
||||||
projectAndBranchNames
|
(projectAndBranchNames & #project .~ projectName)
|
||||||
|
|
||||||
-- | @doCreateBranch createFrom project branch description@:
|
-- | @createBranchFromParent createFrom project branch description@:
|
||||||
--
|
--
|
||||||
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@)
|
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@).
|
||||||
-- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog.
|
-- 3. Switches to the new branch.
|
||||||
-- 3. cds to the new branch in the root namespace.
|
|
||||||
--
|
--
|
||||||
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
|
-- 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.
|
-- @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.
|
-- Returns the branch id of the newly-created branch.
|
||||||
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
|
createBranch ::
|
||||||
doCreateBranch createFrom project newBranchName description = do
|
Text ->
|
||||||
sourceNamespaceObject <-
|
CreateFrom ->
|
||||||
case createFrom of
|
|
||||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do
|
|
||||||
let sourceProjectId = sourceBranch ^. #projectId
|
|
||||||
let sourceBranchId = sourceBranch ^. #branchId
|
|
||||||
Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId))
|
|
||||||
CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath
|
|
||||||
CreateFrom'Nothingness -> pure Branch.empty
|
|
||||||
let parentBranchId =
|
|
||||||
case createFrom of
|
|
||||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch)
|
|
||||||
| sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId
|
|
||||||
_ -> Nothing
|
|
||||||
(newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description
|
|
||||||
pure newBranchId
|
|
||||||
|
|
||||||
doCreateBranch' ::
|
|
||||||
Branch IO ->
|
|
||||||
Maybe ProjectBranchId ->
|
|
||||||
Sqlite.Project ->
|
Sqlite.Project ->
|
||||||
Sqlite.Transaction ProjectBranchName ->
|
Sqlite.Transaction ProjectBranchName ->
|
||||||
Text ->
|
|
||||||
Cli (ProjectBranchId, ProjectBranchName)
|
Cli (ProjectBranchId, ProjectBranchName)
|
||||||
doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do
|
createBranch description createFrom project getNewBranchName = do
|
||||||
let projectId = project ^. #projectId
|
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
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
newBranchName <- getNewBranchName
|
newBranchName <- getNewBranchName
|
||||||
Queries.projectBranchExistsByName projectId newBranchName >>= \case
|
Queries.projectBranchExistsByName projectId newBranchName >>= \case
|
||||||
@ -146,16 +131,15 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de
|
|||||||
-- `bar`, so the fork will succeed.
|
-- `bar`, so the fork will succeed.
|
||||||
newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||||
Queries.insertProjectBranch
|
Queries.insertProjectBranch
|
||||||
|
description
|
||||||
|
newBranchCausalHashId
|
||||||
Sqlite.ProjectBranch
|
Sqlite.ProjectBranch
|
||||||
{ projectId,
|
{ projectId,
|
||||||
branchId = newBranchId,
|
branchId = newBranchId,
|
||||||
name = newBranchName,
|
name = newBranchName,
|
||||||
parentBranchId = parentBranchId
|
parentBranchId = mayParentBranchId
|
||||||
}
|
}
|
||||||
Queries.setMostRecentBranch projectId newBranchId
|
pure (newBranchName, newBranchId)
|
||||||
pure (newBranchId, newBranchName)
|
|
||||||
|
|
||||||
let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
|
Cli.switchProject (ProjectAndBranch projectId newBranchId)
|
||||||
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
|
|
||||||
Cli.cd newBranchPath
|
|
||||||
pure (newBranchId, newBranchName)
|
pure (newBranchId, newBranchName)
|
||||||
|
@ -7,14 +7,15 @@ where
|
|||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Editor.Output qualified as Output
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName)
|
||||||
|
|
||||||
handleBranchRename :: ProjectBranchName -> Cli ()
|
handleBranchRename :: ProjectBranchName -> Cli ()
|
||||||
handleBranchRename newBranchName = do
|
handleBranchRename newBranchName = do
|
||||||
(ProjectAndBranch project branch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
PP.ProjectPath project branch _path <- Cli.getCurrentProjectPath
|
||||||
|
|
||||||
case classifyProjectBranchName newBranchName of
|
case classifyProjectBranchName newBranchName of
|
||||||
ProjectBranchNameKind'Contributor {} -> pure ()
|
ProjectBranchNameKind'Contributor {} -> pure ()
|
||||||
|
@ -10,14 +10,14 @@ import Network.URI (URI)
|
|||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Editor.Output qualified as Output
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectBranchName, ProjectName)
|
||||||
|
|
||||||
handleBranches :: Maybe ProjectName -> Cli ()
|
handleBranches :: Maybe ProjectName -> Cli ()
|
||||||
handleBranches maybeProjectName = do
|
handleBranches maybeProjectName = do
|
||||||
maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds
|
pp <- Cli.getCurrentProjectPath
|
||||||
(project, branches) <-
|
(project, branches) <-
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
project <-
|
project <-
|
||||||
@ -26,8 +26,7 @@ handleBranches maybeProjectName = do
|
|||||||
Queries.loadProjectByName projectName & onNothingM do
|
Queries.loadProjectByName projectName & onNothingM do
|
||||||
rollback (Output.LocalProjectDoesntExist projectName)
|
rollback (Output.LocalProjectDoesntExist projectName)
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch)
|
pure (pp ^. #project)
|
||||||
Queries.expectProject projectId
|
|
||||||
branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId)
|
branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId)
|
||||||
pure (project, branches)
|
pure (project, branches)
|
||||||
Cli.respondNumbered (Output.ListBranches (project ^. #name) (f 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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||||
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
|
|||||||
|
|
||||||
handleCommitMerge :: Cli ()
|
handleCommitMerge :: Cli ()
|
||||||
handleCommitMerge = do
|
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`),
|
-- 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.
|
-- and switch to the parent.
|
||||||
@ -33,9 +34,8 @@ handleCommitMerge = do
|
|||||||
parentBranch <-
|
parentBranch <-
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId
|
parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId
|
||||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
|
||||||
pure parentBranch
|
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
|
-- 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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||||
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
|
|||||||
|
|
||||||
handleCommitUpgrade :: Cli ()
|
handleCommitUpgrade :: Cli ()
|
||||||
handleCommitUpgrade = do
|
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`),
|
-- 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.
|
-- and switch to the parent.
|
||||||
@ -33,9 +34,8 @@ handleCommitUpgrade = do
|
|||||||
parentBranch <-
|
parentBranch <-
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
|
parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
|
||||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
|
||||||
pure parentBranch
|
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
|
-- Merge the upgrade branch into the parent
|
||||||
|
|
||||||
|
@ -5,8 +5,7 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Map.Strict qualified as Map
|
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||||
import Data.These (These (..))
|
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
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.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Editor.HandleInput.ProjectCreate
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||||
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Witch (unsafeFrom)
|
import Witch (unsafeFrom)
|
||||||
|
|
||||||
-- | Delete a project branch.
|
-- | Delete a project branch.
|
||||||
@ -27,44 +27,50 @@ import Witch (unsafeFrom)
|
|||||||
-- project.
|
-- project.
|
||||||
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||||
handleDeleteBranch projectAndBranchNamesToDelete = do
|
handleDeleteBranch projectAndBranchNamesToDelete = do
|
||||||
projectAndBranchToDelete <-
|
ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath
|
||||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
projectAndBranchToDelete@(ProjectAndBranch _projectToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just)
|
||||||
case projectAndBranchNamesToDelete of
|
|
||||||
ProjectAndBranch Nothing branch -> That branch
|
|
||||||
ProjectAndBranch (Just project) branch -> These project branch
|
|
||||||
|
|
||||||
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
|
|
||||||
|
|
||||||
doDeleteProjectBranch projectAndBranchToDelete
|
|
||||||
|
|
||||||
-- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
|
-- 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
|
-- 1. cd to parent branch, if it exists
|
||||||
-- 2. cd to "main", if it exists
|
-- 2. cd to "main", if it exists
|
||||||
-- 3. cd to loose code path `.`
|
-- 3. Any other branch in the codebase
|
||||||
whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
|
-- 4. Create a dummy project and go to /main
|
||||||
when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
|
when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do
|
||||||
newPath <-
|
mayNextLocation <-
|
||||||
case projectAndBranchToDelete.branch.parentBranchId of
|
Cli.runTransaction . runMaybeT $
|
||||||
Nothing ->
|
asum
|
||||||
let loadMain =
|
[ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId),
|
||||||
Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
|
findMainBranchInProject (currentProject ^. #projectId),
|
||||||
in Cli.runTransaction loadMain <&> \case
|
findAnyBranchInProject (currentProject ^. #projectId),
|
||||||
Nothing -> Path.Absolute Path.empty
|
findAnyBranchInCodebase,
|
||||||
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
|
createDummyProject
|
||||||
Just parentBranchId ->
|
]
|
||||||
pure $
|
nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing
|
||||||
ProjectUtils.projectBranchPath
|
Cli.switchProject nextLoc
|
||||||
(ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
|
doDeleteProjectBranch projectAndBranchToDelete
|
||||||
Cli.cd newPath
|
where
|
||||||
|
parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||||
|
parentBranch projectId mayParentBranchId = do
|
||||||
|
parentBranchId <- hoistMaybe mayParentBranchId
|
||||||
|
pure (ProjectAndBranch projectId parentBranchId)
|
||||||
|
findMainBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||||
|
findMainBranchInProject projectId = do
|
||||||
|
branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")
|
||||||
|
pure (ProjectAndBranch projectId (branch ^. #branchId))
|
||||||
|
|
||||||
|
findAnyBranchInProject :: ProjectId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||||
|
findAnyBranchInProject projectId = do
|
||||||
|
(someBranchId, _) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
||||||
|
pure (ProjectAndBranch projectId someBranchId)
|
||||||
|
findAnyBranchInCodebase :: MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||||
|
findAnyBranchInCodebase = do
|
||||||
|
(_, pbIds) <- MaybeT . fmap listToMaybe $ Queries.loadAllProjectBranchNamePairs
|
||||||
|
pure pbIds
|
||||||
|
createDummyProject = error "TODO: create new branch or project if we delete the last branch you're on."
|
||||||
|
|
||||||
-- | Delete a project branch and record an entry in the reflog.
|
-- | Delete a project branch and record an entry in the reflog.
|
||||||
doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
|
doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
|
||||||
doDeleteProjectBranch projectAndBranch = do
|
doDeleteProjectBranch projectAndBranch = do
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId
|
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 (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
import Unison.Project (ProjectName)
|
||||||
|
|
||||||
-- | Delete a project
|
-- | Delete a project
|
||||||
handleDeleteProject :: ProjectName -> Cli ()
|
handleDeleteProject :: ProjectName -> Cli ()
|
||||||
handleDeleteProject projectName = do
|
handleDeleteProject projectName = do
|
||||||
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
|
ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath
|
||||||
|
|
||||||
deletedProject <-
|
deletedProject <-
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
@ -29,14 +28,8 @@ handleDeleteProject projectName = do
|
|||||||
Queries.deleteProject (project ^. #projectId)
|
Queries.deleteProject (project ^. #projectId)
|
||||||
pure project
|
pure project
|
||||||
|
|
||||||
let projectId = deletedProject ^. #projectId
|
-- If the user is on the project that they're deleting, we create a new project to switch
|
||||||
|
-- to.
|
||||||
Cli.updateAt
|
when (((==) `on` (view #projectId)) deletedProject currentProject) do
|
||||||
("delete.project " <> into @Text projectName)
|
nextLoc <- projectCreate False Nothing
|
||||||
(ProjectUtils.projectPath projectId)
|
Cli.switchProject nextLoc
|
||||||
(const Branch.empty)
|
|
||||||
|
|
||||||
-- If the user is on the project that they're deleting, we cd to the root path
|
|
||||||
whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) ->
|
|
||||||
when (on (==) (view #projectId) deletedProject currentProject) do
|
|
||||||
Cli.cd (Path.Absolute Path.empty)
|
|
||||||
|
@ -10,8 +10,6 @@ import Data.Map.Strict qualified as Map
|
|||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import Data.Text qualified as Text
|
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.DownloadUtils
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Branch qualified as Branch
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Core.Project (ProjectBranchName)
|
import Unison.Core.Project (ProjectBranchName)
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
import Unison.NameSegment qualified as NameSegment (libSegment)
|
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 :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli ()
|
||||||
handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do
|
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
|
libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName
|
||||||
|
|
||||||
libdepBranchName <-
|
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".
|
-- 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
|
libdepNameSegment :: NameSegment <- do
|
||||||
currentBranchObject <- Cli.getBranch0At currentProjectBranchPath
|
currentBranchObject <- Cli.getCurrentProjectRoot0
|
||||||
pure $
|
pure $
|
||||||
fresh
|
fresh
|
||||||
(\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText)
|
(\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText)
|
||||||
@ -90,13 +81,12 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran
|
|||||||
(makeDependencyName libdepProjectName libdepBranchName)
|
(makeDependencyName libdepProjectName libdepBranchName)
|
||||||
|
|
||||||
let libdepPath :: Path.Absolute
|
let libdepPath :: Path.Absolute
|
||||||
libdepPath =
|
libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment]
|
||||||
Path.resolve
|
|
||||||
currentProjectBranchPath
|
|
||||||
(Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment]))
|
|
||||||
|
|
||||||
let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames
|
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)
|
Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment)
|
||||||
|
|
||||||
|
@ -78,7 +78,7 @@ loadUnisonFile sourceName text = do
|
|||||||
Text ->
|
Text ->
|
||||||
Cli (TypecheckedUnisonFile Symbol Ann)
|
Cli (TypecheckedUnisonFile Symbol Ann)
|
||||||
withFile names sourceName text = do
|
withFile names sourceName text = do
|
||||||
currentPath <- Cli.getCurrentPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
State.modify' \loopState ->
|
State.modify' \loopState ->
|
||||||
loopState
|
loopState
|
||||||
& #latestFile .~ Just (Text.unpack sourceName, False)
|
& #latestFile .~ Just (Text.unpack sourceName, False)
|
||||||
@ -88,7 +88,7 @@ loadUnisonFile sourceName text = do
|
|||||||
let parsingEnv =
|
let parsingEnv =
|
||||||
Parser.ParsingEnv
|
Parser.ParsingEnv
|
||||||
{ uniqueNames = uniqueName,
|
{ uniqueNames = uniqueName,
|
||||||
uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath,
|
uniqueTypeGuid = Cli.loadUniqueTypeGuid pp,
|
||||||
names
|
names
|
||||||
}
|
}
|
||||||
unisonFile <-
|
unisonFile <-
|
||||||
|
@ -8,9 +8,11 @@ import Unison.Cli.Monad (Cli)
|
|||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.PrettyPrintUtils 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.Output
|
||||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||||
import Unison.Codebase.Path (Path')
|
import Unison.Codebase.Path (Path')
|
||||||
|
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||||
import Unison.Server.Backend qualified as Backend
|
import Unison.Server.Backend qualified as Backend
|
||||||
@ -18,9 +20,9 @@ import Unison.Server.Backend qualified as Backend
|
|||||||
handleLs :: Path' -> Cli ()
|
handleLs :: Path' -> Cli ()
|
||||||
handleLs pathArg = do
|
handleLs pathArg = do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
|
pp <- Cli.resolvePath' pathArg
|
||||||
pathArgAbs <- Cli.resolvePath' pathArg
|
projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch
|
||||||
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
|
entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath))
|
||||||
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
||||||
pped <- Cli.currentPrettyPrintEnvDecl
|
pped <- Cli.currentPrettyPrintEnvDecl
|
||||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
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.Editor.RemoteRepo (ReadShareLooseCode (..))
|
||||||
import Unison.Codebase.Path (Path)
|
import Unison.Codebase.Path (Path)
|
||||||
import Unison.Codebase.Path qualified as 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.Branch.Cache (newBranchCache)
|
||||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
|
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 (EitherWayI (..))
|
||||||
import Unison.Merge.EitherWayI qualified as EitherWayI
|
import Unison.Merge.EitherWayI qualified as EitherWayI
|
||||||
import Unison.Merge.Libdeps qualified as Merge
|
import Unison.Merge.Libdeps qualified as Merge
|
||||||
|
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
|
||||||
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
|
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
|
||||||
import Unison.Merge.Synhashed (Synhashed (..))
|
import Unison.Merge.Synhashed (Synhashed (..))
|
||||||
import Unison.Merge.Synhashed qualified as Synhashed
|
import Unison.Merge.Synhashed qualified as Synhashed
|
||||||
@ -138,12 +141,12 @@ import Unison.Util.SyntaxText (SyntaxText')
|
|||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import Witch (unsafeFrom)
|
import Witch (unsafeFrom)
|
||||||
import Prelude hiding (unzip, zip, zipWith)
|
import Prelude hiding (unzip, zip, zipWith)
|
||||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
|
|
||||||
|
|
||||||
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||||
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
|
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
|
||||||
-- Assert that Alice (us) is on a project branch, and grab the causal hash.
|
-- 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
|
-- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch
|
||||||
-- name, and causal hash.
|
-- name, and causal hash.
|
||||||
@ -193,7 +196,6 @@ doMerge info = do
|
|||||||
then realDebugFunctions
|
then realDebugFunctions
|
||||||
else fakeDebugFunctions
|
else fakeDebugFunctions
|
||||||
|
|
||||||
let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch)
|
|
||||||
let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
|
let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
|
||||||
let mergeSource = MergeSourceOrTarget'Source info.bob.source
|
let mergeSource = MergeSourceOrTarget'Source info.bob.source
|
||||||
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
|
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.
|
-- 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
|
when (info.lca.causalHash == Just info.alice.causalHash) do
|
||||||
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
|
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)
|
done (Output.MergeSuccessFastForward mergeSourceAndTarget)
|
||||||
|
|
||||||
-- Create a bunch of cached database lookup functions
|
-- Create a bunch of cached database lookup functions
|
||||||
@ -397,7 +399,7 @@ doMerge info = do
|
|||||||
in if thisMergeHasConflicts
|
in if thisMergeHasConflicts
|
||||||
then pure Nothing
|
then pure Nothing
|
||||||
else do
|
else do
|
||||||
currentPath <- Cli.getCurrentPath
|
currentPath <- Cli.getCurrentProjectPath
|
||||||
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
||||||
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
||||||
|
|
||||||
@ -408,12 +410,12 @@ doMerge info = do
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
Cli.Env {writeSource} <- ask
|
Cli.Env {writeSource} <- ask
|
||||||
(_temporaryBranchId, temporaryBranchName) <-
|
(_temporaryBranchId, temporaryBranchName) <-
|
||||||
HandleInput.Branch.doCreateBranch'
|
HandleInput.Branch.createBranch
|
||||||
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
info.description
|
||||||
(Just info.alice.projectAndBranch.branch.branchId)
|
(HandleInput.Branch.CreateFrom'NamespaceWithParent info.alice.projectAndBranch.branch (Branch.mergeNode stageOneBranch parents.alice parents.bob))
|
||||||
info.alice.projectAndBranch.project
|
info.alice.projectAndBranch.project
|
||||||
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||||
info.description
|
|
||||||
scratchFilePath <-
|
scratchFilePath <-
|
||||||
Cli.getLatestFile <&> \case
|
Cli.getLatestFile <&> \case
|
||||||
Nothing -> "scratch.u"
|
Nothing -> "scratch.u"
|
||||||
@ -423,11 +425,10 @@ doMerge info = do
|
|||||||
Just tuf -> do
|
Just tuf -> do
|
||||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||||
_ <-
|
Cli.updateProjectBranchRoot_
|
||||||
Cli.updateAt
|
info.alice.projectAndBranch.branch
|
||||||
info.description
|
info.description
|
||||||
alicePath
|
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
|
||||||
pure (Output.MergeSuccess mergeSourceAndTarget)
|
pure (Output.MergeSuccess mergeSourceAndTarget)
|
||||||
|
|
||||||
Cli.respond finalOutput
|
Cli.respond finalOutput
|
||||||
@ -436,8 +437,8 @@ doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
|
|||||||
doMergeLocalBranch branches = do
|
doMergeLocalBranch branches = do
|
||||||
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
|
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
|
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch)
|
||||||
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
|
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch)
|
||||||
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
|
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
|
||||||
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
|
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
|
||||||
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
|
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
|
||||||
|
@ -11,9 +11,9 @@ import Unison.Codebase.Path qualified as Path
|
|||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
|
|
||||||
handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli ()
|
handleMoveAll :: Path.Path' -> Path.Path' -> Text -> Cli ()
|
||||||
handleMoveAll hasConfirmed src' dest' description = do
|
handleMoveAll src' dest' description = do
|
||||||
moveBranchFunc <- moveBranchFunc hasConfirmed src' dest'
|
moveBranchFunc <- moveBranchFunc src' dest'
|
||||||
moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
|
moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
|
||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just (fmap HQ'.NameOnly -> src, dest) -> do
|
Just (fmap HQ'.NameOnly -> src, dest) -> do
|
||||||
@ -23,5 +23,6 @@ handleMoveAll hasConfirmed src' dest' description = do
|
|||||||
case (moveBranchFunc, moveTermTypeSteps) of
|
case (moveBranchFunc, moveTermTypeSteps) of
|
||||||
(Nothing, []) -> Cli.respond (Output.MoveNothingFound src')
|
(Nothing, []) -> Cli.respond (Output.MoveNothingFound src')
|
||||||
(mupdates, steps) -> do
|
(mupdates, steps) -> do
|
||||||
Cli.updateAndStepAt description (maybeToList mupdates) steps
|
pp <- Cli.getCurrentProjectPath
|
||||||
|
Cli.updateAndStepAt description (pp ^. #branch) (maybeToList mupdates) steps
|
||||||
Cli.respond Output.Success
|
Cli.respond Output.Success
|
||||||
|
@ -7,17 +7,18 @@ import Unison.Codebase.Branch (Branch)
|
|||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Editor.Output (Output (..))
|
import Unison.Codebase.Editor.Output (Output (..))
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
|
|
||||||
moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
|
-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if
|
||||||
moveBranchFunc hasConfirmed src' dest' = do
|
-- needed.
|
||||||
srcAbs <- Cli.resolvePath' src'
|
moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
|
||||||
destAbs <- Cli.resolvePath' dest'
|
moveBranchFunc src' dest' = do
|
||||||
|
-- We currently only support moving within the same project branch.
|
||||||
|
srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src'
|
||||||
|
PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest'
|
||||||
destBranchExists <- Cli.branchExistsAtPath' dest'
|
destBranchExists <- Cli.branchExistsAtPath' dest'
|
||||||
let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
|
Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do
|
||||||
when (isRootMove && not hasConfirmed) do
|
|
||||||
Cli.returnEarly MoveRootBranchConfirmation
|
|
||||||
Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
|
|
||||||
-- We want the move to appear as a single step in the root namespace, but we need to make
|
-- 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
|
-- 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.
|
-- those changes such that they appear as a single change in the root.
|
||||||
@ -26,17 +27,18 @@ moveBranchFunc hasConfirmed src' dest' = do
|
|||||||
changeRoot
|
changeRoot
|
||||||
& Branch.modifyAt srcLoc (const Branch.empty)
|
& Branch.modifyAt srcLoc (const Branch.empty)
|
||||||
& Branch.modifyAt destLoc (const srcBranch)
|
& Branch.modifyAt destLoc (const srcBranch)
|
||||||
if (destBranchExists && not isRootMove)
|
if destBranchExists
|
||||||
then Cli.respond (MovedOverExistingBranch dest')
|
then Cli.respond (MovedOverExistingBranch dest')
|
||||||
else pure ()
|
else pure ()
|
||||||
pure (Path.Absolute changeRootPath, doMove)
|
pure (Path.Absolute changeRootPath, doMove)
|
||||||
|
|
||||||
-- | Moves a branch and its history from one location to another, and saves the new root
|
-- | Moves a branch and its history from one location to another, and saves the new root
|
||||||
-- branch.
|
-- branch.
|
||||||
doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
|
doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli ()
|
||||||
doMoveBranch actionDescription hasConfirmed src' dest' = do
|
doMoveBranch actionDescription src' dest' = do
|
||||||
moveBranchFunc hasConfirmed src' dest' >>= \case
|
moveBranchFunc src' dest' >>= \case
|
||||||
Nothing -> Cli.respond (BranchNotFound src')
|
Nothing -> Cli.respond (BranchNotFound src')
|
||||||
Just (path, func) -> do
|
Just (absPath, func) -> do
|
||||||
_ <- Cli.updateAt actionDescription path func
|
pp <- Cli.resolvePath' (Path.AbsolutePath' absPath)
|
||||||
|
_ <- Cli.updateAt actionDescription pp func
|
||||||
Cli.respond Success
|
Cli.respond Success
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where
|
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 Data.Set qualified as Set
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Branch (Branch0)
|
||||||
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
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.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
import Unison.Prelude
|
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
|
moveTermSteps src' dest' = do
|
||||||
src <- Cli.resolveSplit' src'
|
src <- Cli.resolveSplit' src'
|
||||||
srcTerms <- Cli.getTermsAt src
|
srcTerms <- Cli.getTermsAt src
|
||||||
@ -29,11 +30,11 @@ moveTermSteps src' dest' = do
|
|||||||
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
|
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
|
||||||
when (not (Set.null destTerms)) do
|
when (not (Set.null destTerms)) do
|
||||||
Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
|
Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
|
||||||
let p = first Path.unabsolute src
|
let p = src & _1 %~ view PP.absPath_
|
||||||
pure
|
pure
|
||||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||||
BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
|
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 ()
|
doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||||
@ -41,5 +42,6 @@ doMoveTerm src' dest' description = do
|
|||||||
steps <- moveTermSteps src' dest'
|
steps <- moveTermSteps src' dest'
|
||||||
when (null steps) do
|
when (null steps) do
|
||||||
Cli.returnEarly (Output.TermNotFound src')
|
Cli.returnEarly (Output.TermNotFound src')
|
||||||
Cli.stepManyAt description steps
|
pb <- Cli.getCurrentProjectBranch
|
||||||
|
Cli.stepManyAt pb description steps
|
||||||
Cli.respond Output.Success
|
Cli.respond Output.Success
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where
|
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 Data.Set qualified as Set
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Branch (Branch0)
|
||||||
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
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.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
import Unison.Prelude
|
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
|
moveTypeSteps src' dest' = do
|
||||||
src <- Cli.resolveSplit' src'
|
src <- Cli.resolveSplit' src'
|
||||||
srcTypes <- Cli.getTypesAt src
|
srcTypes <- Cli.getTypesAt src
|
||||||
@ -29,11 +30,11 @@ moveTypeSteps src' dest' = do
|
|||||||
destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
|
destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
|
||||||
when (not (Set.null destTypes)) do
|
when (not (Set.null destTypes)) do
|
||||||
Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
|
Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
|
||||||
let p = first Path.unabsolute src
|
let p = over _1 (view PP.absPath_) src
|
||||||
pure
|
pure
|
||||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||||
BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
|
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 ()
|
doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||||
@ -41,5 +42,6 @@ doMoveType src' dest' description = do
|
|||||||
steps <- moveTypeSteps src' dest'
|
steps <- moveTypeSteps src' dest'
|
||||||
when (null steps) do
|
when (null steps) do
|
||||||
Cli.returnEarly (Output.TypeNotFound src')
|
Cli.returnEarly (Output.TypeNotFound src')
|
||||||
Cli.stepManyAt description steps
|
pb <- Cli.getCurrentProjectBranch
|
||||||
|
Cli.stepManyAt pb description steps
|
||||||
Cli.respond Output.Success
|
Cli.respond Output.Success
|
||||||
|
@ -14,7 +14,6 @@ import Unison.Codebase (Codebase)
|
|||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch (Branch0)
|
import Unison.Codebase.Branch (Branch0)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
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.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.DataDeclaration qualified as DD
|
import Unison.DataDeclaration qualified as DD
|
||||||
@ -22,7 +21,6 @@ import Unison.LabeledDependency (LabeledDependency)
|
|||||||
import Unison.LabeledDependency qualified as LD
|
import Unison.LabeledDependency qualified as LD
|
||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
import Unison.Names qualified as Names
|
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||||
import Unison.Reference qualified as Reference
|
import Unison.Reference qualified as Reference
|
||||||
@ -35,19 +33,16 @@ import Unison.Util.Relation qualified as Relation
|
|||||||
handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli ()
|
handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli ()
|
||||||
handleNamespaceDependencies namespacePath' = do
|
handleNamespaceDependencies namespacePath' = do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath'
|
pp <- maybe Cli.getCurrentProjectPath Cli.resolvePath' namespacePath'
|
||||||
|
let pb = pp ^. #branch
|
||||||
branch <-
|
branch <-
|
||||||
Cli.getMaybeBranch0At path & onNothingM do
|
Cli.getMaybeBranch0FromProjectPath pp & onNothingM do
|
||||||
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path)))
|
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp))
|
||||||
externalDependencies <-
|
externalDependencies <-
|
||||||
Cli.runTransaction (namespaceDependencies codebase branch)
|
Cli.runTransaction (namespaceDependencies codebase branch)
|
||||||
currentPPED <- Cli.currentPrettyPrintEnvDecl
|
pped <- Cli.projectBranchPPED pb
|
||||||
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
|
let ppe = PPED.unsuffixifiedPPE pped
|
||||||
globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames
|
Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies
|
||||||
-- We explicitly include a global unsuffixified fallback on namespace dependencies since
|
|
||||||
-- the things we want names for are obviously outside of our scope.
|
|
||||||
let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback globalPPED currentPPED
|
|
||||||
Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies
|
|
||||||
|
|
||||||
-- | Check the dependencies of all types and terms in the current namespace,
|
-- | 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,
|
-- 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
|
where
|
||||||
|
|
||||||
import Control.Lens (_2)
|
import Control.Lens (_2)
|
||||||
import Control.Monad.Reader (ask)
|
|
||||||
import Data.These (These (..))
|
import Data.These (These (..))
|
||||||
import Data.UUID.V4 qualified as UUID
|
import Data.UUID.V4 qualified as UUID
|
||||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||||
import U.Codebase.Sqlite.DbId qualified as Sqlite
|
import U.Codebase.Sqlite.DbId qualified as Sqlite
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli (updateAt)
|
import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch)
|
||||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Cli.Share.Projects qualified as Share
|
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.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path (Path)
|
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
|
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
@ -39,9 +36,9 @@ data RemoteProjectKey
|
|||||||
-- | Clone a remote branch.
|
-- | Clone a remote branch.
|
||||||
handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
|
handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
|
||||||
handleClone remoteNames0 maybeLocalNames0 = do
|
handleClone remoteNames0 maybeLocalNames0 = do
|
||||||
maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
|
currentProjectBranch <- Cli.getCurrentProjectAndBranch
|
||||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
|
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0
|
||||||
localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
|
localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||||
cloneInto localNames1 resolvedRemoteNames.branch
|
cloneInto localNames1 resolvedRemoteNames.branch
|
||||||
|
|
||||||
data ResolvedRemoteNames = ResolvedRemoteNames
|
data ResolvedRemoteNames = ResolvedRemoteNames
|
||||||
@ -78,63 +75,59 @@ data ResolvedRemoteNamesFrom
|
|||||||
-- otherwise abort
|
-- otherwise abort
|
||||||
resolveRemoteNames ::
|
resolveRemoteNames ::
|
||||||
Share.IncludeSquashedHead ->
|
Share.IncludeSquashedHead ->
|
||||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||||
ProjectAndBranchNames ->
|
ProjectAndBranchNames ->
|
||||||
Cli ResolvedRemoteNames
|
Cli ResolvedRemoteNames
|
||||||
resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
resolveRemoteNames includeSquashed currentProjectAndBranch = \case
|
||||||
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
|
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do
|
||||||
case maybeCurrentProjectBranch of
|
case projectNameUserSlug remoteProjectName of
|
||||||
Nothing -> resolveP remoteProjectName
|
Nothing -> resolveB remoteBranchName
|
||||||
Just (currentProjectAndBranch, _path) ->
|
Just _ ->
|
||||||
case projectNameUserSlug remoteProjectName of
|
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
||||||
Nothing -> resolveB remoteBranchName
|
Nothing -> resolveP remoteProjectName
|
||||||
Just _ ->
|
Just remoteBranchProjectId -> do
|
||||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
-- Fetching these in parallel would be an improvement
|
||||||
Nothing -> resolveP remoteProjectName
|
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
||||||
Just remoteBranchProjectId -> do
|
maybeRemoteBranch <-
|
||||||
-- Fetching these in parallel would be an improvement
|
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
||||||
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
||||||
maybeRemoteBranch <-
|
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
||||||
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||||
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||||
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
(Just remoteProject, Nothing) -> do
|
||||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
let remoteProjectId = remoteProject.projectId
|
||||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
let remoteProjectName = remoteProject.projectName
|
||||||
(Just remoteProject, Nothing) -> do
|
let remoteBranchName = unsafeFrom @Text "main"
|
||||||
let remoteProjectId = remoteProject.projectId
|
remoteBranch <-
|
||||||
let remoteProjectName = remoteProject.projectName
|
ProjectUtils.expectRemoteProjectBranchByName
|
||||||
let remoteBranchName = unsafeFrom @Text "main"
|
includeSquashed
|
||||||
remoteBranch <-
|
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||||
ProjectUtils.expectRemoteProjectBranchByName
|
pure
|
||||||
includeSquashed
|
ResolvedRemoteNames
|
||||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
{ branch = remoteBranch,
|
||||||
pure
|
from = ResolvedRemoteNamesFrom'Project
|
||||||
ResolvedRemoteNames
|
}
|
||||||
{ branch = remoteBranch,
|
(Nothing, Just remoteBranch) ->
|
||||||
from = ResolvedRemoteNamesFrom'Project
|
pure
|
||||||
}
|
ResolvedRemoteNames
|
||||||
(Nothing, Just remoteBranch) ->
|
{ branch = remoteBranch,
|
||||||
pure
|
from = ResolvedRemoteNamesFrom'Branch
|
||||||
ResolvedRemoteNames
|
}
|
||||||
{ branch = remoteBranch,
|
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
||||||
from = ResolvedRemoteNamesFrom'Branch
|
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
||||||
}
|
-- wouldn't help, because we did enough work to know neither thing exists"
|
||||||
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
_ -> do
|
||||||
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
branchProjectName <-
|
||||||
-- wouldn't help, because we did enough work to know neither thing exists"
|
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
||||||
_ -> do
|
Cli.returnEarly $
|
||||||
branchProjectName <-
|
Output.AmbiguousCloneRemote
|
||||||
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
remoteProjectName
|
||||||
Cli.returnEarly $
|
(ProjectAndBranch branchProjectName remoteBranchName)
|
||||||
Output.AmbiguousCloneRemote
|
|
||||||
remoteProjectName
|
|
||||||
(ProjectAndBranch branchProjectName remoteBranchName)
|
|
||||||
ProjectAndBranchNames'Unambiguous (This p) -> resolveP p
|
ProjectAndBranchNames'Unambiguous (This p) -> resolveP p
|
||||||
ProjectAndBranchNames'Unambiguous (That b) -> resolveB b
|
ProjectAndBranchNames'Unambiguous (That b) -> resolveB b
|
||||||
ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b
|
ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b
|
||||||
where
|
where
|
||||||
resolveB branchName = do
|
resolveB branchName = do
|
||||||
(currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
|
||||||
remoteProjectId <-
|
remoteProjectId <-
|
||||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do
|
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do
|
||||||
Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch)
|
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
|
-- `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`.
|
-- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`.
|
||||||
resolveLocalNames ::
|
resolveLocalNames ::
|
||||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||||
ResolvedRemoteNames ->
|
ResolvedRemoteNames ->
|
||||||
Maybe ProjectAndBranchNames ->
|
Maybe ProjectAndBranchNames ->
|
||||||
Cli (ProjectAndBranch LocalProjectKey ProjectBranchName)
|
Cli (ProjectAndBranch LocalProjectKey ProjectBranchName)
|
||||||
resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames =
|
resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames =
|
||||||
resolve case maybeLocalNames of
|
resolve case maybeLocalNames of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
|
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
|
||||||
@ -199,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
|||||||
|
|
||||||
resolve names =
|
resolve names =
|
||||||
case names of
|
case names of
|
||||||
ProjectAndBranchNames'Ambiguous localProjectName localBranchName ->
|
ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do
|
||||||
case maybeCurrentProjectBranch of
|
Cli.returnEarly $
|
||||||
Nothing -> resolveP localProjectName
|
Output.AmbiguousCloneLocal
|
||||||
Just (ProjectAndBranch currentProject _, _path) -> do
|
(ProjectAndBranch localProjectName remoteBranchName)
|
||||||
Cli.returnEarly $
|
(ProjectAndBranch currentProject.name localBranchName)
|
||||||
Output.AmbiguousCloneLocal
|
|
||||||
(ProjectAndBranch localProjectName remoteBranchName)
|
|
||||||
(ProjectAndBranch currentProject.name localBranchName)
|
|
||||||
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
|
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
|
||||||
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
|
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
|
||||||
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
|
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
|
||||||
@ -215,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
|||||||
go (LocalProjectKey'Name localProjectName) remoteBranchName
|
go (LocalProjectKey'Name localProjectName) remoteBranchName
|
||||||
|
|
||||||
resolveB localBranchName = do
|
resolveB localBranchName = do
|
||||||
(ProjectAndBranch currentProject _, _path) <-
|
|
||||||
maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
|
||||||
go (LocalProjectKey'Project currentProject) localBranchName
|
go (LocalProjectKey'Project currentProject) localBranchName
|
||||||
|
|
||||||
resolvePB localProjectName localBranchName =
|
resolvePB localProjectName localBranchName =
|
||||||
@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
|||||||
pure (localProjectId, localProjectName)
|
pure (localProjectId, localProjectName)
|
||||||
Right localProject -> pure (localProject.projectId, localProject.name)
|
Right localProject -> pure (localProject.projectId, localProject.name)
|
||||||
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||||
|
causalHashId <- Q.expectCausalHashIdByCausalHash branchHead
|
||||||
|
let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName)
|
||||||
Queries.insertProjectBranch
|
Queries.insertProjectBranch
|
||||||
|
description
|
||||||
|
causalHashId
|
||||||
Sqlite.ProjectBranch
|
Sqlite.ProjectBranch
|
||||||
{ projectId = localProjectId,
|
{ projectId = localProjectId,
|
||||||
branchId = localBranchId,
|
branchId = localBranchId,
|
||||||
@ -277,12 +269,8 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
|||||||
localProjectBranch.branch
|
localProjectBranch.branch
|
||||||
)
|
)
|
||||||
|
|
||||||
-- Manipulate the root namespace and cd
|
let newProjectAndBranch = (over #project fst localProjectAndBranch)
|
||||||
Cli.Env {codebase} <- ask
|
Cli.switchProject newProjectAndBranch
|
||||||
theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead)
|
|
||||||
let path = projectBranchPath (over #project fst localProjectAndBranch)
|
|
||||||
Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch)
|
|
||||||
Cli.cd path
|
|
||||||
|
|
||||||
-- Return the remote project id associated with the given project branch
|
-- Return the remote project id associated with the given project branch
|
||||||
loadAssociatedRemoteProjectId ::
|
loadAssociatedRemoteProjectId ::
|
||||||
|
@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
import Control.Monad.Reader (ask)
|
import Control.Monad.Reader (ask)
|
||||||
import Data.Map.Strict qualified as Map
|
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.UUID.V4 qualified as UUID
|
|
||||||
import System.Random.Shuffle qualified as RandomShuffle
|
import System.Random.Shuffle qualified as RandomShuffle
|
||||||
import U.Codebase.Sqlite.DbId
|
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 U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Cli.Share.Projects qualified as Share
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
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.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
|
||||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
import Unison.Prelude
|
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
|
-- 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.
|
-- 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
|
projectCreate tryDownloadingBase maybeProjectName = do
|
||||||
projectId <- liftIO (ProjectId <$> UUID.nextRandom)
|
|
||||||
branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom)
|
|
||||||
|
|
||||||
let branchName = unsafeFrom @Text "main"
|
let branchName = unsafeFrom @Text "main"
|
||||||
|
(_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash
|
||||||
|
|
||||||
projectName <-
|
(project, branch) <-
|
||||||
case maybeProjectName of
|
case maybeProjectName of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
randomProjectNames <- liftIO generateRandomProjectNames
|
randomProjectNames <- liftIO generateRandomProjectNames
|
||||||
@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
|||||||
let loop = \case
|
let loop = \case
|
||||||
[] -> error (reportBug "E066388" "project name supply is supposed to be infinite")
|
[] -> error (reportBug "E066388" "project name supply is supposed to be infinite")
|
||||||
projectName : projectNames ->
|
projectName : projectNames ->
|
||||||
Queries.projectExistsByName projectName >>= \case
|
Queries.loadProjectByName projectName >>= \case
|
||||||
False -> do
|
Nothing -> do
|
||||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
(project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||||
pure projectName
|
pure (project, branch)
|
||||||
True -> loop projectNames
|
Just _project -> loop projectNames
|
||||||
loop randomProjectNames
|
loop randomProjectNames
|
||||||
Just projectName -> do
|
Just projectName -> do
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
Queries.projectExistsByName projectName >>= \case
|
Queries.projectExistsByName projectName >>= \case
|
||||||
False -> do
|
False -> do
|
||||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||||
pure projectName
|
|
||||||
True -> rollback (Output.ProjectNameAlreadyExists projectName)
|
True -> rollback (Output.ProjectNameAlreadyExists projectName)
|
||||||
|
|
||||||
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
|
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
|
||||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
|
Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)
|
||||||
Cli.cd path
|
|
||||||
|
|
||||||
maybeBaseLatestReleaseBranchObject <-
|
maybeBaseLatestReleaseBranchObject <-
|
||||||
if tryDownloadingBase
|
if tryDownloadingBase
|
||||||
@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
|||||||
pure maybeBaseLatestReleaseBranchObject
|
pure maybeBaseLatestReleaseBranchObject
|
||||||
else pure Nothing
|
else pure Nothing
|
||||||
|
|
||||||
let projectBranchObject =
|
for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do
|
||||||
case maybeBaseLatestReleaseBranchObject of
|
-- lib.base
|
||||||
Nothing -> Branch.empty0
|
let projectBranchLibBaseObject =
|
||||||
Just baseLatestReleaseBranchObject ->
|
Branch.empty0
|
||||||
let -- lib.base
|
& Branch.children
|
||||||
projectBranchLibBaseObject =
|
. at NameSegment.baseSegment
|
||||||
over
|
.~ Just baseLatestReleaseBranchObject
|
||||||
Branch.children
|
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||||
(Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject)
|
let branchWithBase =
|
||||||
Branch.empty0
|
Branch.empty
|
||||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
& Branch.history
|
||||||
in over
|
. Causal.head_
|
||||||
Branch.children
|
. Branch.children
|
||||||
(Map.insert NameSegment.libSegment projectBranchLibObject)
|
. at NameSegment.libSegment
|
||||||
Branch.empty0
|
.~ Just projectBranchLibObject
|
||||||
|
Cli.Env {codebase} <- ask
|
||||||
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
|
liftIO $ Codebase.putBranch codebase branchWithBase
|
||||||
|
Cli.runTransaction $ do
|
||||||
|
baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase)
|
||||||
|
Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId
|
||||||
|
|
||||||
Cli.respond Output.HappyCoding
|
Cli.respond Output.HappyCoding
|
||||||
where
|
pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}
|
||||||
reflogDescription =
|
|
||||||
case maybeProjectName of
|
|
||||||
Nothing -> "project.create"
|
|
||||||
Just projectName -> "project.create " <> into @Text projectName
|
|
||||||
|
|
||||||
-- An infinite list of random project names that looks like
|
-- An infinite list of random project names that looks like
|
||||||
--
|
--
|
||||||
|
@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import U.Codebase.Sqlite.Project (Project (..))
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Editor.Output qualified as Output
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||||
|
|
||||||
handleProjectRename :: ProjectName -> Cli ()
|
handleProjectRename :: ProjectName -> Cli ()
|
||||||
handleProjectRename newName = do
|
handleProjectRename newName = do
|
||||||
project <- ProjectUtils.expectCurrentProject
|
ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch
|
||||||
let oldName = project ^. #name
|
let oldName = project.name
|
||||||
when (oldName /= newName) do
|
when (oldName /= newName) do
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
Queries.loadProjectByName newName >>= \case
|
Queries.loadProjectByName newName >>= \case
|
||||||
Just _ -> rollback (Output.ProjectNameAlreadyExists newName)
|
Just _ -> rollback (Output.ProjectNameAlreadyExists newName)
|
||||||
Nothing -> Queries.renameProject (project ^. #projectId) newName
|
Nothing -> Queries.renameProject project.projectId newName
|
||||||
Cli.respond (Output.RenamedProject oldName newName)
|
Cli.respond (Output.RenamedProject oldName newName)
|
||||||
|
@ -5,11 +5,11 @@ module Unison.Codebase.Editor.HandleInput.ProjectSwitch
|
|||||||
where
|
where
|
||||||
|
|
||||||
import Data.These (These (..))
|
import Data.These (These (..))
|
||||||
import U.Codebase.Sqlite.Project qualified
|
import U.Codebase.Sqlite.Project (Project (..))
|
||||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
@ -28,51 +28,46 @@ import Witch (unsafeFrom)
|
|||||||
projectSwitch :: ProjectAndBranchNames -> Cli ()
|
projectSwitch :: ProjectAndBranchNames -> Cli ()
|
||||||
projectSwitch projectNames = do
|
projectSwitch projectNames = do
|
||||||
case projectNames of
|
case projectNames of
|
||||||
ProjectAndBranchNames'Ambiguous projectName branchName ->
|
ProjectAndBranchNames'Ambiguous projectName branchName -> do
|
||||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
ProjectAndBranch currentProject _currentBranch <- Cli.getCurrentProjectAndBranch
|
||||||
Nothing -> switchToProjectAndBranchByTheseNames (This projectName)
|
(projectExists, branchExists) <-
|
||||||
Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do
|
Cli.runTransaction do
|
||||||
(projectExists, branchExists) <-
|
(,)
|
||||||
Cli.runTransaction do
|
<$> Queries.projectExistsByName projectName
|
||||||
(,)
|
<*> Queries.projectBranchExistsByName currentProject.projectId branchName
|
||||||
<$> Queries.projectExistsByName projectName
|
case (projectExists, branchExists) of
|
||||||
<*> Queries.projectBranchExistsByName currentProject.projectId branchName
|
(False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
|
||||||
case (projectExists, branchExists) of
|
(False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
|
||||||
(False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName)
|
(True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
|
||||||
(False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName)
|
(True, True) ->
|
||||||
(True, False) -> switchToProjectAndBranchByTheseNames (This projectName)
|
Cli.respondNumbered $
|
||||||
(True, True) ->
|
Output.AmbiguousSwitch
|
||||||
Cli.respondNumbered $
|
projectName
|
||||||
Output.AmbiguousSwitch
|
(ProjectAndBranch currentProject.name branchName)
|
||||||
projectName
|
|
||||||
(ProjectAndBranch currentProject.name branchName)
|
|
||||||
ProjectAndBranchNames'Unambiguous projectAndBranchNames0 ->
|
ProjectAndBranchNames'Unambiguous projectAndBranchNames0 ->
|
||||||
switchToProjectAndBranchByTheseNames projectAndBranchNames0
|
switchToProjectAndBranchByTheseNames projectAndBranchNames0
|
||||||
|
|
||||||
switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli ()
|
switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli ()
|
||||||
switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
|
switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
|
||||||
branch <-
|
branch <- case projectAndBranchNames0 of
|
||||||
case projectAndBranchNames0 of
|
This projectName ->
|
||||||
This projectName ->
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
project <-
|
||||||
project <-
|
Queries.loadProjectByName projectName & onNothingM do
|
||||||
Queries.loadProjectByName projectName & onNothingM do
|
rollback (Output.LocalProjectDoesntExist projectName)
|
||||||
rollback (Output.LocalProjectDoesntExist projectName)
|
Queries.loadMostRecentBranch (project ^. #projectId) >>= \case
|
||||||
Queries.loadMostRecentBranch project.projectId >>= \case
|
Nothing -> do
|
||||||
Nothing -> do
|
let branchName = unsafeFrom @Text "main"
|
||||||
let branchName = unsafeFrom @Text "main"
|
branch <-
|
||||||
branch <-
|
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||||
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
pure branch
|
||||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
Just branchId -> Queries.expectProjectBranch project.projectId branchId
|
||||||
pure branch
|
_ -> do
|
||||||
Just branchId -> Queries.expectProjectBranch project.projectId branchId
|
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||||
_ -> do
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
projectAndBranchNames <- ProjectUtils.hydrateNames projectAndBranchNames0
|
branch <-
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Queries.loadProjectBranchByNames projectName branchName & onNothingM do
|
||||||
branch <-
|
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||||
Queries.loadProjectBranchByNames projectAndBranchNames.project projectAndBranchNames.branch & onNothingM do
|
pure branch
|
||||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
Cli.switchProject (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId))
|
||||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
|
||||||
pure branch
|
|
||||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId))
|
|
||||||
|
@ -21,9 +21,9 @@ import Unison.Cli.MergeTypes (MergeSource (..))
|
|||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils 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.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Cli.Share.Projects qualified as Share
|
import Unison.Cli.Share.Projects qualified as Share
|
||||||
import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl)
|
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch (Branch (..))
|
import Unison.Codebase.Branch (Branch (..))
|
||||||
import Unison.Codebase.Branch qualified as 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.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
import Unison.Codebase.Editor.Output qualified as 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.Propagate qualified as Propagate
|
||||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
|
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
|
||||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
|
||||||
import Unison.Codebase.Patch (Patch (..))
|
import Unison.Codebase.Patch (Patch (..))
|
||||||
import Unison.Codebase.Path (Path')
|
|
||||||
import Unison.Codebase.Path qualified as 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.InputPattern qualified as InputPattern
|
||||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
@ -76,8 +74,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
|||||||
|
|
||||||
when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
|
when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))
|
||||||
|
|
||||||
let targetAbsolutePath =
|
let targetProjectPath = PP.projectBranchRoot (ProjectAndBranch target.project target.branch)
|
||||||
ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId)
|
|
||||||
|
|
||||||
let description =
|
let description =
|
||||||
Text.unwords
|
Text.unwords
|
||||||
@ -92,22 +89,18 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
|||||||
|
|
||||||
case pullMode of
|
case pullMode of
|
||||||
Input.PullWithHistory -> do
|
Input.PullWithHistory -> do
|
||||||
targetBranchObject <- Cli.getBranch0At targetAbsolutePath
|
targetBranch <- Cli.getBranchFromProjectPath targetProjectPath
|
||||||
|
|
||||||
if Branch.isEmpty0 targetBranchObject
|
if Branch.isEmpty0 $ Branch.head targetBranch
|
||||||
then do
|
then do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
|
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
|
Cli.respond $ MergeOverEmpty target
|
||||||
else do
|
else do
|
||||||
Cli.respond AboutToMerge
|
Cli.respond AboutToMerge
|
||||||
|
|
||||||
aliceCausalHash <-
|
let aliceCausalHash = Branch.headHash targetBranch
|
||||||
Cli.runTransaction do
|
|
||||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath)
|
|
||||||
pure causal.causalHash
|
|
||||||
|
|
||||||
lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)
|
lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)
|
||||||
|
|
||||||
doMerge
|
doMerge
|
||||||
@ -139,7 +132,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
|||||||
didUpdate <-
|
didUpdate <-
|
||||||
Cli.updateAtM
|
Cli.updateAtM
|
||||||
description
|
description
|
||||||
targetAbsolutePath
|
targetProjectPath
|
||||||
(\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject)
|
(\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject)
|
||||||
|
|
||||||
Cli.respond
|
Cli.respond
|
||||||
@ -167,30 +160,29 @@ resolveSourceAndTarget includeSquashed = \case
|
|||||||
pure (source, target)
|
pure (source, target)
|
||||||
|
|
||||||
resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
|
resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
|
||||||
resolveImplicitSource includeSquashed =
|
resolveImplicitSource includeSquashed = do
|
||||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
pp <- Cli.getCurrentProjectPath
|
||||||
Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath
|
let localProjectAndBranch = PP.toProjectAndBranch pp
|
||||||
Just (localProjectAndBranch, _restPath) -> do
|
(remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
|
||||||
(remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
|
Cli.runTransactionWithRollback \rollback -> do
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
let localProjectId = localProjectAndBranch.project.projectId
|
||||||
let localProjectId = localProjectAndBranch.project.projectId
|
let localBranchId = localProjectAndBranch.branch.branchId
|
||||||
let localBranchId = localProjectAndBranch.branch.branchId
|
Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
|
||||||
Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case
|
Just (remoteProjectId, Just remoteBranchId) -> do
|
||||||
Just (remoteProjectId, Just remoteBranchId) -> do
|
remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
|
||||||
remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
|
remoteBranchName <-
|
||||||
remoteBranchName <-
|
Queries.expectRemoteProjectBranchName
|
||||||
Queries.expectRemoteProjectBranchName
|
Share.hardCodedUri
|
||||||
Share.hardCodedUri
|
remoteProjectId
|
||||||
remoteProjectId
|
remoteBranchId
|
||||||
remoteBranchId
|
pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
|
||||||
pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
|
_ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
|
||||||
_ -> rollback (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch)
|
remoteBranch <-
|
||||||
remoteBranch <-
|
ProjectUtils.expectRemoteProjectBranchById includeSquashed $
|
||||||
ProjectUtils.expectRemoteProjectBranchById includeSquashed $
|
ProjectAndBranch
|
||||||
ProjectAndBranch
|
(remoteProjectId, remoteProjectName)
|
||||||
(remoteProjectId, remoteProjectName)
|
(remoteBranchId, remoteBranchName)
|
||||||
(remoteBranchId, remoteBranchName)
|
pure (ReadShare'ProjectBranch remoteBranch)
|
||||||
pure (ReadShare'ProjectBranch remoteBranch)
|
|
||||||
|
|
||||||
resolveExplicitSource ::
|
resolveExplicitSource ::
|
||||||
Share.IncludeSquashedHead ->
|
Share.IncludeSquashedHead ->
|
||||||
@ -208,7 +200,7 @@ resolveExplicitSource includeSquashed = \case
|
|||||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||||
ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
|
ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
|
||||||
(localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch
|
localProjectAndBranch <- PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
|
||||||
let localProjectId = localProjectAndBranch.project.projectId
|
let localProjectId = localProjectAndBranch.project.projectId
|
||||||
let localBranchId = localProjectAndBranch.branch.branchId
|
let localBranchId = localProjectAndBranch.branch.branchId
|
||||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||||
@ -243,8 +235,7 @@ resolveExplicitSource includeSquashed = \case
|
|||||||
|
|
||||||
resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||||
resolveImplicitTarget = do
|
resolveImplicitTarget = do
|
||||||
(projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
PP.toProjectAndBranch <$> Cli.getCurrentProjectPath
|
||||||
pure projectAndBranch
|
|
||||||
|
|
||||||
-- | supply `dest0` if you want to print diff messages
|
-- | supply `dest0` if you want to print diff messages
|
||||||
-- supply unchangedMessage if you want to display it if merge had no effect
|
-- supply unchangedMessage if you want to display it if merge had no effect
|
||||||
@ -253,8 +244,8 @@ mergeBranchAndPropagateDefaultPatch ::
|
|||||||
Text ->
|
Text ->
|
||||||
Maybe Output ->
|
Maybe Output ->
|
||||||
Branch IO ->
|
Branch IO ->
|
||||||
Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
Cli ()
|
Cli ()
|
||||||
mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest =
|
mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb maybeDest0 dest =
|
||||||
ifM
|
ifM
|
||||||
@ -266,7 +257,7 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
|
|||||||
mergeBranch =
|
mergeBranch =
|
||||||
Cli.time "mergeBranch" do
|
Cli.time "mergeBranch" do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
destb <- Cli.getBranchAt dest
|
destb <- Cli.getBranchFromProjectPath dest
|
||||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb)
|
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) mode srcb destb)
|
||||||
b <- Cli.updateAtM inputDescription dest (const $ pure merged)
|
b <- Cli.updateAtM inputDescription dest (const $ pure merged)
|
||||||
for_ maybeDest0 \dest0 -> do
|
for_ maybeDest0 \dest0 -> do
|
||||||
@ -276,19 +267,19 @@ mergeBranchAndPropagateDefaultPatch mode inputDescription unchangedMessage srcb
|
|||||||
|
|
||||||
loadPropagateDiffDefaultPatch ::
|
loadPropagateDiffDefaultPatch ::
|
||||||
Text ->
|
Text ->
|
||||||
Maybe (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
Cli ()
|
Cli ()
|
||||||
loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
||||||
Cli.respond Output.AboutToPropagatePatch
|
Cli.respond Output.AboutToPropagatePatch
|
||||||
Cli.time "loadPropagateDiffDefaultPatch" do
|
Cli.time "loadPropagateDiffDefaultPatch" do
|
||||||
original <- Cli.getBranch0At dest
|
original <- Cli.getBranch0FromProjectPath dest
|
||||||
patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original
|
patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original
|
||||||
patchDidChange <- propagatePatch inputDescription patch dest
|
patchDidChange <- propagatePatch inputDescription patch dest
|
||||||
when patchDidChange do
|
when patchDidChange do
|
||||||
whenJust maybeDest0 \dest0 -> do
|
whenJust maybeDest0 \dest0 -> do
|
||||||
Cli.respond Output.CalculatingDiff
|
Cli.respond Output.CalculatingDiff
|
||||||
patched <- Cli.getBranchAt dest
|
patched <- Cli.getBranchFromProjectPath dest
|
||||||
let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment])))
|
let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment])))
|
||||||
(ppe, diff) <- diffHelper original (Branch.head patched)
|
(ppe, diff) <- diffHelper original (Branch.head patched)
|
||||||
Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff)
|
Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff)
|
||||||
@ -297,10 +288,11 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
|||||||
propagatePatch ::
|
propagatePatch ::
|
||||||
Text ->
|
Text ->
|
||||||
Patch ->
|
Patch ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
Cli Bool
|
Cli Bool
|
||||||
propagatePatch inputDescription patch scopePath = do
|
propagatePatch inputDescription patch scopePath = do
|
||||||
Cli.time "propagatePatch" do
|
Cli.time "propagatePatch" do
|
||||||
|
rootNames <- Cli.projectBranchNames scopePath.branch
|
||||||
Cli.stepAt'
|
Cli.stepAt'
|
||||||
(inputDescription <> " (applying patch)")
|
(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.Set.NonEmpty qualified as Set.NonEmpty
|
||||||
import Data.Text as Text
|
import Data.Text as Text
|
||||||
import Data.These (These (..))
|
import Data.These (These (..))
|
||||||
import Data.Void (absurd)
|
|
||||||
import System.Console.Regions qualified as Console.Regions
|
import System.Console.Regions qualified as Console.Regions
|
||||||
import Text.Builder qualified
|
import Text.Builder qualified
|
||||||
import U.Codebase.HashTags (CausalHash (..))
|
import U.Codebase.HashTags (CausalHash (..))
|
||||||
import U.Codebase.Sqlite.DbId
|
import U.Codebase.Sqlite.DbId
|
||||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project)
|
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.ProjectBranch qualified as Sqlite (ProjectBranch)
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
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.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Cli.Share.Projects qualified as Share
|
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.HandleInput.AuthLogin qualified as AuthLogin
|
||||||
import Unison.Codebase.Editor.Input
|
import Unison.Codebase.Editor.Input
|
||||||
( PushRemoteBranchInput (..),
|
( PushRemoteBranchInput (..),
|
||||||
@ -32,13 +31,6 @@ import Unison.Codebase.Editor.Input
|
|||||||
)
|
)
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
import Unison.Codebase.Editor.Output qualified as 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.Codebase.PushBehavior qualified as PushBehavior
|
||||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||||
import Unison.Hash32 (Hash32)
|
import Unison.Hash32 (Hash32)
|
||||||
@ -67,49 +59,16 @@ handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
|
|||||||
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||||
case sourceTarget of
|
case sourceTarget of
|
||||||
-- push <implicit> to <implicit>
|
-- push <implicit> to <implicit>
|
||||||
PushSourceTarget0 ->
|
PushSourceTarget0 -> do
|
||||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
localProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||||
Nothing -> do
|
pushProjectBranchToProjectBranch force localProjectAndBranch Nothing
|
||||||
localPath <- Cli.getCurrentPath
|
|
||||||
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
|
|
||||||
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
|
||||||
WriteRemoteProjectBranch v -> absurd v
|
|
||||||
Just (localProjectAndBranch, _restPath) ->
|
|
||||||
pushProjectBranchToProjectBranch
|
|
||||||
force
|
|
||||||
localProjectAndBranch
|
|
||||||
Nothing
|
|
||||||
-- push <implicit> to .some.path (share)
|
-- push <implicit> to .some.path (share)
|
||||||
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
|
|
||||||
localPath <- Cli.getCurrentPath
|
|
||||||
pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
|
||||||
-- push <implicit> to @some/project
|
-- push <implicit> to @some/project
|
||||||
PushSourceTarget1 (WriteRemoteProjectBranch remoteProjectAndBranch0) ->
|
PushSourceTarget1 remoteProjectAndBranch0 -> do
|
||||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
localProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||||
Nothing -> do
|
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
|
||||||
localPath <- Cli.getCurrentPath
|
|
||||||
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
|
|
||||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
|
||||||
Just (localProjectAndBranch, _restPath) ->
|
|
||||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
|
|
||||||
-- push .some.path to .some.path (share)
|
|
||||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
|
|
||||||
localPath <- Cli.resolvePath' localPath0
|
|
||||||
pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
|
||||||
-- push .some.path to @some/project
|
|
||||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteProjectBranch remoteProjectAndBranch0) -> do
|
|
||||||
localPath <- Cli.resolvePath' localPath0
|
|
||||||
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
|
|
||||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
|
||||||
-- push @some/project to .some.path (share)
|
|
||||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
|
|
||||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
|
||||||
pushLooseCodeToShareLooseCode
|
|
||||||
(ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
|
||||||
namespace
|
|
||||||
pushBehavior
|
|
||||||
-- push @some/project to @some/project
|
-- push @some/project to @some/project
|
||||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteProjectBranch remoteProjectAndBranch) -> do
|
PushSourceTarget2 (ProjySource localProjectAndBranch0) remoteProjectAndBranch -> do
|
||||||
localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
localProjectAndBranch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch)
|
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch)
|
||||||
where
|
where
|
||||||
@ -119,24 +78,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
|||||||
PushBehavior.RequireEmpty -> False
|
PushBehavior.RequireEmpty -> False
|
||||||
PushBehavior.RequireNonEmpty -> 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
|
-- | 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).
|
-- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it).
|
||||||
pushProjectBranchToProjectBranch ::
|
pushProjectBranchToProjectBranch ::
|
||||||
@ -147,14 +88,11 @@ pushProjectBranchToProjectBranch ::
|
|||||||
pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do
|
pushProjectBranchToProjectBranch force localProjectAndBranch maybeRemoteProjectAndBranchNames = do
|
||||||
_ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
|
_ <- AuthLogin.ensureAuthenticatedWithCodeserver Codeserver.defaultCodeserver
|
||||||
let localProjectAndBranchIds = localProjectAndBranch & over #project (view #projectId) & over #branch (view #branchId)
|
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
|
-- Load local project and branch from database and get the causal hash to push
|
||||||
(localProjectAndBranch, localBranchHead) <-
|
(localProjectAndBranch, localBranchHead) <-
|
||||||
Cli.runTransactionWithRollback \rollback -> do
|
Cli.runTransaction do
|
||||||
hash <-
|
hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch)
|
||||||
loadCausalHashToPush (ProjectUtils.projectBranchPath localProjectAndBranchIds) & onNothingM do
|
|
||||||
rollback (EmptyProjectBranchPush localProjectAndBranchNames)
|
|
||||||
localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds
|
localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds
|
||||||
pure (localProjectAndBranch, hash)
|
pure (localProjectAndBranch, hash)
|
||||||
|
|
||||||
@ -471,7 +409,7 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do
|
|||||||
Share.TransportError err -> ShareErrorTransport err
|
Share.TransportError err -> ShareErrorTransport err
|
||||||
afterUploadAction
|
afterUploadAction
|
||||||
let ProjectAndBranch projectName branchName = remoteBranch
|
let ProjectAndBranch projectName branchName = remoteBranch
|
||||||
Cli.respond (ViewOnShare (Right (Share.hardCodedUri, projectName, branchName)))
|
Cli.respond (ViewOnShare (Share.hardCodedUri, projectName, branchName))
|
||||||
|
|
||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- After upload actions
|
-- After upload actions
|
||||||
@ -563,7 +501,7 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
|
|||||||
|
|
||||||
when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do
|
when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do
|
||||||
Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
|
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
|
when (not force) do
|
||||||
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
|
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
|
||||||
@ -633,14 +571,11 @@ expectProjectAndBranch (ProjectAndBranch projectId branchId) =
|
|||||||
<$> Queries.expectProject projectId
|
<$> Queries.expectProject projectId
|
||||||
<*> Queries.expectProjectBranch projectId branchId
|
<*> Queries.expectProjectBranch projectId branchId
|
||||||
|
|
||||||
-- Get the causal hash to push at the given path. Return Nothing if there's no history.
|
-- Get the causal hash for the given project branch.
|
||||||
loadCausalHashToPush :: Path.Absolute -> Sqlite.Transaction (Maybe Hash32)
|
expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32
|
||||||
loadCausalHashToPush path =
|
expectCausalHashToPush pb = do
|
||||||
Operations.loadCausalHashAtPath Nothing segments <&> \case
|
CausalHash causalHash <- Operations.expectProjectBranchHead (pb ^. #projectId) (pb ^. #branchId)
|
||||||
Nothing -> Nothing
|
pure (Hash32.fromHash causalHash)
|
||||||
Just (CausalHash hash) -> Just (Hash32.fromHash hash)
|
|
||||||
where
|
|
||||||
segments = Path.toList (Path.unabsolute path)
|
|
||||||
|
|
||||||
-- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward?
|
-- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward?
|
||||||
wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool
|
wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool
|
||||||
|
@ -6,8 +6,8 @@ where
|
|||||||
|
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), doCreateBranch)
|
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..), createBranch)
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (Semver)
|
import Unison.Project (Semver)
|
||||||
@ -16,15 +16,15 @@ import Witch (unsafeFrom)
|
|||||||
-- | Handle a @release.draft@ command.
|
-- | Handle a @release.draft@ command.
|
||||||
handleReleaseDraft :: Semver -> Cli ()
|
handleReleaseDraft :: Semver -> Cli ()
|
||||||
handleReleaseDraft ver = do
|
handleReleaseDraft ver = do
|
||||||
currentProjectAndBranch <- fst <$> ProjectUtils.expectCurrentProjectBranch
|
currentProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||||
|
|
||||||
let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver)
|
let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver)
|
||||||
|
|
||||||
_ <-
|
_ <-
|
||||||
doCreateBranch
|
createBranch
|
||||||
(CreateFrom'Branch currentProjectAndBranch)
|
|
||||||
(currentProjectAndBranch ^. #project)
|
|
||||||
branchName
|
|
||||||
("release.draft " <> into @Text ver)
|
("release.draft " <> into @Text ver)
|
||||||
|
(CreateFrom'ParentBranch (currentProjectAndBranch ^. #branch))
|
||||||
|
(currentProjectAndBranch ^. #project)
|
||||||
|
(pure branchName)
|
||||||
|
|
||||||
Cli.respond (Output.DraftingRelease branchName ver)
|
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.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 Project
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
|
||||||
import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
|
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 (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as Project
|
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||||
import Unison.ConstructorType qualified as ConstructorType
|
import Unison.ConstructorType qualified as ConstructorType
|
||||||
import Unison.HashQualified qualified as HQ
|
import Unison.HashQualified qualified as HQ
|
||||||
@ -28,8 +26,7 @@ import Unison.Name (Name)
|
|||||||
import Unison.Name qualified as Name
|
import Unison.Name qualified as Name
|
||||||
import Unison.Parser.Ann (Ann (..))
|
import Unison.Parser.Ann (Ann (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch)
|
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||||
import Unison.Project.Util (projectBranchPath)
|
|
||||||
import Unison.Referent qualified as Referent
|
import Unison.Referent qualified as Referent
|
||||||
import Unison.Server.CodebaseServer qualified as Server
|
import Unison.Server.CodebaseServer qualified as Server
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
@ -39,39 +36,27 @@ import Web.Browser (openBrowser)
|
|||||||
openUI :: Path.Path' -> Cli ()
|
openUI :: Path.Path' -> Cli ()
|
||||||
openUI path' = do
|
openUI path' = do
|
||||||
Cli.Env {serverBaseUrl} <- ask
|
Cli.Env {serverBaseUrl} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
defnPath <- Cli.resolvePath' path'
|
||||||
let absPath = Path.resolve currentPath path'
|
pp <- Cli.getCurrentProjectPath
|
||||||
whenJust serverBaseUrl \url -> do
|
whenJust serverBaseUrl \url -> do
|
||||||
Project.getProjectBranchForPath absPath >>= \case
|
openUIForProject url pp (defnPath ^. PP.absPath_)
|
||||||
Nothing -> openUIForLooseCode url path'
|
|
||||||
Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch
|
|
||||||
|
|
||||||
openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli ()
|
openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
|
||||||
openUIForProject url projectAndBranch pathFromProjectRoot = do
|
openUIForProject url pp@(PP.ProjectPath project projectBranch perspective) defnPath = do
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
perspective <-
|
|
||||||
Project.getProjectBranchForPath currentPath <&> \case
|
|
||||||
Nothing ->
|
|
||||||
-- The current path is outside the project the argument was in. Use the project root
|
|
||||||
-- as the perspective.
|
|
||||||
Path.empty
|
|
||||||
Just (_projectBranch, pathWithinBranch) -> pathWithinBranch
|
|
||||||
mayDefinitionRef <- getDefinitionRef perspective
|
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
|
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
|
||||||
pure ()
|
pure ()
|
||||||
where
|
where
|
||||||
pathToBranchFromCodebaseRoot :: Path.Absolute
|
|
||||||
pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch)
|
|
||||||
-- If the provided ui path matches a definition, find it.
|
-- 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
|
getDefinitionRef perspective = runMaybeT $ do
|
||||||
Cli.Env {codebase} <- lift ask
|
Cli.Env {codebase} <- lift ask
|
||||||
let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot)
|
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath
|
||||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition
|
let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace
|
||||||
namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing)
|
namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath
|
||||||
fqn <- hoistMaybe $ do
|
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
|
Path.toName . Path.fromList $ pathFromPerspective
|
||||||
def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn
|
def <- MaybeT $ getTermOrTypeRef codebase namespaceBranch fqn
|
||||||
pure def
|
pure def
|
||||||
@ -89,35 +74,6 @@ getTermOrTypeRef codebase namespaceBranch fqn = runMaybeT $ do
|
|||||||
pure (toTypeReference fqn oneType)
|
pure (toTypeReference fqn oneType)
|
||||||
terms <|> types
|
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 -> V2.Reference -> Server.DefinitionReference
|
||||||
toTypeReference name reference =
|
toTypeReference name reference =
|
||||||
Server.TypeReference $
|
Server.TypeReference $
|
||||||
|
@ -22,6 +22,7 @@ import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
|
|||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch (Branch0)
|
import Unison.Codebase.Branch (Branch0)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
|
import Unison.Codebase.Branch.Names as Branch
|
||||||
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||||
import Unison.Codebase.Editor.Input
|
import Unison.Codebase.Editor.Input
|
||||||
import Unison.Codebase.Editor.Output
|
import Unison.Codebase.Editor.Output
|
||||||
@ -73,6 +74,7 @@ import Unison.WatchKind (WatchKind)
|
|||||||
handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli ()
|
handleUpdate :: Input -> OptionalPatch -> Set Name -> Cli ()
|
||||||
handleUpdate input optionalPatch requestedNames = do
|
handleUpdate input optionalPatch requestedNames = do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
|
pp <- Cli.getCurrentProjectPath
|
||||||
currentPath' <- Cli.getCurrentPath
|
currentPath' <- Cli.getCurrentPath
|
||||||
let patchPath =
|
let patchPath =
|
||||||
case optionalPatch of
|
case optionalPatch of
|
||||||
@ -171,37 +173,46 @@ handleUpdate input optionalPatch requestedNames = do
|
|||||||
pure (updatePatch ye'ol'Patch, updatePatches, p)
|
pure (updatePatch ye'ol'Patch, updatePatches, p)
|
||||||
|
|
||||||
when (Slurp.hasAddsOrUpdates sr) $ do
|
when (Slurp.hasAddsOrUpdates sr) $ do
|
||||||
-- take a look at the `updates` from the SlurpResult
|
-- First add the new definitions to the codebase
|
||||||
-- and make a patch diff to record a replacement from the old to new references
|
|
||||||
Cli.stepManyAtMNoSync
|
|
||||||
( [ ( Path.unabsolute currentPath',
|
|
||||||
pure . doSlurpUpdates typeEdits termEdits termDeprecations
|
|
||||||
),
|
|
||||||
( Path.unabsolute currentPath',
|
|
||||||
pure . doSlurpAdds addsAndUpdates (Slurp.originalFile sr)
|
|
||||||
)
|
|
||||||
]
|
|
||||||
++ case patchOps of
|
|
||||||
Nothing -> []
|
|
||||||
Just (_, update, p) -> [(Path.unabsolute p, update)]
|
|
||||||
)
|
|
||||||
Cli.runTransaction
|
Cli.runTransaction
|
||||||
. Codebase.addDefsToCodebase codebase
|
. Codebase.addDefsToCodebase codebase
|
||||||
. Slurp.filterUnisonFile sr
|
. Slurp.filterUnisonFile sr
|
||||||
$ Slurp.originalFile 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
|
let codebaseAndFileNames = UF.addNamesFromTypeCheckedUnisonFile (Slurp.originalFile sr) currentCodebaseNames
|
||||||
pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames
|
pped <- Cli.prettyPrintEnvDeclFromNames codebaseAndFileNames
|
||||||
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||||
whenJust patchOps \(updatedPatch, _, _) ->
|
branchWithPropagatedPatch <- case patchOps of
|
||||||
void $ propagatePatchNoSync updatedPatch currentPath'
|
Nothing -> pure updatedBranch
|
||||||
Cli.syncRoot case patchPath of
|
Just (updatedPatch, _, _) -> do
|
||||||
Nothing -> "update.nopatch"
|
propagatePatch updatedPatch (Path.unabsolute currentPath') updatedBranch
|
||||||
Just p ->
|
let description = case patchPath of
|
||||||
p
|
Nothing -> "update.nopatch"
|
||||||
& Path.unsplit'
|
Just p ->
|
||||||
& Path.resolve @_ @_ @Path.Absolute currentPath'
|
p
|
||||||
& tShow
|
& Path.unsplit'
|
||||||
|
& Path.resolve @_ @_ @Path.Absolute currentPath'
|
||||||
|
& tShow
|
||||||
|
void $ Cli.updateAt description pp (const branchWithPropagatedPatch)
|
||||||
|
|
||||||
getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult
|
getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult
|
||||||
getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||||
@ -646,10 +657,11 @@ doSlurpUpdates typeEdits termEdits deprecated b0 =
|
|||||||
split = Path.splitFromName n
|
split = Path.splitFromName n
|
||||||
|
|
||||||
-- Returns True if the operation changed the namespace, False otherwise.
|
-- Returns True if the operation changed the namespace, False otherwise.
|
||||||
propagatePatchNoSync :: Patch -> Path.Absolute -> Cli Bool
|
propagatePatch :: Patch -> Path.Path -> Branch.Branch IO -> Cli (Branch.Branch IO)
|
||||||
propagatePatchNoSync patch scopePath =
|
propagatePatch patch scopePath b = do
|
||||||
Cli.time "propagatePatchNoSync" do
|
Cli.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 :: [(Reference.Id, a)] -> [(Hash, [a])]
|
||||||
recomponentize =
|
recomponentize =
|
||||||
|
@ -49,6 +49,7 @@ import Unison.Codebase.Editor.Output (Output)
|
|||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path (Path)
|
import Unison.Codebase.Path (Path)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||||
import Unison.Codebase.Type (Codebase)
|
import Unison.Codebase.Type (Codebase)
|
||||||
import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
|
import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
|
||||||
import Unison.DataDeclaration (DataDeclaration, Decl)
|
import Unison.DataDeclaration (DataDeclaration, Decl)
|
||||||
@ -106,8 +107,8 @@ handleUpdate2 = do
|
|||||||
Cli.Env {codebase, writeSource} <- ask
|
Cli.Env {codebase, writeSource} <- ask
|
||||||
tuf <- Cli.expectLatestTypecheckedFile
|
tuf <- Cli.expectLatestTypecheckedFile
|
||||||
let termAndDeclNames = getTermAndDeclNames tuf
|
let termAndDeclNames = getTermAndDeclNames tuf
|
||||||
currentPath <- Cli.getCurrentPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
currentBranch0 <- Cli.getBranch0At currentPath
|
currentBranch0 <- Cli.getCurrentBranch0
|
||||||
let namesIncludingLibdeps = Branch.toNames currentBranch0
|
let namesIncludingLibdeps = Branch.toNames currentBranch0
|
||||||
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
|
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
|
||||||
let ctorNames = forwardCtorNames namesExcludingLibdeps
|
let ctorNames = forwardCtorNames namesExcludingLibdeps
|
||||||
@ -141,7 +142,7 @@ handleUpdate2 = do
|
|||||||
then pure tuf
|
then pure tuf
|
||||||
else do
|
else do
|
||||||
Cli.respond Output.UpdateStartTypechecking
|
Cli.respond Output.UpdateStartTypechecking
|
||||||
parsingEnv <- makeParsingEnv currentPath namesIncludingLibdeps
|
parsingEnv <- makeParsingEnv pp namesIncludingLibdeps
|
||||||
secondTuf <-
|
secondTuf <-
|
||||||
prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do
|
prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do
|
||||||
scratchFilePath <- fst <$> Cli.expectLatestFile
|
scratchFilePath <- fst <$> Cli.expectLatestFile
|
||||||
@ -185,7 +186,7 @@ prettyParseTypecheck2 prettyUf parsingEnv = do
|
|||||||
Result.Result _notes Nothing -> Left prettyUf
|
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 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
|
makeParsingEnv path names = do
|
||||||
Cli.Env {generateUniqueName} <- ask
|
Cli.Env {generateUniqueName} <- ask
|
||||||
uniqueName <- liftIO generateUniqueName
|
uniqueName <- liftIO generateUniqueName
|
||||||
@ -200,12 +201,12 @@ makeParsingEnv path names = do
|
|||||||
saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
|
saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
|
||||||
saveTuf getConstructors tuf = do
|
saveTuf getConstructors tuf = do
|
||||||
Cli.Env {codebase} <- ask
|
Cli.Env {codebase} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
branchUpdates <-
|
branchUpdates <-
|
||||||
Cli.runTransactionWithRollback \abort -> do
|
Cli.runTransactionWithRollback \abort -> do
|
||||||
Codebase.addDefsToCodebase codebase tuf
|
Codebase.addDefsToCodebase codebase tuf
|
||||||
typecheckedUnisonFileToBranchUpdates abort getConstructors 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
|
-- @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@.
|
-- 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 Data.Text qualified as Text
|
||||||
import Text.Builder qualified
|
import Text.Builder qualified
|
||||||
import U.Codebase.Sqlite.DbId (ProjectId)
|
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 (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils 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 qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Branch.Names 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.Branch qualified as HandleInput.Branch
|
||||||
import Unison.Codebase.Editor.HandleInput.Update2
|
import Unison.Codebase.Editor.HandleInput.Update2
|
||||||
( addDefinitionsToUnisonFile,
|
( addDefinitionsToUnisonFile,
|
||||||
@ -34,6 +33,7 @@ import Unison.Codebase.Editor.HandleInput.Update2
|
|||||||
)
|
)
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
import Unison.Name qualified as 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.PrettyPrintEnv.Names qualified as PPE
|
||||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
|
import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
|
import Unison.Project (ProjectBranchName)
|
||||||
import Unison.Reference (TermReference, TypeReference)
|
import Unison.Reference (TermReference, TypeReference)
|
||||||
import Unison.Referent (Referent)
|
import Unison.Referent (Referent)
|
||||||
import Unison.Referent qualified as Referent
|
import Unison.Referent qualified as Referent
|
||||||
@ -66,13 +66,10 @@ handleUpgrade oldName newName = do
|
|||||||
|
|
||||||
Cli.Env {codebase, writeSource} <- ask
|
Cli.Env {codebase, writeSource} <- ask
|
||||||
|
|
||||||
(projectAndBranch, _path) <- Cli.expectCurrentProjectBranch
|
let oldPath = Path.Absolute (Path.fromList [NameSegment.libSegment, oldName])
|
||||||
let projectId = projectAndBranch.project.projectId
|
let newPath = Path.Absolute (Path.fromList [NameSegment.libSegment, newName])
|
||||||
let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId projectAndBranch.branch.branchId)
|
|
||||||
let oldPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldName]))
|
|
||||||
let newPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newName]))
|
|
||||||
|
|
||||||
currentNamespace <- Cli.getBranch0At projectPath
|
currentNamespace <- Cli.getCurrentProjectRoot0
|
||||||
let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace
|
let currentNamespaceSansOld = Branch.deleteLibdep oldName currentNamespace
|
||||||
let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld
|
let currentDeepTermsSansOld = Branch.deepTerms currentNamespaceSansOld
|
||||||
let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld
|
let currentDeepTypesSansOld = Branch.deepTypes currentNamespaceSansOld
|
||||||
@ -80,7 +77,7 @@ handleUpgrade oldName newName = do
|
|||||||
let currentLocalConstructorNames = forwardCtorNames currentLocalNames
|
let currentLocalConstructorNames = forwardCtorNames currentLocalNames
|
||||||
let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld
|
let currentDeepNamesSansOld = Branch.toNames currentNamespaceSansOld
|
||||||
|
|
||||||
oldNamespace <- Cli.expectBranch0AtPath' oldPath
|
oldNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' oldPath)
|
||||||
let oldLocalNamespace = Branch.deleteLibdeps oldNamespace
|
let oldLocalNamespace = Branch.deleteLibdeps oldNamespace
|
||||||
let oldLocalTerms = Branch.deepTerms oldLocalNamespace
|
let oldLocalTerms = Branch.deepTerms oldLocalNamespace
|
||||||
let oldLocalTypes = Branch.deepTypes oldLocalNamespace
|
let oldLocalTypes = Branch.deepTypes oldLocalNamespace
|
||||||
@ -88,7 +85,7 @@ handleUpgrade oldName newName = do
|
|||||||
let oldDeepMinusLocalTerms = Branch.deepTerms oldNamespaceMinusLocal
|
let oldDeepMinusLocalTerms = Branch.deepTerms oldNamespaceMinusLocal
|
||||||
let oldDeepMinusLocalTypes = Branch.deepTypes oldNamespaceMinusLocal
|
let oldDeepMinusLocalTypes = Branch.deepTypes oldNamespaceMinusLocal
|
||||||
|
|
||||||
newNamespace <- Cli.expectBranch0AtPath' newPath
|
newNamespace <- Cli.expectBranch0AtPath' (Path.AbsolutePath' newPath)
|
||||||
let newLocalNamespace = Branch.deleteLibdeps newNamespace
|
let newLocalNamespace = Branch.deleteLibdeps newNamespace
|
||||||
let newLocalTerms = Branch.deepTerms newLocalNamespace
|
let newLocalTerms = Branch.deepTerms newLocalNamespace
|
||||||
let newLocalTypes = Branch.deepTypes newLocalNamespace
|
let newLocalTypes = Branch.deepTypes newLocalNamespace
|
||||||
@ -152,27 +149,24 @@ handleUpgrade oldName newName = do
|
|||||||
`PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents
|
`PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents
|
||||||
)
|
)
|
||||||
|
|
||||||
parsingEnv <- makeParsingEnv projectPath currentDeepNamesSansOld
|
pp@(PP.ProjectPath project projectBranch _path) <- Cli.getCurrentProjectPath
|
||||||
|
parsingEnv <- makeParsingEnv pp currentDeepNamesSansOld
|
||||||
typecheckedUnisonFile <-
|
typecheckedUnisonFile <-
|
||||||
prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do
|
prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do
|
||||||
-- Small race condition: since picking a branch name and creating the branch happen in different
|
let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName
|
||||||
-- transactions, creating could fail.
|
(_temporaryBranchId, temporaryBranchName) <-
|
||||||
temporaryBranchName <- Cli.runTransaction (findTemporaryBranchName projectId oldName newName)
|
HandleInput.Branch.createBranch
|
||||||
temporaryBranchId <-
|
|
||||||
HandleInput.Branch.doCreateBranch
|
|
||||||
(HandleInput.Branch.CreateFrom'Branch projectAndBranch)
|
|
||||||
projectAndBranch.project
|
|
||||||
temporaryBranchName
|
|
||||||
textualDescriptionOfUpgrade
|
textualDescriptionOfUpgrade
|
||||||
let temporaryBranchPath = Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
|
(CreateFrom'ParentBranch projectBranch)
|
||||||
Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, \_ -> currentNamespaceSansOld)
|
project
|
||||||
|
getTemporaryBranchName
|
||||||
scratchFilePath <-
|
scratchFilePath <-
|
||||||
Cli.getLatestFile <&> \case
|
Cli.getLatestFile <&> \case
|
||||||
Nothing -> "scratch.u"
|
Nothing -> "scratch.u"
|
||||||
Just (file, _) -> file
|
Just (file, _) -> file
|
||||||
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
|
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
|
||||||
Cli.returnEarly $
|
Cli.returnEarly $
|
||||||
Output.UpgradeFailure projectAndBranch.branch.name temporaryBranchName scratchFilePath oldName newName
|
Output.UpgradeFailure (projectBranch ^. #name) temporaryBranchName scratchFilePath oldName newName
|
||||||
|
|
||||||
branchUpdates <-
|
branchUpdates <-
|
||||||
Cli.runTransactionWithRollback \abort -> do
|
Cli.runTransactionWithRollback \abort -> do
|
||||||
@ -183,7 +177,7 @@ handleUpgrade oldName newName = do
|
|||||||
typecheckedUnisonFile
|
typecheckedUnisonFile
|
||||||
Cli.stepAt
|
Cli.stepAt
|
||||||
textualDescriptionOfUpgrade
|
textualDescriptionOfUpgrade
|
||||||
( Path.unabsolute projectPath,
|
( PP.toRoot pp,
|
||||||
Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates
|
Branch.deleteLibdep oldName . Branch.batchUpdates branchUpdates
|
||||||
)
|
)
|
||||||
Cli.respond (Output.UpgradeSuccess oldName newName)
|
Cli.respond (Output.UpgradeSuccess oldName newName)
|
||||||
|
@ -9,9 +9,10 @@ module Unison.Codebase.Editor.Input
|
|||||||
Event (..),
|
Event (..),
|
||||||
OutputLocation (..),
|
OutputLocation (..),
|
||||||
PatchPath,
|
PatchPath,
|
||||||
|
BranchIdG (..),
|
||||||
BranchId,
|
BranchId,
|
||||||
AbsBranchId,
|
AbsBranchId,
|
||||||
LooseCodeOrProject,
|
UnresolvedProjectBranch,
|
||||||
parseBranchId,
|
parseBranchId,
|
||||||
parseBranchId2,
|
parseBranchId2,
|
||||||
parseShortCausalHash,
|
parseShortCausalHash,
|
||||||
@ -31,10 +32,11 @@ import Data.List.NonEmpty (NonEmpty)
|
|||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.These (These)
|
import Data.These (These)
|
||||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
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 (Path, Path')
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Codebase.Path.Parse qualified as Path
|
import Unison.Codebase.Path.Parse qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
@ -60,15 +62,24 @@ type PatchPath = Path.Split'
|
|||||||
data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
|
data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
type BranchId = Either ShortCausalHash Path'
|
data BranchIdG p
|
||||||
|
= BranchAtSCH ShortCausalHash
|
||||||
|
| BranchAtPath p
|
||||||
|
| BranchAtProjectPath ProjectPath
|
||||||
|
deriving stock (Eq, Show, Functor, Foldable, Traversable)
|
||||||
|
|
||||||
-- | A lot of commands can take either a loose code path or a project branch in the same argument slot. Usually, those
|
instance From p Text => From (BranchIdG p) Text where
|
||||||
-- have distinct syntaxes, but sometimes it's ambiguous, in which case we'd parse a `These`. The command itself can
|
from = \case
|
||||||
-- decide what to do with the ambiguity.
|
BranchAtSCH h -> "#" <> SCH.toText h
|
||||||
type LooseCodeOrProject =
|
BranchAtPath p -> from p
|
||||||
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
BranchAtProjectPath pp -> from pp
|
||||||
|
|
||||||
type AbsBranchId = Either ShortCausalHash Path.Absolute
|
type BranchId = BranchIdG Path'
|
||||||
|
|
||||||
|
type AbsBranchId = BranchIdG Path.Absolute
|
||||||
|
|
||||||
|
-- | An unambiguous project branch name, use the current project name if not provided.
|
||||||
|
type UnresolvedProjectBranch = ProjectAndBranch (Maybe ProjectName) ProjectBranchName
|
||||||
|
|
||||||
type HashOrHQSplit' = Either ShortHash Path.HQSplit'
|
type HashOrHQSplit' = Either ShortHash Path.HQSplit'
|
||||||
|
|
||||||
@ -79,8 +90,8 @@ data Insistence = Force | Try
|
|||||||
parseBranchId :: String -> Either Text BranchId
|
parseBranchId :: String -> Either Text BranchId
|
||||||
parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
|
parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||||
Nothing -> Left "Invalid hash, expected a base32hex string."
|
Nothing -> Left "Invalid hash, expected a base32hex string."
|
||||||
Just h -> pure $ Left h
|
Just h -> pure $ BranchAtSCH h
|
||||||
parseBranchId s = Right <$> Path.parsePath' s
|
parseBranchId s = BranchAtPath <$> Path.parsePath' s
|
||||||
|
|
||||||
parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
|
parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
|
||||||
parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of
|
parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||||
@ -106,18 +117,13 @@ data Input
|
|||||||
-- clone w/o merge, error if would clobber
|
-- clone w/o merge, error if would clobber
|
||||||
ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath
|
ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath
|
||||||
| -- merge first causal into destination
|
| -- merge first causal into destination
|
||||||
MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode
|
MergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath) Branch.MergeMode
|
||||||
| PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject
|
| PreviewMergeLocalBranchI BranchRelativePath (Maybe BranchRelativePath)
|
||||||
| DiffNamespaceI BranchId BranchId -- old new
|
| DiffNamespaceI BranchId BranchId -- old new
|
||||||
| PullI !PullSourceTarget !PullMode
|
| PullI !PullSourceTarget !PullMode
|
||||||
| PushRemoteBranchI PushRemoteBranchInput
|
| PushRemoteBranchI PushRemoteBranchInput
|
||||||
| ResetRootI (Either ShortCausalHash Path')
|
| ResetRootI BranchId
|
||||||
| ResetI
|
| ResetI BranchId (Maybe UnresolvedProjectBranch)
|
||||||
( These
|
|
||||||
(Either ShortCausalHash Path')
|
|
||||||
(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
|
||||||
)
|
|
||||||
(Maybe LooseCodeOrProject)
|
|
||||||
| -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
|
| -- 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?
|
-- Does it make sense to fork from not-the-root of a Github repo?
|
||||||
-- used in Welcome module to give directions to user
|
-- used in Welcome module to give directions to user
|
||||||
@ -237,8 +243,8 @@ data BranchSourceI
|
|||||||
BranchSourceI'CurrentContext
|
BranchSourceI'CurrentContext
|
||||||
| -- | Create an empty branch
|
| -- | Create an empty branch
|
||||||
BranchSourceI'Empty
|
BranchSourceI'Empty
|
||||||
| -- | Create a branch from this loose-code-or-project
|
| -- | Create a branch from this other branch
|
||||||
BranchSourceI'LooseCodeOrProject LooseCodeOrProject
|
BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
-- | Pull source and target: either neither is specified, or only a source, or both.
|
-- | Pull source and target: either neither is specified, or only a source, or both.
|
||||||
@ -249,15 +255,14 @@ data PullSourceTarget
|
|||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
data PushSource
|
data PushSource
|
||||||
= PathySource Path'
|
= ProjySource (These ProjectName ProjectBranchName)
|
||||||
| ProjySource (These ProjectName ProjectBranchName)
|
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
-- | Push source and target: either neither is specified, or only a target, or both.
|
-- | Push source and target: either neither is specified, or only a target, or both.
|
||||||
data PushSourceTarget
|
data PushSourceTarget
|
||||||
= PushSourceTarget0
|
= PushSourceTarget0
|
||||||
| PushSourceTarget1 (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
| PushSourceTarget1 (These ProjectName ProjectBranchName)
|
||||||
| PushSourceTarget2 PushSource (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
| PushSourceTarget2 PushSource (These ProjectName ProjectBranchName)
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
data PushRemoteBranchInput = PushRemoteBranchInput
|
data PushRemoteBranchInput = PushRemoteBranchInput
|
||||||
@ -304,7 +309,7 @@ data DeleteTarget
|
|||||||
= DeleteTarget'TermOrType DeleteOutput [Path.HQSplit']
|
= DeleteTarget'TermOrType DeleteOutput [Path.HQSplit']
|
||||||
| DeleteTarget'Term DeleteOutput [Path.HQSplit']
|
| DeleteTarget'Term DeleteOutput [Path.HQSplit']
|
||||||
| DeleteTarget'Type 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'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||||
| DeleteTarget'Project ProjectName
|
| DeleteTarget'Project ProjectName
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
@ -43,10 +43,11 @@ import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
|||||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
|
import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
|
||||||
import Unison.Codebase.Path (Path')
|
import Unison.Codebase.Path (Path')
|
||||||
import Unison.Codebase.Path qualified as 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.Runtime qualified as Runtime
|
||||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
|
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||||
import Unison.CommandLine.InputPattern qualified as Input
|
import Unison.CommandLine.InputPattern qualified as Input
|
||||||
import Unison.DataDeclaration qualified as DD
|
import Unison.DataDeclaration qualified as DD
|
||||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||||
@ -98,25 +99,25 @@ type NumberedArgs = [StructuredArgument]
|
|||||||
type HashLength = Int
|
type HashLength = Int
|
||||||
|
|
||||||
data NumberedOutput
|
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)
|
| ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
| ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
| ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
| ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterMerge
|
| ShowDiffAfterMerge
|
||||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||||
Path.Absolute
|
ProjectPath
|
||||||
PPE.PrettyPrintEnv
|
PPE.PrettyPrintEnv
|
||||||
(BranchDiffOutput Symbol Ann)
|
(BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterMergePropagate
|
| ShowDiffAfterMergePropagate
|
||||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||||
Path.Absolute
|
ProjectPath
|
||||||
Path.Path'
|
Path.Path'
|
||||||
PPE.PrettyPrintEnv
|
PPE.PrettyPrintEnv
|
||||||
(BranchDiffOutput Symbol Ann)
|
(BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterMergePreview
|
| ShowDiffAfterMergePreview
|
||||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||||
Path.Absolute
|
ProjectPath
|
||||||
PPE.PrettyPrintEnv
|
PPE.PrettyPrintEnv
|
||||||
(BranchDiffOutput Symbol Ann)
|
(BranchDiffOutput Symbol Ann)
|
||||||
| ShowDiffAfterPull Path.Path' Path.Absolute 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
|
| -- | List all direct dependencies which don't have any names in the current branch
|
||||||
ListNamespaceDependencies
|
ListNamespaceDependencies
|
||||||
PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace.
|
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.
|
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
|
||||||
|
|
||||||
data TodoOutput = TodoOutput
|
data TodoOutput = TodoOutput
|
||||||
@ -285,7 +286,7 @@ data Output
|
|||||||
-- and a nicer render.
|
-- and a nicer render.
|
||||||
BustedBuiltins (Set Reference) (Set Reference)
|
BustedBuiltins (Set Reference) (Set Reference)
|
||||||
| ShareError ShareError
|
| ShareError ShareError
|
||||||
| ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
|
| ViewOnShare (URI, ProjectName, ProjectBranchName)
|
||||||
| NoConfiguredRemoteMapping PushPull Path.Absolute
|
| NoConfiguredRemoteMapping PushPull Path.Absolute
|
||||||
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
|
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
|
||||||
| TermMissingType Reference
|
| TermMissingType Reference
|
||||||
@ -303,14 +304,10 @@ data Output
|
|||||||
| AboutToMerge
|
| AboutToMerge
|
||||||
| -- | Indicates a trivial merge where the destination was empty and was just replaced.
|
| -- | Indicates a trivial merge where the destination was empty and was just replaced.
|
||||||
MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||||
| MergeAlreadyUpToDate
|
| MergeAlreadyUpToDate BranchRelativePath BranchRelativePath
|
||||||
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
|
|
||||||
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
|
|
||||||
| -- This will replace the above once `merge.old` is deleted
|
| -- This will replace the above once `merge.old` is deleted
|
||||||
MergeAlreadyUpToDate2 !MergeSourceAndTarget
|
MergeAlreadyUpToDate2 !MergeSourceAndTarget
|
||||||
| PreviewMergeAlreadyUpToDate
|
| PreviewMergeAlreadyUpToDate ProjectPath ProjectPath
|
||||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
|
||||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
|
||||||
| NotImplemented
|
| NotImplemented
|
||||||
| NoBranchWithHash ShortCausalHash
|
| NoBranchWithHash ShortCausalHash
|
||||||
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
|
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
|
||||||
@ -322,10 +319,8 @@ data Output
|
|||||||
| BadName Text
|
| BadName Text
|
||||||
| CouldntLoadBranch CausalHash
|
| CouldntLoadBranch CausalHash
|
||||||
| HelpMessage Input.InputPattern
|
| HelpMessage Input.InputPattern
|
||||||
| NamespaceEmpty (NonEmpty AbsBranchId)
|
| NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath))
|
||||||
| NoOp
|
| 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 repo@ means a causal was just published to @repo@.
|
||||||
GistCreated (ReadRemoteNamespace Void)
|
GistCreated (ReadRemoteNamespace Void)
|
||||||
| -- | Directs the user to URI to begin an authorization flow.
|
| -- | Directs the user to URI to begin an authorization flow.
|
||||||
@ -407,7 +402,6 @@ data Output
|
|||||||
| UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int)
|
| UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int)
|
||||||
| UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment
|
| UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment
|
||||||
| UpgradeSuccess !NameSegment !NameSegment
|
| UpgradeSuccess !NameSegment !NameSegment
|
||||||
| LooseCodePushDeprecated
|
|
||||||
| MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName
|
| MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName
|
||||||
| MergeSuccess !MergeSourceAndTarget
|
| MergeSuccess !MergeSourceAndTarget
|
||||||
| MergeSuccessFastForward !MergeSourceAndTarget
|
| MergeSuccessFastForward !MergeSourceAndTarget
|
||||||
@ -443,12 +437,10 @@ data CreatedProjectBranchFrom
|
|||||||
-- | A branch was empty. But how do we refer to that branch?
|
-- | A branch was empty. But how do we refer to that branch?
|
||||||
data WhichBranchEmpty
|
data WhichBranchEmpty
|
||||||
= WhichBranchEmptyHash ShortCausalHash
|
= WhichBranchEmptyHash ShortCausalHash
|
||||||
| WhichBranchEmptyPath Path'
|
| WhichBranchEmptyPath ProjectPath
|
||||||
|
|
||||||
data ShareError
|
data ShareError
|
||||||
= ShareErrorCheckAndSetPush Sync.CheckAndSetPushError
|
= ShareErrorDownloadEntities Share.DownloadEntitiesError
|
||||||
| ShareErrorDownloadEntities Share.DownloadEntitiesError
|
|
||||||
| ShareErrorFastForwardPush Sync.FastForwardPushError
|
|
||||||
| ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError
|
| ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError
|
||||||
| ShareErrorPull Sync.PullError
|
| ShareErrorPull Sync.PullError
|
||||||
| ShareErrorTransport Sync.CodeserverTransportError
|
| ShareErrorTransport Sync.CodeserverTransportError
|
||||||
@ -581,7 +573,6 @@ isFailure o = case o of
|
|||||||
TermMissingType {} -> True
|
TermMissingType {} -> True
|
||||||
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
|
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
|
||||||
NamespaceEmpty {} -> True
|
NamespaceEmpty {} -> True
|
||||||
RefusedToPush {} -> True
|
|
||||||
GistCreated {} -> False
|
GistCreated {} -> False
|
||||||
InitiateAuthFlow {} -> False
|
InitiateAuthFlow {} -> False
|
||||||
UnknownCodeServer {} -> True
|
UnknownCodeServer {} -> True
|
||||||
@ -645,7 +636,6 @@ isFailure o = case o of
|
|||||||
ProjectHasNoReleases {} -> True
|
ProjectHasNoReleases {} -> True
|
||||||
UpgradeFailure {} -> True
|
UpgradeFailure {} -> True
|
||||||
UpgradeSuccess {} -> False
|
UpgradeSuccess {} -> False
|
||||||
LooseCodePushDeprecated -> True
|
|
||||||
MergeFailure {} -> True
|
MergeFailure {} -> True
|
||||||
MergeSuccess {} -> False
|
MergeSuccess {} -> False
|
||||||
MergeSuccessFastForward {} -> False
|
MergeSuccessFastForward {} -> False
|
||||||
|
@ -14,7 +14,6 @@ import U.Codebase.Reference qualified as Reference
|
|||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as 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.Cli.TypeCheck qualified as Cli (computeTypecheckingEnvironment)
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
@ -82,11 +81,12 @@ noEdits :: Edits v
|
|||||||
noEdits = Edits mempty mempty mempty mempty mempty mempty mempty
|
noEdits = Edits mempty mempty mempty mempty mempty mempty mempty
|
||||||
|
|
||||||
propagateAndApply ::
|
propagateAndApply ::
|
||||||
|
Names ->
|
||||||
Patch ->
|
Patch ->
|
||||||
Branch0 IO ->
|
Branch0 IO ->
|
||||||
Cli (Branch0 IO)
|
Cli (Branch0 IO)
|
||||||
propagateAndApply patch branch = do
|
propagateAndApply rootNames patch branch = do
|
||||||
edits <- propagate patch branch
|
edits <- propagate rootNames patch branch
|
||||||
let f = applyPropagate patch edits
|
let f = applyPropagate patch edits
|
||||||
(pure . f . applyDeprecations patch) branch
|
(pure . f . applyDeprecations patch) branch
|
||||||
|
|
||||||
@ -234,15 +234,13 @@ debugMode = False
|
|||||||
--
|
--
|
||||||
-- "dirty" means in need of update
|
-- "dirty" means in need of update
|
||||||
-- "frontier" means updated definitions responsible for the "dirty"
|
-- "frontier" means updated definitions responsible for the "dirty"
|
||||||
propagate :: Patch -> Branch0 IO -> Cli (Edits Symbol)
|
propagate :: Names -> Patch -> Branch0 IO -> Cli (Edits Symbol)
|
||||||
propagate patch b = case validatePatch patch of
|
propagate rootNames patch b = case validatePatch patch of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
Cli.respond PatchNeedsToBeConflictFree
|
Cli.respond PatchNeedsToBeConflictFree
|
||||||
pure noEdits
|
pure noEdits
|
||||||
Just (initialTermEdits, initialTypeEdits) -> do
|
Just (initialTermEdits, initialTypeEdits) -> do
|
||||||
-- TODO: this can be removed once patches have term replacement of type `Referent -> Referent`
|
-- 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
|
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
|
-- about printing meaningful names for definitions during propagation, or if
|
||||||
-- we want to just remove the tracing.
|
-- we want to just remove the tracing.
|
||||||
|
@ -1,8 +1,7 @@
|
|||||||
module Unison.Codebase.Editor.UriParser
|
module Unison.Codebase.Editor.UriParser
|
||||||
( readRemoteNamespaceParser,
|
( readRemoteNamespaceParser,
|
||||||
writeRemoteNamespace,
|
|
||||||
writeRemoteNamespaceWith,
|
|
||||||
parseReadShareLooseCode,
|
parseReadShareLooseCode,
|
||||||
|
writeRemoteNamespace,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -17,8 +16,6 @@ import Unison.Codebase.Editor.RemoteRepo
|
|||||||
ReadShareLooseCode (..),
|
ReadShareLooseCode (..),
|
||||||
ShareCodeserver (DefaultCodeserver),
|
ShareCodeserver (DefaultCodeserver),
|
||||||
ShareUserHandle (..),
|
ShareUserHandle (..),
|
||||||
WriteRemoteNamespace (..),
|
|
||||||
WriteShareRemoteNamespace (..),
|
|
||||||
)
|
)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.NameSegment (NameSegment)
|
||||||
@ -53,25 +50,9 @@ parseReadShareLooseCode label input =
|
|||||||
|
|
||||||
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
|
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
|
||||||
-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = 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 =
|
writeRemoteNamespace =
|
||||||
writeRemoteNamespaceWith
|
(projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
|
||||||
(projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
|
|
||||||
|
|
||||||
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
|
|
||||||
writeRemoteNamespaceWith projectBranchParser =
|
|
||||||
WriteRemoteProjectBranch <$> projectBranchParser
|
|
||||||
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
|
|
||||||
|
|
||||||
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
|
|
||||||
-- Just (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})
|
|
||||||
writeShareRemoteNamespace :: P WriteShareRemoteNamespace
|
|
||||||
writeShareRemoteNamespace =
|
|
||||||
P.label "write share remote namespace" $
|
|
||||||
WriteShareRemoteNamespace
|
|
||||||
<$> pure DefaultCodeserver
|
|
||||||
<*> shareUserHandle
|
|
||||||
<*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
|
|
||||||
|
|
||||||
-- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
|
-- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
|
||||||
-- >>> 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.Text qualified as Text
|
||||||
import Data.These (These (..))
|
import Data.These (These (..))
|
||||||
import Data.UUID.V4 qualified as UUID
|
import Data.UUID.V4 qualified as UUID
|
||||||
import Ki qualified
|
|
||||||
import Network.HTTP.Client qualified as HTTP
|
import Network.HTTP.Client qualified as HTTP
|
||||||
import System.Directory (doesFileExist)
|
import System.Directory (doesFileExist)
|
||||||
import System.Environment (lookupEnv)
|
import System.Environment (lookupEnv)
|
||||||
@ -41,7 +40,6 @@ import System.IO qualified as IO
|
|||||||
import System.IO.Error (catchIOError)
|
import System.IO.Error (catchIOError)
|
||||||
import Text.Megaparsec qualified as P
|
import Text.Megaparsec qualified as P
|
||||||
import U.Codebase.Sqlite.DbId qualified as Db
|
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.Project (Project (..))
|
||||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||||
import U.Codebase.Sqlite.Queries qualified as Q
|
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 (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as 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.HandleInput qualified as HandleInput
|
||||||
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
|
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.Path.Parse qualified as Path
|
|
||||||
import Unison.Codebase.Runtime qualified as Runtime
|
import Unison.Codebase.Runtime qualified as Runtime
|
||||||
import Unison.Codebase.Verbosity (Verbosity, isSilent)
|
import Unison.Codebase.Verbosity (Verbosity, isSilent)
|
||||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
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.InputPatterns (validInputs)
|
||||||
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
|
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
|
||||||
import Unison.CommandLine.Welcome (asciiartUnison)
|
import Unison.CommandLine.Welcome (asciiartUnison)
|
||||||
|
import Unison.Core.Project (ProjectBranchName, ProjectName (..))
|
||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyTerminal
|
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.Runtime.Interface qualified as RTI
|
||||||
import Unison.Server.Backend qualified as Backend
|
import Unison.Server.Backend qualified as Backend
|
||||||
import Unison.Server.CodebaseServer qualified as Server
|
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>).
|
-- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>).
|
||||||
data UcmContext
|
data UcmContext
|
||||||
= UcmContextLooseCode Path.Absolute
|
= UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
|
||||||
| UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
|
|
||||||
|
|
||||||
data APIRequest
|
data APIRequest
|
||||||
= GetRequest Text
|
= GetRequest Text
|
||||||
@ -133,9 +130,7 @@ instance Show UcmLine where
|
|||||||
UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
|
UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
|
||||||
UcmComment txt -> "--" ++ Text.unpack txt
|
UcmComment txt -> "--" ++ Text.unpack txt
|
||||||
where
|
where
|
||||||
showContext = \case
|
showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
|
||||||
UcmContextLooseCode path -> show path
|
|
||||||
UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch)
|
|
||||||
|
|
||||||
instance Show Stanza where
|
instance Show Stanza where
|
||||||
show s = case s of
|
show s = case s of
|
||||||
@ -248,9 +243,14 @@ run ::
|
|||||||
UCMVersion ->
|
UCMVersion ->
|
||||||
Text ->
|
Text ->
|
||||||
IO (Either TranscriptError 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
|
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 $
|
unless (isSilent verbosity) . putPrettyLn $
|
||||||
Pretty.lines
|
Pretty.lines
|
||||||
[ asciiartUnison,
|
[ asciiartUnison,
|
||||||
@ -258,11 +258,6 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
|||||||
"Running the provided transcript file...",
|
"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
|
mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey
|
||||||
credMan <- AuthN.newCredentialManager
|
credMan <- AuthN.newCredentialManager
|
||||||
let tokenProvider :: AuthN.TokenProvider
|
let tokenProvider :: AuthN.TokenProvider
|
||||||
@ -346,15 +341,11 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
|||||||
liftIO (output ("\n" <> show p))
|
liftIO (output ("\n" <> show p))
|
||||||
awaitInput
|
awaitInput
|
||||||
p@(UcmCommand context lineTxt) -> do
|
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
|
-- 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.
|
-- the right context first, then run the command next.
|
||||||
maybeSwitchCommand <-
|
maybeSwitchCommand <-
|
||||||
case context of
|
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
|
UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do
|
||||||
Project {projectId, name = projectName} <-
|
Project {projectId, name = projectName} <-
|
||||||
Q.loadProjectByName projectName
|
Q.loadProjectByName projectName
|
||||||
@ -369,12 +360,12 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
||||||
let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName}
|
let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName}
|
||||||
Q.insertProjectBranch projectBranch
|
Q.insertProjectBranch "Branch Created" emptyCausalHashId projectBranch
|
||||||
pure projectBranch
|
pure projectBranch
|
||||||
Just projBranch -> pure projBranch
|
Just projBranch -> pure projBranch
|
||||||
let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId
|
let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId
|
||||||
pure
|
pure
|
||||||
if curPath == ProjectUtils.projectBranchPath projectAndBranchIds
|
if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds
|
||||||
then Nothing
|
then Nothing
|
||||||
else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName)))
|
else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName)))
|
||||||
case maybeSwitchCommand of
|
case maybeSwitchCommand of
|
||||||
@ -387,7 +378,8 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
|||||||
args -> do
|
args -> do
|
||||||
liftIO (output ("\n" <> show p <> "\n"))
|
liftIO (output ("\n" <> show p <> "\n"))
|
||||||
numberedArgs <- use #numberedArgs
|
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
|
-- invalid command is treated as a failure
|
||||||
Left msg -> do
|
Left msg -> do
|
||||||
liftIO $ writeIORef hasErrors True
|
liftIO $ writeIORef hasErrors True
|
||||||
@ -580,7 +572,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
|||||||
texts <- readIORef out
|
texts <- readIORef out
|
||||||
pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
|
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 :: IORef (Seq String) -> Text -> IO b
|
||||||
transcriptFailure out msg = do
|
transcriptFailure out msg = do
|
||||||
@ -605,9 +597,8 @@ ucmLine = ucmCommand <|> ucmComment
|
|||||||
P.try do
|
P.try do
|
||||||
contextString <- P.takeWhile1P Nothing (/= '>')
|
contextString <- P.takeWhile1P Nothing (/= '>')
|
||||||
context <-
|
context <-
|
||||||
case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of
|
case (tryFrom @Text contextString) of
|
||||||
(Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||||
(Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs)
|
|
||||||
_ -> fail "expected project/branch or absolute path"
|
_ -> fail "expected project/branch or absolute path"
|
||||||
void $ lineToken $ word ">"
|
void $ lineToken $ word ">"
|
||||||
pure context
|
pure context
|
||||||
|
@ -26,6 +26,7 @@ module Unison.CommandLine
|
|||||||
where
|
where
|
||||||
|
|
||||||
import Control.Concurrent (forkIO, killThread)
|
import Control.Concurrent (forkIO, killThread)
|
||||||
|
import Control.Lens hiding (aside)
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.Configurator (autoConfig, autoReload)
|
import Data.Configurator (autoConfig, autoReload)
|
||||||
@ -42,12 +43,11 @@ import Data.Vector qualified as Vector
|
|||||||
import System.FilePath (takeFileName)
|
import System.FilePath (takeFileName)
|
||||||
import Text.Regex.TDFA ((=~))
|
import Text.Regex.TDFA ((=~))
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
|
||||||
import Unison.Codebase.Branch (Branch0)
|
import Unison.Codebase.Branch (Branch0)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Editor.Input (Event (..), Input (..))
|
import Unison.Codebase.Editor.Input (Event (..), Input (..))
|
||||||
import Unison.Codebase.Editor.Output (NumberedArgs)
|
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.Codebase.Watch qualified as Watch
|
||||||
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
|
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
|
||||||
import Unison.CommandLine.FuzzySelect qualified as Fuzzy
|
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.CommandLine.InputPattern qualified as InputPattern
|
||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project.Util (ProjectContext, projectContextFromPath)
|
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Util.ColorText qualified as CT
|
import Unison.Util.ColorText qualified as CT
|
||||||
import Unison.Util.Monoid (foldMapM)
|
import Unison.Util.Monoid (foldMapM)
|
||||||
@ -121,8 +120,9 @@ nothingTodo = emojiNote "😶"
|
|||||||
|
|
||||||
parseInput ::
|
parseInput ::
|
||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
-- | Current path from root
|
-- | Current location
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
|
IO (Branch.Branch IO) ->
|
||||||
-- | Numbered arguments
|
-- | Numbered arguments
|
||||||
NumberedArgs ->
|
NumberedArgs ->
|
||||||
-- | Input Pattern Map
|
-- | Input Pattern Map
|
||||||
@ -132,10 +132,11 @@ parseInput ::
|
|||||||
-- Returns either an error message or the fully expanded arguments list and parsed input.
|
-- 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)
|
-- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c)
|
||||||
IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input)))
|
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)
|
let getCurrentBranch0 :: IO (Branch0 IO)
|
||||||
getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath
|
getCurrentBranch0 = do
|
||||||
let projCtx = projectContextFromPath currentPath
|
projRoot <- currentProjectRoot
|
||||||
|
pure . Branch.head $ Branch.getAt' (projPath ^. PP.path_) projRoot
|
||||||
|
|
||||||
case segments of
|
case segments of
|
||||||
[] -> throwE ""
|
[] -> throwE ""
|
||||||
@ -144,7 +145,7 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do
|
|||||||
let expandedNumbers :: InputPattern.Arguments
|
let expandedNumbers :: InputPattern.Arguments
|
||||||
expandedNumbers =
|
expandedNumbers =
|
||||||
foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args
|
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 (NoFZFResolverForArgumentType _argDesc) -> throwError help
|
||||||
Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc)
|
Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc)
|
||||||
Left FZFCancelled -> pure Nothing
|
Left FZFCancelled -> pure Nothing
|
||||||
@ -192,8 +193,8 @@ data FZFResolveFailure
|
|||||||
| NoFZFOptions Text {- argument description -}
|
| NoFZFOptions Text {- argument description -}
|
||||||
| FZFCancelled
|
| FZFCancelled
|
||||||
|
|
||||||
fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
|
fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments)
|
||||||
fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do
|
fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do
|
||||||
-- We resolve args in two steps, first we check that all arguments that will require a fzf
|
-- 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.
|
-- 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
|
-- 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 :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments
|
||||||
fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do
|
fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do
|
||||||
currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch
|
currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch
|
||||||
options <- liftIO $ getOptions codebase projCtx currentBranch
|
options <- liftIO $ getOptions codebase ppCtx currentBranch
|
||||||
when (null options) $ throwError $ NoFZFOptions argDesc
|
when (null options) $ throwError $ NoFZFOptions argDesc
|
||||||
liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc)
|
liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc)
|
||||||
results <-
|
results <-
|
||||||
|
@ -2,9 +2,9 @@ module Unison.CommandLine.BranchRelativePath
|
|||||||
( BranchRelativePath (..),
|
( BranchRelativePath (..),
|
||||||
parseBranchRelativePath,
|
parseBranchRelativePath,
|
||||||
branchRelativePathParser,
|
branchRelativePathParser,
|
||||||
ResolvedBranchRelativePath (..),
|
|
||||||
parseIncrementalBranchRelativePath,
|
parseIncrementalBranchRelativePath,
|
||||||
IncrementalBranchRelativePath (..),
|
IncrementalBranchRelativePath (..),
|
||||||
|
toText,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -14,10 +14,9 @@ import Data.These (These (..))
|
|||||||
import Text.Builder qualified
|
import Text.Builder qualified
|
||||||
import Text.Megaparsec qualified as Megaparsec
|
import Text.Megaparsec qualified as Megaparsec
|
||||||
import Text.Megaparsec.Char 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 qualified as Path
|
||||||
import Unison.Codebase.Path.Parse qualified as Path
|
import Unison.Codebase.Path.Parse qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||||
import Unison.Project qualified as Project
|
import Unison.Project qualified as Project
|
||||||
@ -25,8 +24,11 @@ import Unison.Util.ColorText qualified as CT
|
|||||||
import Unison.Util.Pretty qualified as P
|
import Unison.Util.Pretty qualified as P
|
||||||
|
|
||||||
data BranchRelativePath
|
data BranchRelativePath
|
||||||
= BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative)
|
= -- | A path rooted at some specified branch/project
|
||||||
| LoosePath Path.Path'
|
BranchPathInCurrentProject ProjectBranchName Path.Absolute
|
||||||
|
| QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute
|
||||||
|
| -- | A path which is relative to the user's current location.
|
||||||
|
UnqualifiedPath Path.Path'
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
-- | Strings without colons are parsed as loose code paths. A path with a colon may specify:
|
-- | 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))
|
Left e -> Left (P.string (Megaparsec.errorBundlePretty e))
|
||||||
Right x -> Right x
|
Right x -> Right x
|
||||||
|
|
||||||
|
-- |
|
||||||
|
-- >>> from @BranchRelativePath @Text (BranchPathInCurrentProject "foo" (Path.absoluteEmpty "bar"))
|
||||||
instance From BranchRelativePath Text where
|
instance From BranchRelativePath Text where
|
||||||
from = \case
|
from = \case
|
||||||
BranchRelative brArg -> case brArg of
|
BranchPathInCurrentProject branch path ->
|
||||||
This eitherProj ->
|
Text.Builder.run $
|
||||||
Text.Builder.run
|
Text.Builder.char '/'
|
||||||
( Text.Builder.text (eitherProjToText eitherProj)
|
<> Text.Builder.text (into @Text branch)
|
||||||
<> Text.Builder.char ':'
|
<> Text.Builder.char ':'
|
||||||
)
|
<> Text.Builder.text (Path.absToText path)
|
||||||
That path ->
|
QualifiedBranchPath proj branch path ->
|
||||||
Text.Builder.run
|
Text.Builder.run $
|
||||||
( Text.Builder.char ':'
|
Text.Builder.text (into @Text proj)
|
||||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
<> Text.Builder.char '/'
|
||||||
)
|
<> Text.Builder.text (into @Text branch)
|
||||||
These eitherProj path ->
|
<> Text.Builder.char ':'
|
||||||
Text.Builder.run
|
<> Text.Builder.text (Path.absToText path)
|
||||||
( Text.Builder.text (eitherProjToText eitherProj)
|
UnqualifiedPath path ->
|
||||||
<> Text.Builder.char ':'
|
Path.toText' path
|
||||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
|
||||||
)
|
|
||||||
LoosePath path -> Path.toText' path
|
|
||||||
where
|
|
||||||
eitherProjToText = \case
|
|
||||||
Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName)
|
|
||||||
Right (projName, branchName) -> into @Text (These projName branchName)
|
|
||||||
|
|
||||||
data ResolvedBranchRelativePath
|
|
||||||
= ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative)
|
|
||||||
| ResolvedLoosePath Path.Absolute
|
|
||||||
|
|
||||||
instance From ResolvedBranchRelativePath BranchRelativePath where
|
|
||||||
from = \case
|
|
||||||
ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of
|
|
||||||
Nothing -> BranchRelative (This (Right (view #name proj, view #name branch)))
|
|
||||||
Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel)
|
|
||||||
ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p)
|
|
||||||
|
|
||||||
instance From ResolvedBranchRelativePath Text where
|
|
||||||
from = from . into @BranchRelativePath
|
|
||||||
|
|
||||||
data IncrementalBranchRelativePath
|
data IncrementalBranchRelativePath
|
||||||
= -- | no dots, slashes, or colons
|
= -- | no dots, slashes, or colons, so could be a project name or a single path segment
|
||||||
ProjectOrRelative Text Path.Path'
|
ProjectOrPath' Text Path.Path'
|
||||||
| -- | dots, no slashes or colons
|
| -- | dots, no slashes or colons, must be a relative or absolute path
|
||||||
LooseCode Path.Path'
|
OnlyPath' Path.Path'
|
||||||
| -- | valid project, no slash
|
| -- | valid project, no slash
|
||||||
IncompleteProject ProjectName
|
IncompleteProject ProjectName
|
||||||
| -- | valid project/branch, slash, no colon
|
| -- | valid project/branch, slash, no colon
|
||||||
IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName)
|
IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName)
|
||||||
| -- | valid project/branch, with colon
|
| -- | 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
|
| PathRelativeToCurrentBranch Path.Relative
|
||||||
deriving stock (Show)
|
deriving stock (Show)
|
||||||
|
|
||||||
@ -158,9 +141,9 @@ incrementalBranchRelativePathParser =
|
|||||||
pure (IncompleteProject projectName)
|
pure (IncompleteProject projectName)
|
||||||
in end <|> startingAtSlash (Just projectName)
|
in end <|> startingAtSlash (Just projectName)
|
||||||
-- The string doesn't parse as a project name but does parse as a path
|
-- 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
|
-- 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 :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath
|
||||||
startingAtBranch mproj =
|
startingAtBranch mproj =
|
||||||
@ -180,7 +163,7 @@ incrementalBranchRelativePathParser =
|
|||||||
Megaparsec.Parsec Void Text IncrementalBranchRelativePath
|
Megaparsec.Parsec Void Text IncrementalBranchRelativePath
|
||||||
startingAtColon projStuff = do
|
startingAtColon projStuff = do
|
||||||
_ <- Megaparsec.char ':'
|
_ <- Megaparsec.char ':'
|
||||||
p <- optionalEof relPath
|
p <- optionalEof absPath
|
||||||
pure (IncompletePath projStuff p)
|
pure (IncompletePath projStuff p)
|
||||||
|
|
||||||
pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath
|
pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath
|
||||||
@ -190,18 +173,25 @@ incrementalBranchRelativePathParser =
|
|||||||
pure (PathRelativeToCurrentBranch p)
|
pure (PathRelativeToCurrentBranch p)
|
||||||
|
|
||||||
optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a)
|
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 :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName)
|
||||||
optionalBranch = optionalEof branchNameParser
|
optionalBranch = optionalEof branchNameParser
|
||||||
|
|
||||||
branchNameParser = Project.projectBranchNameParser False
|
branchNameParser = Project.projectBranchNameParser False
|
||||||
|
|
||||||
|
relPath :: Megaparsec.Parsec Void Text Path.Relative
|
||||||
relPath = do
|
relPath = do
|
||||||
offset <- Megaparsec.getOffset
|
offset <- Megaparsec.getOffset
|
||||||
path' >>= \(Path.Path' inner) -> case inner of
|
path' >>= \(Path.Path' inner) -> case inner of
|
||||||
Left _ -> failureAt offset "Expected a relative path but found an absolute path"
|
Left _ -> failureAt offset "Expected a relative path but found an absolute path"
|
||||||
Right x -> pure x
|
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
|
path' = Megaparsec.try do
|
||||||
offset <- Megaparsec.getOffset
|
offset <- Megaparsec.getOffset
|
||||||
pathStr <- Megaparsec.takeRest
|
pathStr <- Megaparsec.takeRest
|
||||||
@ -234,16 +224,20 @@ incrementalBranchRelativePathParser =
|
|||||||
branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
|
branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
|
||||||
branchRelativePathParser =
|
branchRelativePathParser =
|
||||||
incrementalBranchRelativePathParser >>= \case
|
incrementalBranchRelativePathParser >>= \case
|
||||||
ProjectOrRelative _txt path -> pure (LoosePath path)
|
ProjectOrPath' _txt path -> pure (UnqualifiedPath path)
|
||||||
LooseCode path -> pure (LoosePath path)
|
OnlyPath' path -> pure (UnqualifiedPath path)
|
||||||
IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here."
|
IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here."
|
||||||
IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. 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 ->
|
IncompletePath projStuff mpath ->
|
||||||
case projStuff of
|
case projStuff of
|
||||||
Left (ProjectAndBranch projName branchName) -> case mpath of
|
Left (ProjectAndBranch projName branchName) ->
|
||||||
Nothing -> pure (BranchRelative (This (Right (projName, branchName))))
|
pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath)
|
||||||
Just path -> pure (BranchRelative (These (Right (projName, branchName)) path))
|
Right branch ->
|
||||||
Right branch -> case mpath of
|
pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath)
|
||||||
Nothing -> pure (BranchRelative (This (Left branch)))
|
|
||||||
Just path -> pure (BranchRelative (These (Left branch) path))
|
toText :: BranchRelativePath -> Text
|
||||||
|
toText = \case
|
||||||
|
BranchPathInCurrentProject pbName absPath -> ProjectPath () pbName absPath & into @Text
|
||||||
|
QualifiedBranchPath projName pbName absPath -> ProjectPath projName pbName absPath & into @Text
|
||||||
|
UnqualifiedPath path' -> Path.toText' path'
|
||||||
|
@ -20,9 +20,8 @@ module Unison.CommandLine.Completion
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Lens (ifoldMap)
|
import Control.Lens
|
||||||
import Control.Lens qualified as Lens
|
import Control.Lens qualified as Lens
|
||||||
import Control.Lens.Cons (unsnoc)
|
|
||||||
import Data.Aeson qualified as Aeson
|
import Data.Aeson qualified as Aeson
|
||||||
import Data.List (isPrefixOf)
|
import Data.List (isPrefixOf)
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
@ -48,6 +47,7 @@ import Unison.Codebase (Codebase)
|
|||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Codebase.Path.Parse 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.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||||
import Unison.CommandLine.InputPattern qualified as IP
|
import Unison.CommandLine.InputPattern qualified as IP
|
||||||
import Unison.HashQualified' qualified as HQ'
|
import Unison.HashQualified' qualified as HQ'
|
||||||
@ -73,9 +73,9 @@ haskelineTabComplete ::
|
|||||||
Map String IP.InputPattern ->
|
Map String IP.InputPattern ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
Line.CompletionFunc m
|
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
|
-- User hasn't finished a command name, complete from command names
|
||||||
if null prev
|
if null prev
|
||||||
then pure . exactComplete word $ Map.keys patterns
|
then pure . exactComplete word $ Map.keys patterns
|
||||||
@ -84,7 +84,7 @@ haskelineTabComplete patterns codebase authedHTTPClient currentPath = Line.compl
|
|||||||
h : t -> fromMaybe (pure []) $ do
|
h : t -> fromMaybe (pure []) $ do
|
||||||
p <- Map.lookup h patterns
|
p <- Map.lookup h patterns
|
||||||
argType <- IP.argType p (length t)
|
argType <- IP.argType p (length t)
|
||||||
pure $ IP.suggestions argType word codebase authedHTTPClient currentPath
|
pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx
|
||||||
_ -> pure []
|
_ -> pure []
|
||||||
|
|
||||||
-- | Things which we may want to complete for.
|
-- | Things which we may want to complete for.
|
||||||
@ -101,7 +101,7 @@ noCompletions ::
|
|||||||
String ->
|
String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [System.Console.Haskeline.Completion.Completion]
|
m [System.Console.Haskeline.Completion.Completion]
|
||||||
noCompletions _ _ _ _ = pure []
|
noCompletions _ _ _ _ = pure []
|
||||||
|
|
||||||
@ -141,11 +141,11 @@ completeWithinNamespace ::
|
|||||||
NESet CompletionType ->
|
NESet CompletionType ->
|
||||||
-- | The portion of this are that the user has already typed.
|
-- | The portion of this are that the user has already typed.
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
||||||
completeWithinNamespace compTypes query currentPath = do
|
completeWithinNamespace compTypes query ppCtx = do
|
||||||
shortHashLen <- Codebase.hashLength
|
shortHashLen <- Codebase.hashLength
|
||||||
b <- Codebase.getShallowBranchAtPath (Path.unabsolute absQueryPath) Nothing
|
b <- Codebase.getShallowBranchAtProjectPath queryProjectPath
|
||||||
currentBranchSuggestions <- do
|
currentBranchSuggestions <- do
|
||||||
nib <- namesInBranch shortHashLen b
|
nib <- namesInBranch shortHashLen b
|
||||||
nib
|
nib
|
||||||
@ -168,8 +168,8 @@ completeWithinNamespace compTypes query currentPath = do
|
|||||||
queryPathPrefix :: Path.Path'
|
queryPathPrefix :: Path.Path'
|
||||||
querySuffix :: Text
|
querySuffix :: Text
|
||||||
(queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query)
|
(queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query)
|
||||||
absQueryPath :: Path.Absolute
|
queryProjectPath :: PP.ProjectPath
|
||||||
absQueryPath = Path.resolve currentPath queryPathPrefix
|
queryProjectPath = ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath queryPathPrefix
|
||||||
getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
|
getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
|
||||||
getChildSuggestions shortHashLen b
|
getChildSuggestions shortHashLen b
|
||||||
| Text.null querySuffix = pure []
|
| Text.null querySuffix = pure []
|
||||||
@ -274,35 +274,35 @@ parseLaxPath'Query txt =
|
|||||||
-- | Completes a namespace argument by prefix-matching against the query.
|
-- | Completes a namespace argument by prefix-matching against the query.
|
||||||
prefixCompleteNamespace ::
|
prefixCompleteNamespace ::
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [Line.Completion]
|
Sqlite.Transaction [Line.Completion]
|
||||||
prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion)
|
prefixCompleteNamespace = completeWithinNamespace (NESet.singleton NamespaceCompletion)
|
||||||
|
|
||||||
-- | Completes a term or type argument by prefix-matching against the query.
|
-- | Completes a term or type argument by prefix-matching against the query.
|
||||||
prefixCompleteTermOrType ::
|
prefixCompleteTermOrType ::
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [Line.Completion]
|
Sqlite.Transaction [Line.Completion]
|
||||||
prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion]))
|
prefixCompleteTermOrType = completeWithinNamespace (NESet.fromList (TermCompletion NE.:| [TypeCompletion]))
|
||||||
|
|
||||||
-- | Completes a term argument by prefix-matching against the query.
|
-- | Completes a term argument by prefix-matching against the query.
|
||||||
prefixCompleteTerm ::
|
prefixCompleteTerm ::
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [Line.Completion]
|
Sqlite.Transaction [Line.Completion]
|
||||||
prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion)
|
prefixCompleteTerm = completeWithinNamespace (NESet.singleton TermCompletion)
|
||||||
|
|
||||||
-- | Completes a term or type argument by prefix-matching against the query.
|
-- | Completes a term or type argument by prefix-matching against the query.
|
||||||
prefixCompleteType ::
|
prefixCompleteType ::
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [Line.Completion]
|
Sqlite.Transaction [Line.Completion]
|
||||||
prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion)
|
prefixCompleteType = completeWithinNamespace (NESet.singleton TypeCompletion)
|
||||||
|
|
||||||
-- | Completes a patch argument by prefix-matching against the query.
|
-- | Completes a patch argument by prefix-matching against the query.
|
||||||
prefixCompletePatch ::
|
prefixCompletePatch ::
|
||||||
String ->
|
String ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction [Line.Completion]
|
Sqlite.Transaction [Line.Completion]
|
||||||
prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion)
|
prefixCompletePatch = completeWithinNamespace (NESet.singleton PatchCompletion)
|
||||||
|
|
||||||
|
@ -37,13 +37,13 @@ import Unison.Codebase.Branch (Branch0)
|
|||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Path (Path, Path' (..))
|
import Unison.Codebase.Path (Path, Path' (..))
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Name qualified as Name
|
import Unison.Name qualified as Name
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
import Unison.Names qualified as Names
|
import Unison.Names qualified as Names
|
||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
import Unison.Position qualified as Position
|
import Unison.Position qualified as Position
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project.Util (ProjectContext (..))
|
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
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.Monoid qualified as Monoid
|
||||||
import Unison.Util.Relation qualified as Relation
|
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
|
data FZFResolver = FZFResolver
|
||||||
{ getOptions :: OptionFetcher
|
{ getOptions :: OptionFetcher
|
||||||
@ -121,7 +121,7 @@ fuzzySelectFromList options =
|
|||||||
-- | Combine multiple option fetchers into one resolver.
|
-- | Combine multiple option fetchers into one resolver.
|
||||||
multiResolver :: [OptionFetcher] -> FZFResolver
|
multiResolver :: [OptionFetcher] -> FZFResolver
|
||||||
multiResolver resolvers =
|
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
|
getOptions codebase projCtx searchBranch0 = do
|
||||||
List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers
|
List.nubOrd <$> foldMapM (\f -> f codebase projCtx searchBranch0) resolvers
|
||||||
in (FZFResolver {getOptions})
|
in (FZFResolver {getOptions})
|
||||||
@ -177,11 +177,8 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do
|
|||||||
-- E.g. '@unison/base/main'
|
-- E.g. '@unison/base/main'
|
||||||
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
||||||
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
||||||
case projCtx of
|
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing)
|
||||||
LooseCodePath _ -> pure []
|
<&> fmap (into @Text . snd)
|
||||||
ProjectBranchPath currentProjectId _projectBranchId _path -> do
|
|
||||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith currentProjectId Nothing)
|
|
||||||
<&> fmap (into @Text . snd)
|
|
||||||
|
|
||||||
-- | Exported from here just so the debug command and actual implementation can use the same
|
-- | Exported from here just so the debug command and actual implementation can use the same
|
||||||
-- messaging.
|
-- messaging.
|
||||||
|
@ -28,7 +28,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
|||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase.Editor.Input (Input (..))
|
import Unison.Codebase.Editor.Input (Input (..))
|
||||||
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
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.CommandLine.FZFResolvers (FZFResolver (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Util.ColorText qualified as CT
|
import Unison.Util.ColorText qualified as CT
|
||||||
@ -78,7 +78,7 @@ data ArgumentType = ArgumentType
|
|||||||
String ->
|
String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
m [Line.Completion],
|
m [Line.Completion],
|
||||||
-- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if
|
-- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if
|
||||||
-- available.
|
-- available.
|
||||||
@ -157,14 +157,14 @@ unionSuggestions ::
|
|||||||
[ ( String ->
|
[ ( String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
)
|
)
|
||||||
] ->
|
] ->
|
||||||
( String ->
|
( String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
)
|
)
|
||||||
unionSuggestions suggesters inp codebase httpClient path = do
|
unionSuggestions suggesters inp codebase httpClient path = do
|
||||||
@ -179,14 +179,14 @@ suggestionFallbacks ::
|
|||||||
[ ( String ->
|
[ ( String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
)
|
)
|
||||||
] ->
|
] ->
|
||||||
( String ->
|
( String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
)
|
)
|
||||||
suggestionFallbacks suggesters inp codebase httpClient path = go suggesters
|
suggestionFallbacks suggesters inp codebase httpClient path = go suggesters
|
||||||
|
@ -138,7 +138,6 @@ module Unison.CommandLine.InputPatterns
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Lens (preview, review)
|
|
||||||
import Control.Lens.Cons qualified as Cons
|
import Control.Lens.Cons qualified as Cons
|
||||||
import Data.Bitraversable (bitraverse)
|
import Data.Bitraversable (bitraverse)
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
@ -168,14 +167,13 @@ import Unison.Cli.Pretty
|
|||||||
prettySlashProjectBranchName,
|
prettySlashProjectBranchName,
|
||||||
prettyURI,
|
prettyURI,
|
||||||
)
|
)
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
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.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
|
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.RemoteRepo qualified as RemoteRepo
|
||||||
import Unison.Codebase.Editor.SlurpResult qualified as SR
|
import Unison.Codebase.Editor.SlurpResult qualified as SR
|
||||||
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
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 (Path, Path')
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Codebase.Path.Parse 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.PushBehavior qualified as PushBehavior
|
||||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
@ -213,7 +213,6 @@ import Unison.Project
|
|||||||
Semver,
|
Semver,
|
||||||
branchWithOptionalProjectParser,
|
branchWithOptionalProjectParser,
|
||||||
)
|
)
|
||||||
import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
|
|
||||||
import Unison.Referent qualified as Referent
|
import Unison.Referent qualified as Referent
|
||||||
import Unison.Server.Backend (ShallowListEntry (..))
|
import Unison.Server.Backend (ShallowListEntry (..))
|
||||||
import Unison.Server.Backend qualified as Backend
|
import Unison.Server.Backend qualified as Backend
|
||||||
@ -249,8 +248,13 @@ formatStructuredArgument schLength = \case
|
|||||||
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
|
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
|
||||||
prefixBranchId :: Input.AbsBranchId -> Name -> Text
|
prefixBranchId :: Input.AbsBranchId -> Name -> Text
|
||||||
prefixBranchId branchId name = case branchId of
|
prefixBranchId branchId name = case branchId of
|
||||||
Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
|
BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
|
||||||
Right pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
|
BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
|
||||||
|
BranchAtProjectPath pp ->
|
||||||
|
pp
|
||||||
|
& PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
|
||||||
|
& PP.toNames
|
||||||
|
& into @Text
|
||||||
|
|
||||||
entryToHQText :: Path' -> ShallowListEntry v Ann -> Text
|
entryToHQText :: Path' -> ShallowListEntry v Ann -> Text
|
||||||
entryToHQText pathArg =
|
entryToHQText pathArg =
|
||||||
@ -365,15 +369,6 @@ handleProjectArg =
|
|||||||
SA.Project project -> pure project
|
SA.Project project -> pure project
|
||||||
otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType
|
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 ::
|
handleMaybeProjectBranchArg ::
|
||||||
I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||||
handleMaybeProjectBranchArg =
|
handleMaybeProjectBranchArg =
|
||||||
@ -468,8 +463,8 @@ handleSplit'Arg =
|
|||||||
(first P.text . Path.parseSplit')
|
(first P.text . Path.parseSplit')
|
||||||
\case
|
\case
|
||||||
SA.Name name -> pure $ Path.splitFromName' name
|
SA.Name name -> pure $ Path.splitFromName' name
|
||||||
SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name
|
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name
|
||||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||||
pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg
|
otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg
|
||||||
|
|
||||||
@ -486,27 +481,34 @@ handleBranchIdArg =
|
|||||||
either
|
either
|
||||||
(first P.text . Input.parseBranchId)
|
(first P.text . Input.parseBranchId)
|
||||||
\case
|
\case
|
||||||
SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path
|
SA.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path
|
||||||
SA.Name name -> pure . pure $ Path.fromName' name
|
SA.Name name -> pure . BranchAtPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix mprefix name ->
|
SA.NameWithBranchPrefix mprefix name ->
|
||||||
pure . pure . Path.fromName' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') name mprefix
|
pure $ case mprefix of
|
||||||
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
|
BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name
|
||||||
|
BranchAtPath prefix -> BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
|
BranchAtProjectPath pp ->
|
||||||
|
pp
|
||||||
|
& PP.absPath_ %~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
|
||||||
|
& BranchAtProjectPath
|
||||||
|
SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash
|
||||||
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||||
|
|
||||||
handleBranchIdOrProjectArg ::
|
-- | TODO: Maybe remove?
|
||||||
|
_handleBranchIdOrProjectArg ::
|
||||||
I.Argument ->
|
I.Argument ->
|
||||||
Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
|
Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
|
||||||
handleBranchIdOrProjectArg =
|
_handleBranchIdOrProjectArg =
|
||||||
either
|
either
|
||||||
(maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject)
|
(maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject)
|
||||||
\case
|
\case
|
||||||
SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash
|
SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash
|
||||||
SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path
|
SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path
|
||||||
SA.Name name -> pure . This . pure $ Path.fromName' name
|
SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name
|
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||||
pure . This . pure . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
SA.ProjectBranch pb -> pure $ pure pb
|
SA.ProjectBranch pb -> pure $ That pb
|
||||||
otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType
|
otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType
|
||||||
where
|
where
|
||||||
branchIdOrProject ::
|
branchIdOrProject ::
|
||||||
@ -533,13 +535,15 @@ handleBranchId2Arg =
|
|||||||
Input.parseBranchId2
|
Input.parseBranchId2
|
||||||
\case
|
\case
|
||||||
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
|
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
|
||||||
SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path
|
SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path
|
||||||
SA.Name name -> pure . pure . LoosePath $ Path.fromName' name
|
SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name
|
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||||
pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
|
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
|
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||||
|
|
||||||
handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath
|
handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath
|
||||||
@ -547,13 +551,15 @@ handleBranchRelativePathArg =
|
|||||||
either
|
either
|
||||||
parseBranchRelativePath
|
parseBranchRelativePath
|
||||||
\case
|
\case
|
||||||
SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path
|
SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path
|
||||||
SA.Name name -> pure . LoosePath $ Path.fromName' name
|
SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name
|
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name
|
||||||
SA.NameWithBranchPrefix (Right prefix) name ->
|
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
|
||||||
pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
|
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
|
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
|
||||||
|
|
||||||
hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit'
|
hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit'
|
||||||
@ -585,8 +591,8 @@ handleHashQualifiedSplit'Arg =
|
|||||||
\case
|
\case
|
||||||
SA.Name name -> pure $ Path.hqSplitFromName' name
|
SA.Name name -> pure $ Path.hqSplitFromName' name
|
||||||
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name
|
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name
|
||||||
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname
|
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname
|
||||||
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
|
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||||
pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
||||||
SA.ShallowListEntry prefix entry ->
|
SA.ShallowListEntry prefix entry ->
|
||||||
pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||||
@ -608,8 +614,8 @@ handleHashQualifiedSplitArg =
|
|||||||
pure
|
pure
|
||||||
$ Path.hqSplitFromName' name
|
$ Path.hqSplitFromName' name
|
||||||
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name
|
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name
|
||||||
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname
|
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname
|
||||||
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
|
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||||
pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
|
||||||
SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry
|
SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry
|
||||||
sr@(SA.SearchResult mpath result) ->
|
sr@(SA.SearchResult mpath result) ->
|
||||||
@ -631,8 +637,8 @@ handleShortHashOrHQSplit'Arg =
|
|||||||
(first P.text . Path.parseShortHashOrHQSplit')
|
(first P.text . Path.parseShortHashOrHQSplit')
|
||||||
\case
|
\case
|
||||||
SA.HashQualified name -> pure $ hqNameToSplit' name
|
SA.HashQualified name -> pure $ hqNameToSplit' name
|
||||||
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname
|
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname
|
||||||
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
|
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||||
pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname)
|
pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname)
|
||||||
SA.ShallowListEntry prefix entry ->
|
SA.ShallowListEntry prefix entry ->
|
||||||
pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||||
@ -653,11 +659,11 @@ handleNameArg =
|
|||||||
(first P.text . Name.parseTextEither . Text.pack)
|
(first P.text . Name.parseTextEither . Text.pack)
|
||||||
\case
|
\case
|
||||||
SA.Name name -> pure name
|
SA.Name name -> pure name
|
||||||
SA.NameWithBranchPrefix (Left _) name -> pure name
|
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name
|
||||||
SA.NameWithBranchPrefix (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
|
||||||
SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname
|
SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname
|
||||||
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname
|
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname
|
||||||
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
|
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
|
||||||
pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname
|
pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname
|
||||||
SA.ShallowListEntry prefix entry ->
|
SA.ShallowListEntry prefix entry ->
|
||||||
pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
|
||||||
@ -681,11 +687,11 @@ handlePullSourceArg =
|
|||||||
otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg
|
otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg
|
||||||
|
|
||||||
handlePushTargetArg ::
|
handlePushTargetArg ::
|
||||||
I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
I.Argument -> Either (P.Pretty CT.ColorText) (These ProjectName ProjectBranchName)
|
||||||
handlePushTargetArg =
|
handlePushTargetArg =
|
||||||
either
|
either
|
||||||
(maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget)
|
(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.Project project -> pure $ This project
|
||||||
SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch
|
SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch
|
||||||
otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
|
otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
|
||||||
@ -695,11 +701,6 @@ handlePushSourceArg =
|
|||||||
either
|
either
|
||||||
(maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource)
|
(maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource)
|
||||||
\case
|
\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.Project project -> pure . Input.ProjySource $ This project
|
||||||
SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch
|
SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch
|
||||||
otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
|
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 :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input
|
||||||
deleteNamespaceParser helpText insistence = \case
|
deleteNamespaceParser helpText insistence = \case
|
||||||
[Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
|
[p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> handleSplitArg p
|
||||||
[p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p
|
|
||||||
_ -> Left helpText
|
_ -> Left helpText
|
||||||
|
|
||||||
renameBranch :: InputPattern
|
renameBranch :: InputPattern
|
||||||
@ -1573,7 +1573,7 @@ history =
|
|||||||
)
|
)
|
||||||
\case
|
\case
|
||||||
[src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src
|
[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)
|
_ -> Left (I.help history)
|
||||||
|
|
||||||
forkLocal :: InputPattern
|
forkLocal :: InputPattern
|
||||||
@ -1649,8 +1649,8 @@ reset =
|
|||||||
]
|
]
|
||||||
)
|
)
|
||||||
\case
|
\case
|
||||||
[arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing
|
[arg0] -> Input.ResetI <$> handleBranchIdArg arg0 <*> pure Nothing
|
||||||
[arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1)
|
[arg0, arg1] -> Input.ResetI <$> handleBranchIdArg arg0 <*> fmap pure (handleMaybeProjectBranchArg arg1)
|
||||||
_ -> Left $ I.help reset
|
_ -> Left $ I.help reset
|
||||||
where
|
where
|
||||||
config =
|
config =
|
||||||
@ -2052,10 +2052,15 @@ mergeOldSquashInputPattern =
|
|||||||
<> "The resulting `dest` will have (at most) 1"
|
<> "The resulting `dest` will have (at most) 1"
|
||||||
<> "additional history entry.",
|
<> "additional history entry.",
|
||||||
parse = \case
|
parse = \case
|
||||||
|
[src] ->
|
||||||
|
Input.MergeLocalBranchI
|
||||||
|
<$> handleBranchRelativePathArg src
|
||||||
|
<*> pure Nothing
|
||||||
|
<*> pure Branch.SquashMerge
|
||||||
[src, dest] ->
|
[src, dest] ->
|
||||||
Input.MergeLocalBranchI
|
Input.MergeLocalBranchI
|
||||||
<$> handleLooseCodeOrProjectArg src
|
<$> handleBranchRelativePathArg src
|
||||||
<*> handleLooseCodeOrProjectArg dest
|
<*> (Just <$> handleBranchRelativePathArg dest)
|
||||||
<*> pure Branch.SquashMerge
|
<*> pure Branch.SquashMerge
|
||||||
_ -> Left $ I.help mergeOldSquashInputPattern
|
_ -> Left $ I.help mergeOldSquashInputPattern
|
||||||
}
|
}
|
||||||
@ -2088,25 +2093,19 @@ mergeOldInputPattern =
|
|||||||
),
|
),
|
||||||
( makeExample mergeOldInputPattern ["/topic", "foo/main"],
|
( makeExample mergeOldInputPattern ["/topic", "foo/main"],
|
||||||
"merges the branch `topic` of the current project into the `main` branch of the project 'foo`"
|
"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
|
( \case
|
||||||
[src] ->
|
[src] ->
|
||||||
Input.MergeLocalBranchI
|
Input.MergeLocalBranchI
|
||||||
<$> handleLooseCodeOrProjectArg src
|
<$> handleBranchRelativePathArg src
|
||||||
<*> pure (This Path.relativeEmpty')
|
<*> pure Nothing
|
||||||
<*> pure Branch.RegularMerge
|
<*> pure Branch.RegularMerge
|
||||||
[src, dest] ->
|
[src, dest] ->
|
||||||
Input.MergeLocalBranchI
|
Input.MergeLocalBranchI
|
||||||
<$> handleLooseCodeOrProjectArg src
|
<$> handleBranchRelativePathArg src
|
||||||
<*> handleLooseCodeOrProjectArg dest
|
<*> (Just <$> handleBranchRelativePathArg dest)
|
||||||
<*> pure Branch.RegularMerge
|
<*> pure Branch.RegularMerge
|
||||||
_ -> Left $ I.help mergeOldInputPattern
|
_ -> Left $ I.help mergeOldInputPattern
|
||||||
)
|
)
|
||||||
@ -2185,17 +2184,6 @@ mergeCommitInputPattern =
|
|||||||
_ -> Left (I.help 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
|
||||||
diffNamespace =
|
diffNamespace =
|
||||||
InputPattern
|
InputPattern
|
||||||
@ -2214,7 +2202,7 @@ diffNamespace =
|
|||||||
)
|
)
|
||||||
( \case
|
( \case
|
||||||
[before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after
|
[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
|
_ -> Left $ I.help diffNamespace
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -2242,9 +2230,9 @@ mergeOldPreviewInputPattern =
|
|||||||
]
|
]
|
||||||
)
|
)
|
||||||
( \case
|
( \case
|
||||||
[src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty')
|
[src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing
|
||||||
[src, dest] ->
|
[src, dest] ->
|
||||||
Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest
|
Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest)
|
||||||
_ -> Left $ I.help mergeOldPreviewInputPattern
|
_ -> Left $ I.help mergeOldPreviewInputPattern
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -3139,13 +3127,12 @@ branchInputPattern =
|
|||||||
help =
|
help =
|
||||||
P.wrapColumn2
|
P.wrapColumn2
|
||||||
[ ("`branch foo`", "forks the current project branch to a new branch `foo`"),
|
[ ("`branch foo`", "forks the current project branch to a new branch `foo`"),
|
||||||
("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"),
|
("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`")
|
||||||
("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`")
|
|
||||||
],
|
],
|
||||||
parse = \case
|
parse = \case
|
||||||
[source0, name] ->
|
[source0, name] ->
|
||||||
Input.BranchI . Input.BranchSourceI'LooseCodeOrProject
|
Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch
|
||||||
<$> handleLooseCodeOrProjectArg source0
|
<$> handleMaybeProjectBranchArg source0
|
||||||
<*> handleMaybeProjectBranchArg name
|
<*> handleMaybeProjectBranchArg name
|
||||||
[name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name
|
[name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name
|
||||||
_ -> Left $ showPatternHelp branchInputPattern
|
_ -> Left $ showPatternHelp branchInputPattern
|
||||||
@ -3513,7 +3500,7 @@ namespaceOrProjectBranchArg config =
|
|||||||
ArgumentType
|
ArgumentType
|
||||||
{ typeName = "namespace or branch",
|
{ typeName = "namespace or branch",
|
||||||
suggestions =
|
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
|
in unionSuggestions
|
||||||
[ projectAndOrBranchSuggestions config,
|
[ projectAndOrBranchSuggestions config,
|
||||||
namespaceSuggestions
|
namespaceSuggestions
|
||||||
@ -3539,8 +3526,8 @@ dependencyArg :: ArgumentType
|
|||||||
dependencyArg =
|
dependencyArg =
|
||||||
ArgumentType
|
ArgumentType
|
||||||
{ typeName = "project dependency",
|
{ typeName = "project dependency",
|
||||||
suggestions = \q cb _http p -> Codebase.runTransaction cb do
|
suggestions = \q cb _http pp -> Codebase.runTransaction cb do
|
||||||
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
|
prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
|
||||||
fzfResolver = Just Resolvers.projectDependencyResolver
|
fzfResolver = Just Resolvers.projectDependencyResolver
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -3599,14 +3586,14 @@ projectAndOrBranchSuggestions ::
|
|||||||
String ->
|
String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute -> -- Current path
|
ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
|
projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do
|
||||||
case Text.uncons input of
|
case Text.uncons input of
|
||||||
-- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
|
-- 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,
|
-- 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.
|
-- 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
|
case tryInto @ProjectAndBranchNames input of
|
||||||
-- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
|
-- 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 []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config path) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
||||||
pure (map (projectBranchToCompletion projectName) branches)
|
pure (map (projectBranchToCompletion projectName) branches)
|
||||||
-- This branch is probably dead due to intercepting inputs that begin with "/" above
|
-- This branch is probably dead due to intercepting inputs that begin with "/" above
|
||||||
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
|
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
|
||||||
handleBranchesComplete (into @Text branchName) codebase path
|
handleBranchesComplete (into @Text branchName) codebase pp
|
||||||
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
|
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
@ -3640,16 +3627,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
|
|||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config path) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
|
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
|
||||||
pure (map (projectBranchToCompletion projectName) branches)
|
pure (map (projectBranchToCompletion projectName) branches)
|
||||||
where
|
where
|
||||||
input = Text.strip . Text.pack $ inputStr
|
input = Text.strip . Text.pack $ inputStr
|
||||||
|
|
||||||
(mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of
|
|
||||||
LooseCodePath {} -> (Nothing, Nothing)
|
|
||||||
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
|
|
||||||
|
|
||||||
handleAmbiguousComplete ::
|
handleAmbiguousComplete ::
|
||||||
(MonadIO m) =>
|
(MonadIO m) =>
|
||||||
Text ->
|
Text ->
|
||||||
@ -3659,14 +3642,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
|
|||||||
(branches, projects) <-
|
(branches, projects) <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
branches <-
|
branches <-
|
||||||
case mayCurrentProjectId of
|
fmap (filterBranches config pp) do
|
||||||
Nothing -> pure []
|
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||||
Just currentProjectId ->
|
projects <- case projectInclusion config of
|
||||||
fmap (filterBranches config path) do
|
OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
|
||||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
|
||||||
projects <- case (projectInclusion config, mayCurrentProjectId) of
|
|
||||||
(OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
|
|
||||||
(OnlyWithinCurrentProject, Nothing) -> pure []
|
|
||||||
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
||||||
pure (branches, projects)
|
pure (branches, projects)
|
||||||
let branchCompletions = map currentProjectBranchToCompletion branches
|
let branchCompletions = map currentProjectBranchToCompletion branches
|
||||||
@ -3740,28 +3719,28 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
|
|||||||
then projectCompletions
|
then projectCompletions
|
||||||
else branchCompletions ++ projectCompletions
|
else branchCompletions ++ projectCompletions
|
||||||
|
|
||||||
handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion]
|
-- Complete the text into a branch name within the provided project
|
||||||
handleBranchesComplete branchName codebase path = do
|
handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
|
||||||
|
handleBranchesComplete branchName codebase pp = do
|
||||||
|
let projId = pp ^. #project . #projectId
|
||||||
branches <-
|
branches <-
|
||||||
case preview ProjectUtils.projectBranchPathPrism path of
|
Codebase.runTransaction codebase do
|
||||||
Nothing -> pure []
|
fmap (filterBranches config pp) do
|
||||||
Just (ProjectAndBranch currentProjectId _, _) ->
|
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
|
||||||
Codebase.runTransaction codebase do
|
|
||||||
fmap (filterBranches config path) do
|
|
||||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
|
|
||||||
pure (map currentProjectBranchToCompletion branches)
|
pure (map currentProjectBranchToCompletion branches)
|
||||||
|
|
||||||
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
||||||
filterProjects projects =
|
filterProjects projects =
|
||||||
case (mayCurrentProjectId, projectInclusion config) of
|
case (projectInclusion config) of
|
||||||
(_, AllProjects) -> projects
|
AllProjects -> projects
|
||||||
(Nothing, _) -> projects
|
OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
|
||||||
(Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
|
OnlyWithinCurrentProject ->
|
||||||
(Just currentBranchId, OnlyWithinCurrentProject) ->
|
|
||||||
projects
|
projects
|
||||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
|
& List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
|
||||||
& maybeToList
|
& maybeToList
|
||||||
|
|
||||||
|
PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp
|
||||||
|
|
||||||
projectToCompletion :: Sqlite.Project -> Completion
|
projectToCompletion :: Sqlite.Project -> Completion
|
||||||
projectToCompletion project =
|
projectToCompletion project =
|
||||||
Completion
|
Completion
|
||||||
@ -3785,28 +3764,22 @@ handleBranchesComplete ::
|
|||||||
ProjectBranchSuggestionsConfig ->
|
ProjectBranchSuggestionsConfig ->
|
||||||
Text ->
|
Text ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [Completion]
|
m [Completion]
|
||||||
handleBranchesComplete config branchName codebase path = do
|
handleBranchesComplete config branchName codebase pp = do
|
||||||
branches <-
|
branches <-
|
||||||
case preview ProjectUtils.projectBranchPathPrism path of
|
Codebase.runTransaction codebase do
|
||||||
Nothing -> pure []
|
fmap (filterBranches config pp) do
|
||||||
Just (ProjectAndBranch currentProjectId _, _) ->
|
Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName)
|
||||||
Codebase.runTransaction codebase do
|
|
||||||
fmap (filterBranches config path) do
|
|
||||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
|
|
||||||
pure (map currentProjectBranchToCompletion branches)
|
pure (map currentProjectBranchToCompletion branches)
|
||||||
|
|
||||||
filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
||||||
filterBranches config path branches =
|
filterBranches config pp branches =
|
||||||
case (mayCurrentBranchId, branchInclusion config) of
|
case (branchInclusion config) of
|
||||||
(_, AllBranches) -> branches
|
AllBranches -> branches
|
||||||
(Nothing, _) -> branches
|
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
||||||
(Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
|
||||||
where
|
where
|
||||||
(_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of
|
currentBranchId = pp ^. #branch . #branchId
|
||||||
LooseCodePath {} -> (Nothing, Nothing)
|
|
||||||
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
|
|
||||||
|
|
||||||
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
||||||
currentProjectBranchToCompletion (_, branchName) =
|
currentProjectBranchToCompletion (_, branchName) =
|
||||||
@ -3822,22 +3795,22 @@ branchRelativePathSuggestions ::
|
|||||||
String ->
|
String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute -> -- Current path
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do
|
branchRelativePathSuggestions config inputStr codebase _httpClient pp = do
|
||||||
case parseIncrementalBranchRelativePath inputStr of
|
case parseIncrementalBranchRelativePath inputStr of
|
||||||
Left _ -> pure []
|
Left _ -> pure []
|
||||||
Right ibrp -> case ibrp of
|
Right ibrp -> case ibrp of
|
||||||
BranchRelativePath.ProjectOrRelative _txt _path -> do
|
BranchRelativePath.ProjectOrPath' _txt _path -> do
|
||||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||||
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
||||||
pure (namespaceSuggestions ++ projectSuggestions)
|
pure (namespaceSuggestions ++ projectSuggestions)
|
||||||
BranchRelativePath.LooseCode _path ->
|
BranchRelativePath.OnlyPath' _path ->
|
||||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||||
BranchRelativePath.IncompleteProject _proj ->
|
BranchRelativePath.IncompleteProject _proj ->
|
||||||
projectNameSuggestions WithSlash inputStr codebase
|
projectNameSuggestions WithSlash inputStr codebase
|
||||||
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
|
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
|
Just projectName -> do
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
@ -3845,44 +3818,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath =
|
|||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config currentPath) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
|
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
|
||||||
pure (map (projectBranchToCompletionWithSep projectName) branches)
|
pure (map (projectBranchToCompletionWithSep projectName) branches)
|
||||||
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
|
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
|
||||||
mprojectBranch <- runMaybeT do
|
-- TODO: Verify this works as intended, might need to use an absolute path instead.
|
||||||
(projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId)
|
map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) pp
|
||||||
MaybeT (Queries.loadProjectBranch projectId branchId)
|
|
||||||
case mprojectBranch of
|
|
||||||
Nothing -> pure []
|
|
||||||
Just projectBranch -> do
|
|
||||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
|
||||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
|
||||||
map prefixPathSep
|
|
||||||
<$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath
|
|
||||||
BranchRelativePath.IncompletePath projStuff mpath -> do
|
BranchRelativePath.IncompletePath projStuff mpath -> do
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
mprojectBranch <- runMaybeT do
|
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp
|
||||||
case projStuff of
|
|
||||||
Left names@(ProjectAndBranch projectName branchName) -> do
|
|
||||||
(,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName)
|
|
||||||
Right branchName -> do
|
|
||||||
currentProjectId <- MaybeT (pure mayCurrentProjectId)
|
|
||||||
projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName)
|
|
||||||
pure (projectBranch, Right (projectBranch ^. #name))
|
|
||||||
case mprojectBranch of
|
|
||||||
Nothing -> pure []
|
|
||||||
Just (projectBranch, prefix) -> do
|
|
||||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
|
||||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
|
||||||
map (addBranchPrefix prefix)
|
|
||||||
<$> prefixCompleteNamespace
|
|
||||||
(maybe "" (Text.unpack . Path.toText' . Path.RelativePath') mpath)
|
|
||||||
branchPath
|
|
||||||
where
|
where
|
||||||
(mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of
|
|
||||||
LooseCodePath {} -> (Nothing, Nothing)
|
|
||||||
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
|
|
||||||
|
|
||||||
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
||||||
projectBranchToCompletionWithSep projectName (_, branchName) =
|
projectBranchToCompletionWithSep projectName (_, branchName) =
|
||||||
Completion
|
Completion
|
||||||
@ -4007,12 +3952,11 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do
|
|||||||
parsePushSource :: String -> Maybe Input.PushSource
|
parsePushSource :: String -> Maybe Input.PushSource
|
||||||
parsePushSource sourceStr =
|
parsePushSource sourceStr =
|
||||||
fixup Input.ProjySource (tryFrom $ Text.pack sourceStr)
|
fixup Input.ProjySource (tryFrom $ Text.pack sourceStr)
|
||||||
<|> fixup Input.PathySource (Path.parsePath' sourceStr)
|
|
||||||
where
|
where
|
||||||
fixup = either (const Nothing) . (pure .)
|
fixup = either (const Nothing) . (pure .)
|
||||||
|
|
||||||
-- | Parse a push target.
|
-- | Parse a push target.
|
||||||
parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
parsePushTarget :: String -> Maybe (These ProjectName ProjectBranchName)
|
||||||
parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack
|
parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack
|
||||||
|
|
||||||
parseHashQualifiedName ::
|
parseHashQualifiedName ::
|
||||||
|
@ -6,10 +6,12 @@ where
|
|||||||
import Compat (withInterruptHandler)
|
import Compat (withInterruptHandler)
|
||||||
import Control.Concurrent.Async qualified as Async
|
import Control.Concurrent.Async qualified as Async
|
||||||
import Control.Exception (catch, displayException, finally, mask)
|
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 Crypto.Random qualified as Random
|
||||||
import Data.Configurator.Types (Config)
|
import Data.Configurator.Types (Config)
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
import Data.List.NonEmpty qualified as NEL
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Text.IO qualified as Text
|
import Data.Text.IO qualified as Text
|
||||||
import Ki qualified
|
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 (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin)
|
||||||
import System.IO.Error (isDoesNotExistError)
|
import System.IO.Error (isDoesNotExistError)
|
||||||
import U.Codebase.HashTags (CausalHash)
|
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.CredentialManager (newCredentialManager)
|
||||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||||
import Unison.Auth.HTTPClient qualified as AuthN
|
import Unison.Auth.HTTPClient qualified as AuthN
|
||||||
import Unison.Auth.Tokens qualified as AuthN
|
import Unison.Auth.Tokens qualified as AuthN
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
import Unison.Cli.Pretty (prettyProjectAndBranchName)
|
import Unison.Cli.Pretty qualified as P
|
||||||
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
|
import Unison.Codebase.Branch (Branch)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
|
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
|
||||||
import Unison.Codebase.Editor.Input (Event, Input (..))
|
import Unison.Codebase.Editor.Input (Event, Input (..))
|
||||||
import Unison.Codebase.Editor.Output (NumberedArgs, Output)
|
import Unison.Codebase.Editor.Output (NumberedArgs, Output)
|
||||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
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.Codebase.Runtime qualified as Runtime
|
||||||
import Unison.CommandLine
|
import Unison.CommandLine
|
||||||
import Unison.CommandLine.Completion (haskelineTabComplete)
|
import Unison.CommandLine.Completion (haskelineTabComplete)
|
||||||
@ -46,7 +47,6 @@ import Unison.CommandLine.Welcome qualified as Welcome
|
|||||||
import Unison.Parser.Ann (Ann)
|
import Unison.Parser.Ann (Ann)
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.PrettyTerminal
|
import Unison.PrettyTerminal
|
||||||
import Unison.Project (ProjectAndBranch (..))
|
|
||||||
import Unison.Runtime.IOSource qualified as IOSource
|
import Unison.Runtime.IOSource qualified as IOSource
|
||||||
import Unison.Server.CodebaseServer qualified as Server
|
import Unison.Server.CodebaseServer qualified as Server
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
@ -60,10 +60,11 @@ import UnliftIO.STM
|
|||||||
getUserInput ::
|
getUserInput ::
|
||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
|
IO (Branch IO) ->
|
||||||
NumberedArgs ->
|
NumberedArgs ->
|
||||||
IO Input
|
IO Input
|
||||||
getUserInput codebase authHTTPClient currentPath numberedArgs =
|
getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs =
|
||||||
Line.runInputT
|
Line.runInputT
|
||||||
settings
|
settings
|
||||||
(haskelineCtrlCHandling go)
|
(haskelineCtrlCHandling go)
|
||||||
@ -78,23 +79,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
|
|||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
go :: Line.InputT IO Input
|
go :: Line.InputT IO Input
|
||||||
go = do
|
go = do
|
||||||
promptString <-
|
let promptString = P.prettyProjectPath pp
|
||||||
case preview projectBranchPathPrism currentPath of
|
|
||||||
Nothing -> pure ((P.green . P.shown) currentPath)
|
|
||||||
Just (ProjectAndBranch projectId branchId, restPath) -> do
|
|
||||||
lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case
|
|
||||||
-- If the project branch has been deleted from sqlite, just show a borked prompt
|
|
||||||
Nothing -> P.red "???"
|
|
||||||
Just (projectName, branchName) ->
|
|
||||||
P.sep
|
|
||||||
" "
|
|
||||||
( catMaybes
|
|
||||||
[ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)),
|
|
||||||
case restPath of
|
|
||||||
Path.Empty -> Nothing
|
|
||||||
_ -> (Just . P.green . P.shown) restPath
|
|
||||||
]
|
|
||||||
)
|
|
||||||
let fullPrompt = P.toANSI 80 (promptString <> fromString prompt)
|
let fullPrompt = P.toANSI 80 (promptString <> fromString prompt)
|
||||||
line <- Line.getInputLine fullPrompt
|
line <- Line.getInputLine fullPrompt
|
||||||
case line of
|
case line of
|
||||||
@ -102,7 +87,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
|
|||||||
Just l -> case words l of
|
Just l -> case words l of
|
||||||
[] -> go
|
[] -> go
|
||||||
ws -> do
|
ws -> do
|
||||||
liftIO (parseInput codebase currentPath numberedArgs IP.patternMap ws) >>= \case
|
liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case
|
||||||
Left msg -> do
|
Left msg -> do
|
||||||
-- We still add history that failed to parse so the user can easily reload
|
-- We still add history that failed to parse so the user can easily reload
|
||||||
-- the input and fix it.
|
-- the input and fix it.
|
||||||
@ -126,12 +111,20 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
|
|||||||
historyFile = Just ".unisonHistory",
|
historyFile = Just ".unisonHistory",
|
||||||
autoAddHistory = False
|
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 ::
|
main ::
|
||||||
FilePath ->
|
FilePath ->
|
||||||
Welcome.Welcome ->
|
Welcome.Welcome ->
|
||||||
Path.Absolute ->
|
PP.ProjectPathIds ->
|
||||||
Config ->
|
Config ->
|
||||||
[Either Event Input] ->
|
[Either Event Input] ->
|
||||||
Runtime.Runtime Symbol ->
|
Runtime.Runtime Symbol ->
|
||||||
@ -141,25 +134,24 @@ main ::
|
|||||||
Maybe Server.BaseUrl ->
|
Maybe Server.BaseUrl ->
|
||||||
UCMVersion ->
|
UCMVersion ->
|
||||||
(CausalHash -> STM ()) ->
|
(CausalHash -> STM ()) ->
|
||||||
(Path.Absolute -> STM ()) ->
|
(PP.ProjectPath -> STM ()) ->
|
||||||
ShouldWatchFiles ->
|
ShouldWatchFiles ->
|
||||||
IO ()
|
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
|
rootVar <- newEmptyTMVarIO
|
||||||
initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash
|
|
||||||
_ <- Ki.fork scope do
|
_ <- Ki.fork scope do
|
||||||
root <- Codebase.getRootBranch codebase
|
projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch
|
||||||
atomically do
|
atomically do
|
||||||
-- Try putting the root, but if someone else as already written over the root, don't
|
-- Try putting the root, but if someone else as already written over the root, don't
|
||||||
-- overwrite it.
|
-- overwrite it.
|
||||||
void $ tryPutTMVar rootVar root
|
void $ tryPutTMVar rootVar projectRoot
|
||||||
-- Start forcing thunks in a background thread.
|
-- Start forcing thunks in a background thread.
|
||||||
-- This might be overly aggressive, maybe we should just evaluate the top level but avoid
|
-- This might be overly aggressive, maybe we should just evaluate the top level but avoid
|
||||||
-- recursive "deep*" things.
|
-- recursive "deep*" things.
|
||||||
UnliftIO.concurrently_
|
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
|
(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
|
Ki.fork_ scope do
|
||||||
let loop lastRoot = do
|
let loop lastRoot = do
|
||||||
-- This doesn't necessarily notify on _every_ update, but the LSP only needs the
|
-- 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
|
getInput loopState = do
|
||||||
currentEcho <- hGetEcho stdin
|
currentEcho <- hGetEcho stdin
|
||||||
liftIO $ restoreEcho currentEcho
|
liftIO $ restoreEcho currentEcho
|
||||||
|
let getProjectRoot = atomically $ readTMVar rootVar
|
||||||
|
pp <- loopStateProjectPath codebase loopState
|
||||||
getUserInput
|
getUserInput
|
||||||
codebase
|
codebase
|
||||||
authHTTPClient
|
authHTTPClient
|
||||||
(loopState ^. #currentPath)
|
pp
|
||||||
|
getProjectRoot
|
||||||
(loopState ^. #numberedArgs)
|
(loopState ^. #numberedArgs)
|
||||||
let loadSourceFile :: Text -> IO Cli.LoadSourceResult
|
let loadSourceFile :: Text -> IO Cli.LoadSourceResult
|
||||||
loadSourceFile fname =
|
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))
|
Text.hPutStrLn stderr ("Encountered exception:\n" <> Text.pack (displayException e))
|
||||||
loop0 s0
|
loop0 s0
|
||||||
Right (Right (result, s1)) -> do
|
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
|
case result of
|
||||||
Cli.Success () -> loop0 s1
|
Cli.Success () -> loop0 s1
|
||||||
Cli.Continue -> 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.Builtin.Decls qualified as DD
|
||||||
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
|
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
|
||||||
import Unison.Cli.Pretty
|
import Unison.Cli.Pretty
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
|
||||||
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
||||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
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 qualified as E
|
||||||
import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD
|
import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD
|
||||||
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
|
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.SlurpResult qualified as SlurpResult
|
||||||
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
||||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
|
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
|
||||||
import Unison.Codebase.Patch qualified as Patch
|
import Unison.Codebase.Patch qualified as Patch
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Codebase.PushBehavior qualified as PushBehavior
|
|
||||||
import Unison.Codebase.Runtime qualified as Runtime
|
import Unison.Codebase.Runtime qualified as Runtime
|
||||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||||
@ -90,7 +86,6 @@ import Unison.LabeledDependency as LD
|
|||||||
import Unison.Name (Name)
|
import Unison.Name (Name)
|
||||||
import Unison.Name qualified as Name
|
import Unison.Name qualified as Name
|
||||||
import Unison.NameSegment qualified as NameSegment
|
import Unison.NameSegment qualified as NameSegment
|
||||||
import Unison.NameSegment.Internal (NameSegment (NameSegment))
|
|
||||||
import Unison.Names (Names (..))
|
import Unison.Names (Names (..))
|
||||||
import Unison.Names qualified as Names
|
import Unison.Names qualified as Names
|
||||||
import Unison.NamesWithHistory 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.Var qualified as Var
|
||||||
import Unison.WatchKind qualified as WK
|
import Unison.WatchKind qualified as WK
|
||||||
import Witch (unsafeFrom)
|
import Witch (unsafeFrom)
|
||||||
|
import Unison.Codebase.Editor.Input (BranchIdG(..))
|
||||||
|
|
||||||
reportBugURL :: Pretty
|
reportBugURL :: Pretty
|
||||||
reportBugURL = "https://github.com/unisonweb/unison/issues/new"
|
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 :: NumberedOutput -> (Pretty, NumberedArgs)
|
||||||
notifyNumbered = \case
|
notifyNumbered = \case
|
||||||
ShowDiffNamespace oldPrefix newPrefix ppe diffOutput ->
|
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 ->
|
ShowDiffAfterDeleteDefinitions ppe diff ->
|
||||||
first
|
first
|
||||||
( \p ->
|
( \p ->
|
||||||
@ -231,7 +227,7 @@ notifyNumbered = \case
|
|||||||
<> " to undo the results of this merge."
|
<> " 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 ->
|
ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput ->
|
||||||
first
|
first
|
||||||
( \p ->
|
( \p ->
|
||||||
@ -258,7 +254,7 @@ notifyNumbered = \case
|
|||||||
<> " to undo the results of this merge."
|
<> " 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 ->
|
ShowDiffAfterMergePreview dest' destAbs ppe diffOutput ->
|
||||||
first
|
first
|
||||||
( \p ->
|
( \p ->
|
||||||
@ -268,7 +264,7 @@ notifyNumbered = \case
|
|||||||
p
|
p
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
(showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
|
(showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
|
||||||
ShowDiffAfterUndo ppe diffOutput ->
|
ShowDiffAfterUndo ppe diffOutput ->
|
||||||
first
|
first
|
||||||
(\p -> P.lines ["Here are the changes I undid", "", p])
|
(\p -> P.lines ["Here are the changes I undid", "", p])
|
||||||
@ -473,7 +469,7 @@ notifyNumbered = \case
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
switch = IP.makeExample IP.projectSwitch
|
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
|
( P.wrap
|
||||||
( openingLine
|
( openingLine
|
||||||
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
|
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
|
||||||
@ -513,10 +509,10 @@ notifyNumbered = \case
|
|||||||
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
||||||
reset = IP.makeExample IP.reset
|
reset = IP.makeExample IP.reset
|
||||||
relPath0 = prettyPath path
|
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 Empty -> ("This namespace has no external dependencies.", mempty)
|
||||||
ListNamespaceDependencies ppe path' externalDependencies ->
|
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),
|
List.intersperse spacer (externalDepsTable externalDependencies),
|
||||||
numberedArgs
|
numberedArgs
|
||||||
)
|
)
|
||||||
@ -558,7 +554,7 @@ notifyNumbered = \case
|
|||||||
& fmap (\name -> formatNum (getNameNumber name) <> prettyName name)
|
& fmap (\name -> formatNum (getNameNumber name) <> prettyName name)
|
||||||
& P.lines
|
& P.lines
|
||||||
where
|
where
|
||||||
absPathToBranchId = Right
|
absPathToBranchId = BranchAtPath
|
||||||
|
|
||||||
undoTip :: P.Pretty P.ColorText
|
undoTip :: P.Pretty P.ColorText
|
||||||
undoTip =
|
undoTip =
|
||||||
@ -602,13 +598,13 @@ notifyUser dir = \case
|
|||||||
pure
|
pure
|
||||||
. P.warnCallout
|
. P.warnCallout
|
||||||
$ "The namespace "
|
$ "The namespace "
|
||||||
<> prettyBranchId p0
|
<> either prettySCH prettyProjectPath p0
|
||||||
<> " is empty. Was there a typo?"
|
<> " is empty. Was there a typo?"
|
||||||
ps ->
|
ps ->
|
||||||
pure
|
pure
|
||||||
. P.warnCallout
|
. P.warnCallout
|
||||||
$ "The namespaces "
|
$ "The namespaces "
|
||||||
<> P.commas (prettyBranchId <$> ps)
|
<> P.commas (either prettySCH prettyProjectPath <$> ps)
|
||||||
<> " are empty. Was there a typo?"
|
<> " are empty. Was there a typo?"
|
||||||
LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
|
LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
|
||||||
pure $
|
pure $
|
||||||
@ -801,7 +797,7 @@ notifyUser dir = \case
|
|||||||
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
|
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
|
||||||
CreatedNewBranch path ->
|
CreatedNewBranch path ->
|
||||||
pure $
|
pure $
|
||||||
"☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty."
|
"☝️ The namespace " <> prettyAbsolute path <> " is empty."
|
||||||
-- RenameOutput rootPath oldName newName r -> do
|
-- RenameOutput rootPath oldName newName r -> do
|
||||||
-- nameChange "rename" "renamed" oldName newName r
|
-- nameChange "rename" "renamed" oldName newName r
|
||||||
-- AliasOutput rootPath existingName newName r -> do
|
-- AliasOutput rootPath existingName newName r -> do
|
||||||
@ -1329,9 +1325,9 @@ notifyUser dir = \case
|
|||||||
MergeAlreadyUpToDate src dest ->
|
MergeAlreadyUpToDate src dest ->
|
||||||
pure . P.callout "😶" $
|
pure . P.callout "😶" $
|
||||||
P.wrap $
|
P.wrap $
|
||||||
either prettyPath' prettyProjectAndBranchName dest
|
prettyBranchRelativePath dest
|
||||||
<> "was already up-to-date with"
|
<> "was already up-to-date with"
|
||||||
<> P.group (either prettyPath' prettyProjectAndBranchName src <> ".")
|
<> P.group (prettyBranchRelativePath src <> ".")
|
||||||
MergeAlreadyUpToDate2 aliceAndBob ->
|
MergeAlreadyUpToDate2 aliceAndBob ->
|
||||||
pure . P.callout "😶" $
|
pure . P.callout "😶" $
|
||||||
P.wrap $
|
P.wrap $
|
||||||
@ -1476,9 +1472,9 @@ notifyUser dir = \case
|
|||||||
PreviewMergeAlreadyUpToDate src dest ->
|
PreviewMergeAlreadyUpToDate src dest ->
|
||||||
pure . P.callout "😶" $
|
pure . P.callout "😶" $
|
||||||
P.wrap $
|
P.wrap $
|
||||||
prettyNamespaceKey dest
|
prettyProjectPath dest
|
||||||
<> "is already up-to-date with"
|
<> "is already up-to-date with"
|
||||||
<> P.group (prettyNamespaceKey src <> ".")
|
<> P.group (prettyProjectPath src)
|
||||||
DumpNumberedArgs schLength args ->
|
DumpNumberedArgs schLength args ->
|
||||||
pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
|
pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
|
||||||
HelpMessage pat -> pure $ IP.showPatternHelp pat
|
HelpMessage pat -> pure $ IP.showPatternHelp pat
|
||||||
@ -1533,11 +1529,6 @@ notifyUser dir = \case
|
|||||||
<> ( terms <&> \(n, r) ->
|
<> ( terms <&> \(n, r) ->
|
||||||
prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId 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 ->
|
GistCreated remoteNamespace ->
|
||||||
pure $
|
pure $
|
||||||
P.lines
|
P.lines
|
||||||
@ -1599,10 +1590,7 @@ notifyUser dir = \case
|
|||||||
PrintVersion ucmVersion -> pure (P.text ucmVersion)
|
PrintVersion ucmVersion -> pure (P.text ucmVersion)
|
||||||
ShareError shareError -> pure (prettyShareError shareError)
|
ShareError shareError -> pure (prettyShareError shareError)
|
||||||
ViewOnShare shareRef ->
|
ViewOnShare shareRef ->
|
||||||
pure $
|
pure $ "View it here: " <> prettyRemoteBranchInfo shareRef
|
||||||
"View it here: " <> case shareRef of
|
|
||||||
Left repoPath -> prettyShareLink repoPath
|
|
||||||
Right branchInfo -> prettyRemoteBranchInfo branchInfo
|
|
||||||
IntegrityCheck result -> pure $ case result of
|
IntegrityCheck result -> pure $ case result of
|
||||||
NoIntegrityErrors -> "🎉 No issues detected 🎉"
|
NoIntegrityErrors -> "🎉 No issues detected 🎉"
|
||||||
IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
|
IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
|
||||||
@ -2068,16 +2056,6 @@ notifyUser dir = \case
|
|||||||
<> P.group (P.text (NameSegment.toEscapedText new) <> ",")
|
<> P.group (P.text (NameSegment.toEscapedText new) <> ",")
|
||||||
<> "and removed"
|
<> "and removed"
|
||||||
<> P.group (P.text (NameSegment.toEscapedText old) <> ".")
|
<> 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 ->
|
MergeFailure path aliceAndBob temp ->
|
||||||
pure $
|
pure $
|
||||||
P.lines $
|
P.lines $
|
||||||
@ -2150,39 +2128,16 @@ notifyUser dir = \case
|
|||||||
NoMergeInProgress ->
|
NoMergeInProgress ->
|
||||||
pure . P.wrap $ "It doesn't look like there's a merge in progress."
|
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 :: ShareError -> Pretty
|
||||||
prettyShareError =
|
prettyShareError =
|
||||||
P.fatalCallout . \case
|
P.fatalCallout . \case
|
||||||
ShareErrorCheckAndSetPush err -> prettyCheckAndSetPushError err
|
|
||||||
ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err
|
ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err
|
||||||
ShareErrorFastForwardPush err -> prettyFastForwardPushError err
|
|
||||||
ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err
|
ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err
|
||||||
ShareErrorPull err -> prettyPullError err
|
ShareErrorPull err -> prettyPullError err
|
||||||
ShareErrorTransport err -> prettyTransportError err
|
ShareErrorTransport err -> prettyTransportError err
|
||||||
ShareErrorUploadEntities err -> prettyUploadEntitiesError 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."
|
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 :: Share.DownloadEntitiesError -> Pretty
|
||||||
prettyDownloadEntitiesError = \case
|
prettyDownloadEntitiesError = \case
|
||||||
Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo
|
Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo
|
||||||
@ -2191,27 +2146,6 @@ prettyDownloadEntitiesError = \case
|
|||||||
Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project
|
Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project
|
||||||
Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationFailure err
|
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 :: Share.GetCausalHashByPathError -> Pretty
|
||||||
prettyGetCausalHashByPathError = \case
|
prettyGetCausalHashByPathError = \case
|
||||||
Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath
|
Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath
|
||||||
@ -2225,21 +2159,6 @@ prettyPullError = \case
|
|||||||
Share.PullError'NoHistoryAtPath sharePath ->
|
Share.PullError'NoHistoryAtPath sharePath ->
|
||||||
P.wrap $ P.text "The server didn't find anything at" <> prettySharePath 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 :: Share.UploadEntitiesError -> Pretty
|
||||||
prettyUploadEntitiesError = \case
|
prettyUploadEntitiesError = \case
|
||||||
Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr
|
Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr
|
||||||
@ -2437,17 +2356,6 @@ shareUserNotFound :: Share.RepoInfo -> Pretty
|
|||||||
shareUserNotFound repoInfo =
|
shareUserNotFound repoInfo =
|
||||||
P.wrap ("User" <> prettyRepoInfo repoInfo <> "does not exist.")
|
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 ::
|
formatMissingStuff ::
|
||||||
(Show tm, Show typ) =>
|
(Show tm, Show typ) =>
|
||||||
[(HQ.HashQualified Name, tm)] ->
|
[(HQ.HashQualified Name, tm)] ->
|
||||||
|
@ -29,7 +29,7 @@ import System.Environment (lookupEnv)
|
|||||||
import System.IO (hPutStrLn)
|
import System.IO (hPutStrLn)
|
||||||
import U.Codebase.HashTags
|
import U.Codebase.HashTags
|
||||||
import Unison.Codebase
|
import Unison.Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.Runtime (Runtime)
|
import Unison.Codebase.Runtime (Runtime)
|
||||||
import Unison.Debug qualified as Debug
|
import Unison.Debug qualified as Debug
|
||||||
import Unison.LSP.CancelRequest (cancelRequestHandler)
|
import Unison.LSP.CancelRequest (cancelRequestHandler)
|
||||||
@ -61,8 +61,14 @@ getLspPort :: IO String
|
|||||||
getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT"
|
getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT"
|
||||||
|
|
||||||
-- | Spawn an LSP server on the configured port.
|
-- | Spawn an LSP server on the configured port.
|
||||||
spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM CausalHash -> STM (Path.Absolute) -> IO ()
|
spawnLsp ::
|
||||||
spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
|
LspFormattingConfig ->
|
||||||
|
Codebase IO Symbol Ann ->
|
||||||
|
Runtime Symbol ->
|
||||||
|
STM CausalHash ->
|
||||||
|
STM PP.ProjectPath ->
|
||||||
|
IO ()
|
||||||
|
spawnLsp lspFormattingConfig codebase runtime latestProjectRootHash latestPath =
|
||||||
ifEnabled . TCP.withSocketsDo $ do
|
ifEnabled . TCP.withSocketsDo $ do
|
||||||
lspPort <- getLspPort
|
lspPort <- getLspPort
|
||||||
UnliftIO.handleIO (handleFailure lspPort) $ do
|
UnliftIO.handleIO (handleFailure lspPort) $ do
|
||||||
@ -82,7 +88,7 @@ spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
|
|||||||
-- different un-saved state for the same file.
|
-- different un-saved state for the same file.
|
||||||
initVFS $ \vfs -> do
|
initVFS $ \vfs -> do
|
||||||
vfsVar <- newMVar vfs
|
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
|
where
|
||||||
handleFailure :: String -> IOException -> IO ()
|
handleFailure :: String -> IOException -> IO ()
|
||||||
handleFailure lspPort ioerr =
|
handleFailure lspPort ioerr =
|
||||||
@ -114,15 +120,15 @@ serverDefinition ::
|
|||||||
Runtime Symbol ->
|
Runtime Symbol ->
|
||||||
Ki.Scope ->
|
Ki.Scope ->
|
||||||
STM CausalHash ->
|
STM CausalHash ->
|
||||||
STM (Path.Absolute) ->
|
STM PP.ProjectPath ->
|
||||||
ServerDefinition Config
|
ServerDefinition Config
|
||||||
serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath =
|
serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestProjectRootHash latestPath =
|
||||||
ServerDefinition
|
ServerDefinition
|
||||||
{ defaultConfig = defaultLSPConfig,
|
{ defaultConfig = defaultLSPConfig,
|
||||||
configSection = "unison",
|
configSection = "unison",
|
||||||
parseConfig = Config.parseConfig,
|
parseConfig = Config.parseConfig,
|
||||||
onConfigChange = Config.updateConfig,
|
onConfigChange = Config.updateConfig,
|
||||||
doInitialize = lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath,
|
doInitialize = lspDoInitialize vfsVar codebase runtime scope latestProjectRootHash latestPath,
|
||||||
staticHandlers = lspStaticHandlers lspFormattingConfig,
|
staticHandlers = lspStaticHandlers lspFormattingConfig,
|
||||||
interpretHandler = lspInterpretHandler,
|
interpretHandler = lspInterpretHandler,
|
||||||
options = lspOptions
|
options = lspOptions
|
||||||
@ -135,7 +141,7 @@ lspDoInitialize ::
|
|||||||
Runtime Symbol ->
|
Runtime Symbol ->
|
||||||
Ki.Scope ->
|
Ki.Scope ->
|
||||||
STM CausalHash ->
|
STM CausalHash ->
|
||||||
STM (Path.Absolute) ->
|
STM PP.ProjectPath ->
|
||||||
LanguageContextEnv Config ->
|
LanguageContextEnv Config ->
|
||||||
Msg.TMessage 'Msg.Method_Initialize ->
|
Msg.TMessage 'Msg.Method_Initialize ->
|
||||||
IO (Either Msg.ResponseError Env)
|
IO (Either Msg.ResponseError Env)
|
||||||
@ -152,7 +158,7 @@ lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspConte
|
|||||||
Env
|
Env
|
||||||
{ ppedCache = atomically $ readTMVar ppedCacheVar,
|
{ ppedCache = atomically $ readTMVar ppedCacheVar,
|
||||||
currentNamesCache = atomically $ readTMVar currentNamesCacheVar,
|
currentNamesCache = atomically $ readTMVar currentNamesCacheVar,
|
||||||
currentPathCache = atomically $ readTMVar currentPathCacheVar,
|
currentProjectPathCache = atomically $ readTMVar currentPathCacheVar,
|
||||||
nameSearchCache = atomically $ readTMVar nameSearchCacheVar,
|
nameSearchCache = atomically $ readTMVar nameSearchCacheVar,
|
||||||
..
|
..
|
||||||
}
|
}
|
||||||
|
@ -77,7 +77,7 @@ import Witherable
|
|||||||
-- | Lex, parse, and typecheck a file.
|
-- | Lex, parse, and typecheck a file.
|
||||||
checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis)
|
checkFile :: (HasUri d Uri) => d -> Lsp (Maybe FileAnalysis)
|
||||||
checkFile doc = runMaybeT do
|
checkFile doc = runMaybeT do
|
||||||
currentPath <- lift getCurrentPath
|
pp <- lift getCurrentProjectPath
|
||||||
let fileUri = doc ^. uri
|
let fileUri = doc ^. uri
|
||||||
(fileVersion, contents) <- VFS.getFileContents fileUri
|
(fileVersion, contents) <- VFS.getFileContents fileUri
|
||||||
parseNames <- lift getCurrentNames
|
parseNames <- lift getCurrentNames
|
||||||
@ -90,7 +90,7 @@ checkFile doc = runMaybeT do
|
|||||||
let parsingEnv =
|
let parsingEnv =
|
||||||
Parser.ParsingEnv
|
Parser.ParsingEnv
|
||||||
{ uniqueNames = uniqueName,
|
{ uniqueNames = uniqueName,
|
||||||
uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath,
|
uniqueTypeGuid = Cli.loadUniqueTypeGuid pp,
|
||||||
names = parseNames
|
names = parseNames
|
||||||
}
|
}
|
||||||
(notes, parsedFile, typecheckedFile) <- do
|
(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.Message qualified as Msg
|
||||||
import Language.LSP.Protocol.Types
|
import Language.LSP.Protocol.Types
|
||||||
import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Formatting
|
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.Conversions (lspToURange, uToLspRange)
|
||||||
import Unison.LSP.FileAnalysis (getFileAnalysis)
|
import Unison.LSP.FileAnalysis (getFileAnalysis)
|
||||||
import Unison.LSP.FileAnalysis qualified as FileAnalysis
|
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 =
|
formatDefs fileUri mayRangesToFormat =
|
||||||
fromMaybe [] <$> runMaybeT do
|
fromMaybe [] <$> runMaybeT do
|
||||||
FileAnalysis {parsedFile = mayParsedFile, typecheckedFile = mayTypecheckedFile} <- getFileAnalysis fileUri
|
FileAnalysis {parsedFile = mayParsedFile, typecheckedFile = mayTypecheckedFile} <- getFileAnalysis fileUri
|
||||||
currentPath <- lift getCurrentPath
|
pp <- lift getCurrentProjectPath
|
||||||
Config {formattingWidth} <- lift getConfig
|
Config {formattingWidth} <- lift getConfig
|
||||||
MaybeT $
|
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
|
<&> (fmap . fmap) uTextReplacementToLSP
|
||||||
where
|
where
|
||||||
uTextReplacementToLSP :: Formatting.TextReplacement -> TextEdit
|
uTextReplacementToLSP :: Formatting.TextReplacement -> TextEdit
|
||||||
|
@ -24,7 +24,7 @@ import Language.LSP.Server
|
|||||||
import Language.LSP.Server qualified as LSP
|
import Language.LSP.Server qualified as LSP
|
||||||
import Language.LSP.VFS
|
import Language.LSP.VFS
|
||||||
import Unison.Codebase
|
import Unison.Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.Runtime (Runtime)
|
import Unison.Codebase.Runtime (Runtime)
|
||||||
import Unison.Debug qualified as Debug
|
import Unison.Debug qualified as Debug
|
||||||
import Unison.LSP.Orphans ()
|
import Unison.LSP.Orphans ()
|
||||||
@ -72,7 +72,7 @@ data Env = Env
|
|||||||
currentNamesCache :: IO Names,
|
currentNamesCache :: IO Names,
|
||||||
ppedCache :: IO PrettyPrintEnvDecl,
|
ppedCache :: IO PrettyPrintEnvDecl,
|
||||||
nameSearchCache :: IO (NameSearch Sqlite.Transaction),
|
nameSearchCache :: IO (NameSearch Sqlite.Transaction),
|
||||||
currentPathCache :: IO Path.Absolute,
|
currentProjectPathCache :: IO PP.ProjectPath,
|
||||||
vfsVar :: MVar VFS,
|
vfsVar :: MVar VFS,
|
||||||
runtime :: Runtime Symbol,
|
runtime :: Runtime Symbol,
|
||||||
-- The information we have for each file.
|
-- The information we have for each file.
|
||||||
@ -129,8 +129,8 @@ data FileAnalysis = FileAnalysis
|
|||||||
}
|
}
|
||||||
deriving stock (Show)
|
deriving stock (Show)
|
||||||
|
|
||||||
getCurrentPath :: Lsp Path.Absolute
|
getCurrentProjectPath :: Lsp PP.ProjectPath
|
||||||
getCurrentPath = asks currentPathCache >>= liftIO
|
getCurrentProjectPath = asks currentProjectPathCache >>= liftIO
|
||||||
|
|
||||||
getCodebaseCompletions :: Lsp CompletionTree
|
getCodebaseCompletions :: Lsp CompletionTree
|
||||||
getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar
|
getCodebaseCompletions = asks completionsVar >>= atomically . readTMVar
|
||||||
|
@ -1,19 +1,17 @@
|
|||||||
module Unison.LSP.UCMWorker where
|
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 U.Codebase.HashTags
|
||||||
|
import Control.Monad.Reader
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Branch.Names 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.Debug qualified as Debug
|
||||||
import Unison.LSP.Completion
|
import Unison.LSP.Completion
|
||||||
import Unison.LSP.Types
|
import Unison.LSP.Types
|
||||||
import Unison.LSP.VFS qualified as VFS
|
import Unison.LSP.VFS qualified as VFS
|
||||||
import Unison.Names (Names)
|
import Unison.Names (Names)
|
||||||
|
import Unison.Prelude
|
||||||
import Unison.PrettyPrintEnv.Names qualified as PPE
|
import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||||
import Unison.PrettyPrintEnvDecl
|
import Unison.PrettyPrintEnvDecl
|
||||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||||
@ -27,21 +25,22 @@ ucmWorker ::
|
|||||||
TMVar PrettyPrintEnvDecl ->
|
TMVar PrettyPrintEnvDecl ->
|
||||||
TMVar Names ->
|
TMVar Names ->
|
||||||
TMVar (NameSearch Sqlite.Transaction) ->
|
TMVar (NameSearch Sqlite.Transaction) ->
|
||||||
TMVar Path.Absolute ->
|
TMVar ProjectPath ->
|
||||||
STM CausalHash ->
|
STM CausalHash ->
|
||||||
STM Path.Absolute ->
|
STM ProjectPath ->
|
||||||
Lsp ()
|
Lsp ()
|
||||||
ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do
|
ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestProjectRootHash getLatestProjectPath = do
|
||||||
Env {codebase, completionsVar} <- ask
|
Env {codebase, completionsVar} <- ask
|
||||||
let loop :: (CausalHash, Path.Absolute) -> Lsp a
|
let loop :: CausalHash -> ProjectPath -> Lsp a
|
||||||
loop (currentRoot, currentPath) = do
|
loop currentProjectRootHash currentProjectPath = do
|
||||||
Debug.debugM Debug.LSP "LSP path: " currentPath
|
currentBranch <- liftIO $ Codebase.expectProjectBranchRoot codebase (currentProjectPath ^. #branch . #projectId) (currentProjectPath ^. #branch . #branchId)
|
||||||
currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath)
|
Debug.debugM Debug.LSP "LSP path: " currentProjectPath
|
||||||
|
let currentBranch0 = Branch.head currentBranch
|
||||||
let currentNames = Branch.toNames currentBranch0
|
let currentNames = Branch.toNames currentBranch0
|
||||||
hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
|
hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
|
||||||
let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames)
|
let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames)
|
||||||
atomically $ do
|
atomically $ do
|
||||||
writeTMVar currentPathVar currentPath
|
writeTMVar currentPathVar currentProjectPath
|
||||||
writeTMVar currentNamesVar currentNames
|
writeTMVar currentNamesVar currentNames
|
||||||
writeTMVar ppedVar pped
|
writeTMVar ppedVar pped
|
||||||
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames)
|
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames)
|
||||||
@ -50,18 +49,18 @@ ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoo
|
|||||||
atomically do
|
atomically do
|
||||||
writeTMVar completionsVar (namesToCompletionTree currentNames)
|
writeTMVar completionsVar (namesToCompletionTree currentNames)
|
||||||
Debug.debugLogM Debug.LSP "LSP Initialized"
|
Debug.debugLogM Debug.LSP "LSP Initialized"
|
||||||
latest <- atomically $ do
|
(latestRootHash, latestProjectPath) <- atomically $ do
|
||||||
latestRoot <- getLatestRoot
|
latestRootHash <- getLatestProjectRootHash
|
||||||
latestPath <- getLatestPath
|
latestPath <- getLatestProjectPath
|
||||||
guard $ (currentRoot /= latestRoot || currentPath /= latestPath)
|
guard $ (currentProjectRootHash /= latestRootHash || currentProjectPath /= latestPath)
|
||||||
pure (latestRoot, latestPath)
|
pure (latestRootHash, latestPath)
|
||||||
Debug.debugLogM Debug.LSP "LSP Change detected"
|
Debug.debugLogM Debug.LSP "LSP Change detected"
|
||||||
loop latest
|
loop latestRootHash latestProjectPath
|
||||||
(rootBranch, currentPath) <- atomically $ do
|
(currentProjectRootHash, currentProjectPath) <- atomically $ do
|
||||||
rootBranch <- getLatestRoot
|
latestProjectRootHash <- getLatestProjectRootHash
|
||||||
currentPath <- getLatestPath
|
currentProjectPath <- getLatestProjectPath
|
||||||
pure (rootBranch, currentPath)
|
pure (latestProjectRootHash, currentProjectPath)
|
||||||
loop (rootBranch, currentPath)
|
loop currentProjectRootHash currentProjectPath
|
||||||
where
|
where
|
||||||
-- This is added in stm-2.5.1, remove this if we upgrade.
|
-- This is added in stm-2.5.1, remove this if we upgrade.
|
||||||
writeTMVar :: TMVar a -> a -> STM ()
|
writeTMVar :: TMVar a -> a -> STM ()
|
||||||
|
@ -48,6 +48,7 @@ import System.Directory
|
|||||||
)
|
)
|
||||||
import System.Environment (getExecutablePath, getProgName, withArgs)
|
import System.Environment (getExecutablePath, getProgName, withArgs)
|
||||||
import System.Exit qualified as Exit
|
import System.Exit qualified as Exit
|
||||||
|
import System.Exit qualified as System
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
( replaceExtension,
|
( replaceExtension,
|
||||||
takeDirectory,
|
takeDirectory,
|
||||||
@ -61,7 +62,9 @@ import System.IO.Error (catchIOError)
|
|||||||
import System.IO.Temp qualified as Temp
|
import System.IO.Temp qualified as Temp
|
||||||
import System.Path qualified as Path
|
import System.Path qualified as Path
|
||||||
import U.Codebase.HashTags (CausalHash)
|
import U.Codebase.HashTags (CausalHash)
|
||||||
|
import U.Codebase.Sqlite.Operations qualified as SqliteOps
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase (Codebase, CodebasePath)
|
import Unison.Codebase (Codebase, CodebasePath)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
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 qualified as CodebaseInit
|
||||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.Runtime qualified as Rt
|
import Unison.Codebase.Runtime qualified as Rt
|
||||||
import Unison.Codebase.SqliteCodebase qualified as SC
|
import Unison.Codebase.SqliteCodebase qualified as SC
|
||||||
import Unison.Codebase.TranscriptParser qualified as TR
|
import Unison.Codebase.TranscriptParser qualified as TR
|
||||||
@ -174,7 +178,7 @@ main version = do
|
|||||||
let noOpRootNotifier _ = pure ()
|
let noOpRootNotifier _ = pure ()
|
||||||
let noOpPathNotifier _ = pure ()
|
let noOpPathNotifier _ = pure ()
|
||||||
let serverUrl = Nothing
|
let serverUrl = Nothing
|
||||||
let startPath = Nothing
|
startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
|
||||||
launch
|
launch
|
||||||
version
|
version
|
||||||
currentDir
|
currentDir
|
||||||
@ -185,7 +189,7 @@ main version = do
|
|||||||
theCodebase
|
theCodebase
|
||||||
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
|
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
|
||||||
serverUrl
|
serverUrl
|
||||||
startPath
|
(PP.toIds startProjectPath)
|
||||||
initRes
|
initRes
|
||||||
noOpRootNotifier
|
noOpRootNotifier
|
||||||
noOpPathNotifier
|
noOpPathNotifier
|
||||||
@ -201,7 +205,7 @@ main version = do
|
|||||||
let noOpRootNotifier _ = pure ()
|
let noOpRootNotifier _ = pure ()
|
||||||
let noOpPathNotifier _ = pure ()
|
let noOpPathNotifier _ = pure ()
|
||||||
let serverUrl = Nothing
|
let serverUrl = Nothing
|
||||||
let startPath = Nothing
|
startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
|
||||||
launch
|
launch
|
||||||
version
|
version
|
||||||
currentDir
|
currentDir
|
||||||
@ -212,7 +216,7 @@ main version = do
|
|||||||
theCodebase
|
theCodebase
|
||||||
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
|
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
|
||||||
serverUrl
|
serverUrl
|
||||||
startPath
|
(PP.toIds startProjectPath)
|
||||||
initRes
|
initRes
|
||||||
noOpRootNotifier
|
noOpRootNotifier
|
||||||
noOpPathNotifier
|
noOpPathNotifier
|
||||||
@ -286,33 +290,44 @@ main version = do
|
|||||||
case mrtsStatsFp of
|
case mrtsStatsFp of
|
||||||
Nothing -> action
|
Nothing -> action
|
||||||
Just fp -> recordRtsStats fp 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
|
getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
|
||||||
withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do
|
withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do
|
||||||
startingPath <- case isHeadless of
|
startingProjectPath <- do
|
||||||
WithCLI -> do
|
-- If the user didn't provide a starting path on the command line, put them in the most recent
|
||||||
-- If the user didn't provide a starting path on the command line, put them in the most recent
|
-- path they cd'd to
|
||||||
-- path they cd'd to
|
case mayStartingProject of
|
||||||
case mayStartingPath of
|
Just startingProject -> do
|
||||||
Just startingPath -> pure startingPath
|
Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace
|
PT.putPrettyLn $
|
||||||
pure (Path.Absolute (Path.fromList segments))
|
P.callout
|
||||||
Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath
|
"❓"
|
||||||
rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash)
|
( P.lines
|
||||||
rootCausalHashVar <- newTVarIO rootCausalHash
|
[ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject)
|
||||||
pathVar <- newTVarIO startingPath
|
]
|
||||||
|
)
|
||||||
|
System.exitFailure
|
||||||
|
Just pab -> do
|
||||||
|
pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty
|
||||||
|
Nothing -> do
|
||||||
|
Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
|
||||||
|
currentProjectRootCH <- Codebase.runTransaction theCodebase do
|
||||||
|
currentPP <- Codebase.expectCurrentProjectPath
|
||||||
|
SqliteOps.expectProjectBranchHead (currentPP.project.projectId) (currentPP.branch.branchId)
|
||||||
|
projectRootHashVar <- newTVarIO currentProjectRootCH
|
||||||
|
projectPathVar <- newTVarIO startingProjectPath
|
||||||
let notifyOnRootChanges :: CausalHash -> STM ()
|
let notifyOnRootChanges :: CausalHash -> STM ()
|
||||||
notifyOnRootChanges b = do
|
notifyOnRootChanges b = do
|
||||||
writeTVar rootCausalHashVar b
|
writeTVar projectRootHashVar b
|
||||||
let notifyOnPathChanges :: Path.Absolute -> STM ()
|
let notifyOnPathChanges :: PP.ProjectPath -> STM ()
|
||||||
notifyOnPathChanges = writeTVar pathVar
|
notifyOnPathChanges = writeTVar projectPathVar
|
||||||
-- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever
|
-- 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
|
-- 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
|
-- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on
|
||||||
-- Windows when we move to GHC 9.*
|
-- Windows when we move to GHC 9.*
|
||||||
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224
|
-- 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
|
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do
|
||||||
case exitOption of
|
case exitOption of
|
||||||
DoNotExit -> do
|
DoNotExit -> do
|
||||||
@ -346,7 +361,7 @@ main version = do
|
|||||||
theCodebase
|
theCodebase
|
||||||
[]
|
[]
|
||||||
(Just baseUrl)
|
(Just baseUrl)
|
||||||
(Just startingPath)
|
(PP.toIds startingProjectPath)
|
||||||
initRes
|
initRes
|
||||||
notifyOnRootChanges
|
notifyOnRootChanges
|
||||||
notifyOnPathChanges
|
notifyOnPathChanges
|
||||||
@ -512,9 +527,6 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba
|
|||||||
)
|
)
|
||||||
when (not completed) $ Exit.exitWith (Exit.ExitFailure 1)
|
when (not completed) $ Exit.exitWith (Exit.ExitFailure 1)
|
||||||
|
|
||||||
defaultInitialPath :: Path.Absolute
|
|
||||||
defaultInitialPath = Path.absoluteEmpty
|
|
||||||
|
|
||||||
launch ::
|
launch ::
|
||||||
Version ->
|
Version ->
|
||||||
FilePath ->
|
FilePath ->
|
||||||
@ -525,13 +537,13 @@ launch ::
|
|||||||
Codebase.Codebase IO Symbol Ann ->
|
Codebase.Codebase IO Symbol Ann ->
|
||||||
[Either Input.Event Input.Input] ->
|
[Either Input.Event Input.Input] ->
|
||||||
Maybe Server.BaseUrl ->
|
Maybe Server.BaseUrl ->
|
||||||
Maybe Path.Absolute ->
|
PP.ProjectPathIds ->
|
||||||
InitResult ->
|
InitResult ->
|
||||||
(CausalHash -> STM ()) ->
|
(CausalHash -> STM ()) ->
|
||||||
(Path.Absolute -> STM ()) ->
|
(PP.ProjectPath -> STM ()) ->
|
||||||
CommandLine.ShouldWatchFiles ->
|
CommandLine.ShouldWatchFiles ->
|
||||||
IO ()
|
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
|
showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist
|
||||||
let isNewCodebase = case initResult of
|
let isNewCodebase = case initResult of
|
||||||
CreatedCodebase -> NewlyCreatedCodebase
|
CreatedCodebase -> NewlyCreatedCodebase
|
||||||
@ -541,7 +553,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
|
|||||||
in CommandLine.main
|
in CommandLine.main
|
||||||
dir
|
dir
|
||||||
welcome
|
welcome
|
||||||
(fromMaybe defaultInitialPath mayStartingPath)
|
startingPath
|
||||||
config
|
config
|
||||||
inputs
|
inputs
|
||||||
runtime
|
runtime
|
||||||
@ -551,7 +563,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
|
|||||||
serverBaseUrl
|
serverBaseUrl
|
||||||
ucmVersion
|
ucmVersion
|
||||||
notifyRootChange
|
notifyRootChange
|
||||||
notifyPathChange
|
notifyProjPathChange
|
||||||
shouldWatchFiles
|
shouldWatchFiles
|
||||||
|
|
||||||
newtype MarkdownFile = MarkdownFile FilePath
|
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 :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
|
||||||
getCodebaseOrExit codebasePathOption migrationStrategy action = do
|
getCodebaseOrExit codebasePathOption migrationStrategy action = do
|
||||||
initOptions <- argsToCodebaseInitOptions codebasePathOption
|
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
|
cbInit@(CreatedCodebase, dir, _) -> do
|
||||||
pDir <- prettyDir dir
|
pDir <- prettyDir dir
|
||||||
PT.putPrettyLn' ""
|
PT.putPrettyLn' ""
|
||||||
|
@ -6,14 +6,10 @@ module Unison.Share.Sync
|
|||||||
getCausalHashByPath,
|
getCausalHashByPath,
|
||||||
GetCausalHashByPathError (..),
|
GetCausalHashByPathError (..),
|
||||||
|
|
||||||
-- ** Push
|
-- ** Upload
|
||||||
checkAndSetPush,
|
|
||||||
CheckAndSetPushError (..),
|
|
||||||
fastForwardPush,
|
|
||||||
FastForwardPushError (..),
|
|
||||||
uploadEntities,
|
uploadEntities,
|
||||||
|
|
||||||
-- ** Pull
|
-- ** Pull/Download
|
||||||
pull,
|
pull,
|
||||||
PullError (..),
|
PullError (..),
|
||||||
downloadEntities,
|
downloadEntities,
|
||||||
@ -26,16 +22,10 @@ import Control.Monad.Except
|
|||||||
import Control.Monad.Reader (ask)
|
import Control.Monad.Reader (ask)
|
||||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
||||||
import Control.Monad.Trans.Reader qualified as Reader
|
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 qualified as Map
|
||||||
import Data.Map.NonEmpty (NEMap)
|
import Data.Map.NonEmpty (NEMap)
|
||||||
import Data.Map.NonEmpty qualified as NEMap
|
import Data.Map.NonEmpty qualified as NEMap
|
||||||
import Data.Proxy
|
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 qualified as Set
|
||||||
import Data.Set.NonEmpty (NESet)
|
import Data.Set.NonEmpty (NESet)
|
||||||
import Data.Set.NonEmpty qualified as 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.Share.Sync.Types
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Unison.Sync.API qualified as Share (API)
|
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.EntityValidation qualified as EV
|
||||||
import Unison.Sync.Types qualified as Share
|
import Unison.Sync.Types qualified as Share
|
||||||
import Unison.Util.Monoid (foldMapM)
|
import Unison.Util.Monoid (foldMapM)
|
||||||
@ -98,300 +88,6 @@ syncChunkSize = unsafePerformIO $ do
|
|||||||
Nothing -> 50
|
Nothing -> 50
|
||||||
{-# NOINLINE syncChunkSize #-}
|
{-# 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
|
-- Pull
|
||||||
|
|
||||||
@ -977,16 +673,6 @@ httpGetCausalHashByPath ::
|
|||||||
BaseUrl ->
|
BaseUrl ->
|
||||||
Share.GetCausalHashByPathRequest ->
|
Share.GetCausalHashByPathRequest ->
|
||||||
IO (Either CodeserverTransportError Share.GetCausalHashByPathResponse)
|
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 ::
|
httpDownloadEntities ::
|
||||||
Auth.AuthenticatedHttpClient ->
|
Auth.AuthenticatedHttpClient ->
|
||||||
BaseUrl ->
|
BaseUrl ->
|
||||||
@ -998,14 +684,10 @@ httpUploadEntities ::
|
|||||||
Share.UploadEntitiesRequest ->
|
Share.UploadEntitiesRequest ->
|
||||||
IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
|
IO (Either CodeserverTransportError Share.UploadEntitiesResponse)
|
||||||
( httpGetCausalHashByPath,
|
( httpGetCausalHashByPath,
|
||||||
httpFastForwardPath,
|
|
||||||
httpUpdatePath,
|
|
||||||
httpDownloadEntities,
|
httpDownloadEntities,
|
||||||
httpUploadEntities
|
httpUploadEntities
|
||||||
) =
|
) =
|
||||||
let ( httpGetCausalHashByPath
|
let ( httpGetCausalHashByPath
|
||||||
Servant.:<|> httpFastForwardPath
|
|
||||||
Servant.:<|> httpUpdatePath
|
|
||||||
Servant.:<|> httpDownloadEntities
|
Servant.:<|> httpDownloadEntities
|
||||||
Servant.:<|> httpUploadEntities
|
Servant.:<|> httpUploadEntities
|
||||||
) =
|
) =
|
||||||
@ -1013,8 +695,6 @@ httpUploadEntities ::
|
|||||||
pp = Proxy
|
pp = Proxy
|
||||||
in Servant.hoistClient pp hoist (Servant.client pp)
|
in Servant.hoistClient pp hoist (Servant.client pp)
|
||||||
in ( go httpGetCausalHashByPath,
|
in ( go httpGetCausalHashByPath,
|
||||||
go httpFastForwardPath,
|
|
||||||
go httpUpdatePath,
|
|
||||||
go httpDownloadEntities,
|
go httpDownloadEntities,
|
||||||
go httpUploadEntities
|
go httpUploadEntities
|
||||||
)
|
)
|
||||||
|
@ -1,8 +1,6 @@
|
|||||||
-- | Types used by the UCM client during sync.
|
-- | Types used by the UCM client during sync.
|
||||||
module Unison.Share.Sync.Types
|
module Unison.Share.Sync.Types
|
||||||
( CheckAndSetPushError (..),
|
( CodeserverTransportError (..),
|
||||||
CodeserverTransportError (..),
|
|
||||||
FastForwardPushError (..),
|
|
||||||
GetCausalHashByPathError (..),
|
GetCausalHashByPathError (..),
|
||||||
PullError (..),
|
PullError (..),
|
||||||
SyncError (..),
|
SyncError (..),
|
||||||
@ -13,29 +11,6 @@ import Servant.Client qualified as Servant
|
|||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Sync.Types qualified as Share
|
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.
|
-- | An error occurred while pulling code from Unison Share.
|
||||||
data PullError
|
data PullError
|
||||||
= PullError'DownloadEntities Share.DownloadEntitiesError
|
= PullError'DownloadEntities Share.DownloadEntitiesError
|
||||||
|
@ -47,7 +47,6 @@ library
|
|||||||
Unison.Cli.Share.Projects.Types
|
Unison.Cli.Share.Projects.Types
|
||||||
Unison.Cli.TypeCheck
|
Unison.Cli.TypeCheck
|
||||||
Unison.Cli.UniqueTypeGuidLookup
|
Unison.Cli.UniqueTypeGuidLookup
|
||||||
Unison.Cli.UnisonConfigUtils
|
|
||||||
Unison.Codebase.Editor.AuthorInfo
|
Unison.Codebase.Editor.AuthorInfo
|
||||||
Unison.Codebase.Editor.HandleInput
|
Unison.Codebase.Editor.HandleInput
|
||||||
Unison.Codebase.Editor.HandleInput.AddRun
|
Unison.Codebase.Editor.HandleInput.AddRun
|
||||||
|
@ -17,6 +17,7 @@ module Unison.Project
|
|||||||
ProjectBranchSpecifier (..),
|
ProjectBranchSpecifier (..),
|
||||||
ProjectAndBranch (..),
|
ProjectAndBranch (..),
|
||||||
projectAndBranchNamesParser,
|
projectAndBranchNamesParser,
|
||||||
|
fullyQualifiedProjectAndBranchNamesParser,
|
||||||
projectAndOptionalBranchParser,
|
projectAndOptionalBranchParser,
|
||||||
branchWithOptionalProjectParser,
|
branchWithOptionalProjectParser,
|
||||||
ProjectAndBranchNames (..),
|
ProjectAndBranchNames (..),
|
||||||
@ -414,6 +415,20 @@ projectAndBranchNamesParser specifier = do
|
|||||||
Just branch -> These project branch
|
Just branch -> These project branch
|
||||||
else pure (This project)
|
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.
|
-- | @project/branch@ syntax, where the branch is optional.
|
||||||
instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
|
instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
|
||||||
from = \case
|
from = \case
|
||||||
|
@ -38,7 +38,7 @@ module Unison.Server.Backend
|
|||||||
lsAtPath,
|
lsAtPath,
|
||||||
lsBranch,
|
lsBranch,
|
||||||
mungeSyntaxText,
|
mungeSyntaxText,
|
||||||
resolveCausalHashV2,
|
Codebase.expectCausalBranchByCausalHash,
|
||||||
resolveRootBranchHashV2,
|
resolveRootBranchHashV2,
|
||||||
namesAtPathFromRootBranchHash,
|
namesAtPathFromRootBranchHash,
|
||||||
termEntryDisplayName,
|
termEntryDisplayName,
|
||||||
@ -58,7 +58,6 @@ module Unison.Server.Backend
|
|||||||
renderDocRefs,
|
renderDocRefs,
|
||||||
docsForDefinitionName,
|
docsForDefinitionName,
|
||||||
normaliseRootCausalHash,
|
normaliseRootCausalHash,
|
||||||
causalHashForProjectBranchName,
|
|
||||||
|
|
||||||
-- * Unused, could remove?
|
-- * Unused, could remove?
|
||||||
resolveRootBranchHash,
|
resolveRootBranchHash,
|
||||||
@ -101,16 +100,12 @@ import U.Codebase.Branch qualified as V2Branch
|
|||||||
import U.Codebase.Causal qualified as V2Causal
|
import U.Codebase.Causal qualified as V2Causal
|
||||||
import U.Codebase.HashTags (BranchHash, CausalHash (..))
|
import U.Codebase.HashTags (BranchHash, CausalHash (..))
|
||||||
import U.Codebase.Referent qualified as V2Referent
|
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.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.ABT qualified as ABT
|
||||||
import Unison.Builtin qualified as B
|
import Unison.Builtin qualified as B
|
||||||
import Unison.Builtin.Decls qualified as Decls
|
import Unison.Builtin.Decls qualified as Decls
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase qualified as UCodebase
|
|
||||||
import Unison.Codebase.Branch (Branch)
|
import Unison.Codebase.Branch (Branch)
|
||||||
import Unison.Codebase.Branch qualified as Branch
|
import Unison.Codebase.Branch qualified as Branch
|
||||||
import Unison.Codebase.Branch.Names 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.PrettyPrintEnv.Util qualified as PPE
|
||||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectBranchName, ProjectName)
|
||||||
import Unison.Project.Util qualified as ProjectUtils
|
|
||||||
import Unison.Reference (Reference, TermReference, TypeReference)
|
import Unison.Reference (Reference, TermReference, TypeReference)
|
||||||
import Unison.Reference qualified as Reference
|
import Unison.Reference qualified as Reference
|
||||||
import Unison.Referent (Referent)
|
import Unison.Referent (Referent)
|
||||||
@ -370,12 +364,12 @@ lsAtPath ::
|
|||||||
(MonadIO m) =>
|
(MonadIO m) =>
|
||||||
Codebase m Symbol Ann ->
|
Codebase m Symbol Ann ->
|
||||||
-- The root to follow the path from.
|
-- 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 from the root to the branch to 'ls'
|
||||||
Path.Absolute ->
|
Path.Absolute ->
|
||||||
m [ShallowListEntry Symbol Ann]
|
m [ShallowListEntry Symbol Ann]
|
||||||
lsAtPath codebase mayRootBranch absPath = do
|
lsAtPath codebase rootBranch absPath = do
|
||||||
b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) mayRootBranch)
|
b <- Codebase.runTransaction codebase (Codebase.getShallowBranchAtPath (Path.unabsolute absPath) rootBranch)
|
||||||
lsBranch codebase b
|
lsBranch codebase b
|
||||||
|
|
||||||
findDocInBranch ::
|
findDocInBranch ::
|
||||||
@ -700,14 +694,12 @@ expandShortCausalHash hash = do
|
|||||||
|
|
||||||
-- | Efficiently resolve a root hash and path to a shallow branch's causal.
|
-- | Efficiently resolve a root hash and path to a shallow branch's causal.
|
||||||
getShallowCausalAtPathFromRootHash ::
|
getShallowCausalAtPathFromRootHash ::
|
||||||
Maybe CausalHash ->
|
CausalHash ->
|
||||||
Path ->
|
Path ->
|
||||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
getShallowCausalAtPathFromRootHash mayRootHash path = do
|
getShallowCausalAtPathFromRootHash rootHash path = do
|
||||||
shallowRoot <- case mayRootHash of
|
shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash
|
||||||
Nothing -> Codebase.getShallowRootCausal
|
Codebase.getShallowCausalAtPath path shallowRoot
|
||||||
Just h -> Codebase.expectCausalBranchByCausalHash h
|
|
||||||
Codebase.getShallowCausalAtPath path (Just shallowRoot)
|
|
||||||
|
|
||||||
formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
|
formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
|
||||||
formatType' ppe w =
|
formatType' ppe w =
|
||||||
@ -987,16 +979,12 @@ namesAtPathFromRootBranchHash ::
|
|||||||
forall m n v a.
|
forall m n v a.
|
||||||
(MonadIO m) =>
|
(MonadIO m) =>
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
Maybe (V2Branch.CausalBranch n) ->
|
V2Branch.CausalBranch n ->
|
||||||
Path ->
|
Path ->
|
||||||
Backend m (Names, PPED.PrettyPrintEnvDecl)
|
Backend m (Names, PPED.PrettyPrintEnvDecl)
|
||||||
namesAtPathFromRootBranchHash codebase mbh path = do
|
namesAtPathFromRootBranchHash codebase cb path = do
|
||||||
shouldUseNamesIndex <- asks useNamesIndex
|
shouldUseNamesIndex <- asks useNamesIndex
|
||||||
(rootBranchHash, rootCausalHash) <- case mbh of
|
let (rootBranchHash, rootCausalHash) = (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
||||||
Just cb -> pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
|
||||||
Nothing -> lift $ do
|
|
||||||
cb <- Codebase.runTransaction codebase Operations.expectRootCausal
|
|
||||||
pure (V2Causal.valueHash cb, V2Causal.causalHash cb)
|
|
||||||
haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash)
|
haveNameLookupForRoot <- lift $ Codebase.runTransaction codebase (Ops.checkBranchHashNameLookupExists rootBranchHash)
|
||||||
hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength
|
hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength
|
||||||
names <-
|
names <-
|
||||||
@ -1005,47 +993,34 @@ namesAtPathFromRootBranchHash codebase mbh path = do
|
|||||||
when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash
|
when (not haveNameLookupForRoot) . throwError $ ExpectedNameLookup rootBranchHash
|
||||||
lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path
|
lift . Codebase.runTransaction codebase $ Codebase.namesAtPath rootBranchHash path
|
||||||
else do
|
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)
|
let pped = PPED.makePPED (PPE.hqNamer hashLen names) (PPE.suffixifyByHash names)
|
||||||
pure (names, pped)
|
pure (names, pped)
|
||||||
|
|
||||||
resolveCausalHash ::
|
resolveCausalHash ::
|
||||||
(Monad m) => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m)
|
(Monad m) => CausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||||
resolveCausalHash h codebase = case h of
|
resolveCausalHash bhash codebase = do
|
||||||
Nothing -> lift (Codebase.getRootBranch codebase)
|
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
|
||||||
Just bhash -> do
|
whenNothing mayBranch (throwError $ NoBranchForHash bhash)
|
||||||
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
|
|
||||||
whenNothing mayBranch (throwError $ NoBranchForHash bhash)
|
|
||||||
|
|
||||||
resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
|
||||||
resolveCausalHashV2 h = case h of
|
|
||||||
Nothing -> Codebase.getShallowRootCausal
|
|
||||||
Just ch -> Codebase.expectCausalBranchByCausalHash ch
|
|
||||||
|
|
||||||
resolveRootBranchHash ::
|
resolveRootBranchHash ::
|
||||||
(MonadIO m) => Maybe ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
|
(MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m)
|
||||||
resolveRootBranchHash mayRoot codebase = case mayRoot of
|
resolveRootBranchHash sch codebase = do
|
||||||
Nothing ->
|
h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
|
||||||
lift (Codebase.getRootBranch codebase)
|
resolveCausalHash h codebase
|
||||||
Just sch -> do
|
|
||||||
h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch)
|
|
||||||
resolveCausalHash (Just h) codebase
|
|
||||||
|
|
||||||
resolveRootBranchHashV2 ::
|
resolveRootBranchHashV2 ::
|
||||||
Maybe ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
resolveRootBranchHashV2 mayRoot = case mayRoot of
|
resolveRootBranchHashV2 sch = do
|
||||||
Nothing -> lift Codebase.getShallowRootCausal
|
h <- expandShortCausalHash sch
|
||||||
Just sch -> do
|
lift (Codebase.expectCausalBranchByCausalHash h)
|
||||||
h <- expandShortCausalHash sch
|
|
||||||
lift (resolveCausalHashV2 (Just h))
|
|
||||||
|
|
||||||
normaliseRootCausalHash :: Maybe (Either ShortCausalHash CausalHash) -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
normaliseRootCausalHash :: Either ShortCausalHash CausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
normaliseRootCausalHash mayCh = case mayCh of
|
normaliseRootCausalHash = \case
|
||||||
Nothing -> lift $ resolveCausalHashV2 Nothing
|
(Left sch) -> do
|
||||||
Just (Left sch) -> do
|
|
||||||
ch <- expandShortCausalHash sch
|
ch <- expandShortCausalHash sch
|
||||||
lift $ resolveCausalHashV2 (Just ch)
|
lift $ Codebase.expectCausalBranchByCausalHash ch
|
||||||
Just (Right ch) -> lift $ resolveCausalHashV2 (Just ch)
|
(Right ch) -> lift $ Codebase.expectCausalBranchByCausalHash ch
|
||||||
|
|
||||||
-- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?)
|
-- | 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 ->
|
Reference.DerivedId id ->
|
||||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||||
<$> Codebase.getTypeDeclaration c id
|
<$> 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 ((</>))
|
||||||
import System.FilePath qualified as FilePath
|
import System.FilePath qualified as FilePath
|
||||||
import System.Random.MWC (createSystemRandom)
|
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 U.Codebase.HashTags (CausalHash)
|
||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as 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.Local.Endpoints.UCM (UCMAPI, ucmServer)
|
||||||
import Unison.Server.NameSearch (NameSearch (..))
|
import Unison.Server.NameSearch (NameSearch (..))
|
||||||
import Unison.Server.NameSearch.FromNames qualified as Names
|
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.ShortHash qualified as ShortHash
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
import Unison.Symbol (Symbol)
|
import Unison.Symbol (Symbol)
|
||||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||||
import Unison.Util.Pretty qualified as Pretty
|
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
|
-- HTML content type
|
||||||
data HTML = HTML
|
data HTML = HTML
|
||||||
|
|
||||||
@ -236,7 +235,7 @@ data DefinitionReference
|
|||||||
data Service
|
data Service
|
||||||
= LooseCodeUI Path.Absolute (Maybe DefinitionReference)
|
= LooseCodeUI Path.Absolute (Maybe DefinitionReference)
|
||||||
| -- (Project branch names, perspective within project, definition reference)
|
| -- (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
|
| Api
|
||||||
deriving stock (Show)
|
deriving stock (Show)
|
||||||
|
|
||||||
@ -296,13 +295,13 @@ urlFor :: Service -> BaseUrl -> Text
|
|||||||
urlFor service baseUrl =
|
urlFor service baseUrl =
|
||||||
case service of
|
case service of
|
||||||
LooseCodeUI perspective def ->
|
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 ->
|
ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def ->
|
||||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path 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"]
|
Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"]
|
||||||
where
|
where
|
||||||
path :: Path.Path -> Maybe DefinitionReference -> [URISegment]
|
path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment]
|
||||||
path ns def =
|
path (Path.Absolute ns) def =
|
||||||
let nsPath = namespacePath ns
|
let nsPath = namespacePath ns
|
||||||
in case definitionPath def of
|
in case definitionPath def of
|
||||||
Just defPath -> case nsPath of
|
Just defPath -> case nsPath of
|
||||||
@ -565,12 +564,12 @@ serveLooseCode ::
|
|||||||
Rt.Runtime Symbol ->
|
Rt.Runtime Symbol ->
|
||||||
ServerT LooseCodeAPI (Backend IO)
|
ServerT LooseCodeAPI (Backend IO)
|
||||||
serveLooseCode codebase rt =
|
serveLooseCode codebase rt =
|
||||||
(\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left <$> root) rel name)
|
(\root rel name -> setCacheControl <$> NamespaceListing.serve codebase (Left root) rel name)
|
||||||
:<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left <$> mayRoot) renderWidth)
|
:<|> (\namespaceName mayRoot renderWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Left mayRoot) renderWidth)
|
||||||
:<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left <$> mayRoot) relativePath rawHqns renderWidth suff)
|
:<|> (\mayRoot relativePath rawHqns renderWidth suff -> setCacheControl <$> serveDefinitions rt codebase (Left mayRoot) relativePath rawHqns renderWidth suff)
|
||||||
:<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left <$> mayRoot) relativePath limit renderWidth query)
|
:<|> (\mayRoot relativePath limit renderWidth query -> setCacheControl <$> serveFuzzyFind codebase (Left mayRoot) relativePath limit renderWidth query)
|
||||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
|
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTermSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
|
||||||
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left <$> mayRoot) relativeTo renderWidth)
|
:<|> (\shortHash mayName mayRoot relativeTo renderWidth -> setCacheControl <$> serveTypeSummary codebase shortHash mayName (Left mayRoot) relativeTo renderWidth)
|
||||||
|
|
||||||
serveProjectsCodebaseServerAPI ::
|
serveProjectsCodebaseServerAPI ::
|
||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
@ -588,34 +587,38 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do
|
|||||||
where
|
where
|
||||||
projectAndBranchName = ProjectAndBranch projectName branchName
|
projectAndBranchName = ProjectAndBranch projectName branchName
|
||||||
namespaceListingEndpoint _rootParam rel name = do
|
namespaceListingEndpoint _rootParam rel name = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name
|
setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name
|
||||||
namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do
|
namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth
|
setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth
|
||||||
|
|
||||||
serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do
|
serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff
|
setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff
|
||||||
|
|
||||||
serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do
|
serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query
|
setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query
|
||||||
|
|
||||||
serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
|
setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth
|
||||||
|
|
||||||
serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do
|
||||||
root <- resolveProjectRoot codebase projectAndBranchName
|
root <- resolveProjectRootHash codebase projectAndBranchName
|
||||||
setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth
|
setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth
|
||||||
|
|
||||||
resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash
|
resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO (V2.CausalBranch Sqlite.Transaction)
|
||||||
resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do
|
resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do
|
||||||
mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName
|
mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName
|
||||||
case mayCH of
|
case mayCB of
|
||||||
Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName)
|
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 IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse
|
||||||
serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do
|
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 IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction)
|
||||||
contextForProjectBranch codebase projectName branchName = do
|
contextForProjectBranch codebase projectName branchName = do
|
||||||
projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName)
|
projectRootHash <- resolveProjectRootHash codebase (ProjectAndBranch projectName branchName)
|
||||||
projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash
|
projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash
|
||||||
hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
|
hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
|
||||||
let names = Branch.toNames (Branch.head projectRootBranch)
|
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.
|
-- ppe which returns names fully qualified to the current perspective, not to the codebase root.
|
||||||
let biases = maybeToList $ HQ.toName query
|
let biases = maybeToList $ HQ.toName query
|
||||||
hqLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength
|
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 pped = PPED.biasTo biases unbiasedPPED
|
||||||
let nameSearch = makeNameSearch hqLength localNamesOnly
|
let nameSearch = makeNameSearch hqLength localNamesOnly
|
||||||
(DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do
|
(DefinitionResults terms types misses) <- liftIO $ Codebase.runTransaction codebase do
|
||||||
|
@ -7,17 +7,12 @@ import Data.Aeson
|
|||||||
import Data.OpenApi (ToSchema (..))
|
import Data.OpenApi (ToSchema (..))
|
||||||
import Servant ((:>))
|
import Servant ((:>))
|
||||||
import Servant.Docs (ToSample (..))
|
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 (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.NameSegment (NameSegment)
|
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment)
|
|
||||||
import Unison.Server.Backend
|
import Unison.Server.Backend
|
||||||
import Unison.Server.Types (APIGet)
|
import Unison.Server.Types (APIGet)
|
||||||
|
|
||||||
@ -39,7 +34,7 @@ instance ToSample Current where
|
|||||||
Current
|
Current
|
||||||
(Just $ UnsafeProjectName "@unison/base")
|
(Just $ UnsafeProjectName "@unison/base")
|
||||||
(Just $ UnsafeProjectBranchName "main")
|
(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 :: MonadIO m => Codebase m v a -> m Current
|
||||||
getCurrentProjectBranch codebase = do
|
getCurrentProjectBranch codebase = do
|
||||||
segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace
|
pp <- Codebase.runTransaction codebase Codebase.expectCurrentProjectPath
|
||||||
let absolutePath = toPath segments
|
let (PP.ProjectPath projName branchName path) = PP.toNames pp
|
||||||
case toIds segments of
|
pure $ Current (Just projName) (Just branchName) path
|
||||||
ProjectAndBranch (Just projectId) branchId ->
|
|
||||||
Codebase.runTransaction codebase do
|
|
||||||
project <- Queries.expectProject projectId
|
|
||||||
branch <- traverse (Queries.expectProjectBranch projectId) branchId
|
|
||||||
pure $ Current (Just $ Project.name project) (ProjectBranch.name <$> branch) absolutePath
|
|
||||||
ProjectAndBranch _ _ ->
|
|
||||||
pure $ Current Nothing Nothing absolutePath
|
|
||||||
where
|
|
||||||
toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId)
|
|
||||||
toIds segments =
|
|
||||||
case segments of
|
|
||||||
ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ ->
|
|
||||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId}
|
|
||||||
ProjectsNameSegment : UUIDNameSegment projectId : _ ->
|
|
||||||
ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing}
|
|
||||||
_ ->
|
|
||||||
ProjectAndBranch {project = Nothing, branch = Nothing}
|
|
||||||
|
|
||||||
toPath :: [NameSegment] -> Path.Absolute
|
|
||||||
toPath = Path.Absolute . Path.fromList
|
|
||||||
|
@ -48,6 +48,7 @@ import Unison.Server.Backend qualified as Backend
|
|||||||
import Unison.Server.Syntax (SyntaxText)
|
import Unison.Server.Syntax (SyntaxText)
|
||||||
import Unison.Server.Types
|
import Unison.Server.Types
|
||||||
( APIGet,
|
( APIGet,
|
||||||
|
RequiredQueryParam,
|
||||||
TermTag (..),
|
TermTag (..),
|
||||||
TypeTag,
|
TypeTag,
|
||||||
mayDefaultWidth,
|
mayDefaultWidth,
|
||||||
@ -67,7 +68,7 @@ type TermSummaryAPI =
|
|||||||
-- It's propagated through to the response as-is.
|
-- It's propagated through to the response as-is.
|
||||||
-- If missing, the short hash will be used instead.
|
-- If missing, the short hash will be used instead.
|
||||||
:> QueryParam "name" Name
|
:> QueryParam "name" Name
|
||||||
:> QueryParam "rootBranch" ShortCausalHash
|
:> RequiredQueryParam "rootBranch" ShortCausalHash
|
||||||
:> QueryParam "relativeTo" Path.Path
|
:> QueryParam "relativeTo" Path.Path
|
||||||
:> QueryParam "renderWidth" Width
|
:> QueryParam "renderWidth" Width
|
||||||
:> APIGet TermSummary
|
:> APIGet TermSummary
|
||||||
@ -98,11 +99,11 @@ serveTermSummary ::
|
|||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
Referent ->
|
Referent ->
|
||||||
Maybe Name ->
|
Maybe Name ->
|
||||||
Maybe (Either ShortCausalHash CausalHash) ->
|
Either ShortCausalHash CausalHash ->
|
||||||
Maybe Path.Path ->
|
Maybe Path.Path ->
|
||||||
Maybe Width ->
|
Maybe Width ->
|
||||||
Backend IO TermSummary
|
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 shortHash = Referent.toShortHash referent
|
||||||
let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName
|
let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName
|
||||||
let relativeToPath = fromMaybe Path.empty relativeTo
|
let relativeToPath = fromMaybe Path.empty relativeTo
|
||||||
@ -111,7 +112,7 @@ serveTermSummary codebase referent mayName mayRoot relativeTo mayWidth = do
|
|||||||
|
|
||||||
(root, sig) <-
|
(root, sig) <-
|
||||||
Backend.hoistBackend (Codebase.runTransaction codebase) do
|
Backend.hoistBackend (Codebase.runTransaction codebase) do
|
||||||
root <- Backend.normaliseRootCausalHash mayRoot
|
root <- Backend.normaliseRootCausalHash root
|
||||||
sig <- lift (Backend.loadReferentType codebase referent)
|
sig <- lift (Backend.loadReferentType codebase referent)
|
||||||
pure (root, sig)
|
pure (root, sig)
|
||||||
case sig of
|
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)
|
namesPerspective <- Ops.namesPerspectiveForRootAndPath (V2Causal.valueHash root) (coerce . Path.toList $ fromMaybe Path.Empty relativeTo)
|
||||||
PPESqlite.ppedForReferences namesPerspective deps
|
PPESqlite.ppedForReferences namesPerspective deps
|
||||||
False -> do
|
False -> do
|
||||||
(_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just root) relativeToPath
|
(_localNames, ppe) <- Backend.namesAtPathFromRootBranchHash codebase root relativeToPath
|
||||||
pure ppe
|
pure ppe
|
||||||
let formattedTermSig = Backend.formatSuffixedType ppe width typeSig
|
let formattedTermSig = Backend.formatSuffixedType ppe width typeSig
|
||||||
let summary = mkSummary termReference formattedTermSig
|
let summary = mkSummary termReference formattedTermSig
|
||||||
@ -150,7 +151,7 @@ type TypeSummaryAPI =
|
|||||||
-- It's propagated through to the response as-is.
|
-- It's propagated through to the response as-is.
|
||||||
-- If missing, the short hash will be used instead.
|
-- If missing, the short hash will be used instead.
|
||||||
:> QueryParam "name" Name
|
:> QueryParam "name" Name
|
||||||
:> QueryParam "rootBranch" ShortCausalHash
|
:> RequiredQueryParam "rootBranch" ShortCausalHash
|
||||||
:> QueryParam "relativeTo" Path.Path
|
:> QueryParam "relativeTo" Path.Path
|
||||||
:> QueryParam "renderWidth" Width
|
:> QueryParam "renderWidth" Width
|
||||||
:> APIGet TypeSummary
|
:> APIGet TypeSummary
|
||||||
@ -181,7 +182,7 @@ serveTypeSummary ::
|
|||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
Reference ->
|
Reference ->
|
||||||
Maybe Name ->
|
Maybe Name ->
|
||||||
Maybe (Either ShortCausalHash CausalHash) ->
|
Either ShortCausalHash CausalHash ->
|
||||||
Maybe Path.Path ->
|
Maybe Path.Path ->
|
||||||
Maybe Width ->
|
Maybe Width ->
|
||||||
Backend IO TypeSummary
|
Backend IO TypeSummary
|
||||||
|
@ -37,6 +37,7 @@ import Unison.Server.Types
|
|||||||
HashQualifiedName,
|
HashQualifiedName,
|
||||||
NamedTerm,
|
NamedTerm,
|
||||||
NamedType,
|
NamedType,
|
||||||
|
RequiredQueryParam,
|
||||||
UnisonName,
|
UnisonName,
|
||||||
mayDefaultWidth,
|
mayDefaultWidth,
|
||||||
)
|
)
|
||||||
@ -46,7 +47,7 @@ import Unison.Util.Pretty (Width)
|
|||||||
|
|
||||||
type FuzzyFindAPI =
|
type FuzzyFindAPI =
|
||||||
"find"
|
"find"
|
||||||
:> QueryParam "rootBranch" SCH.ShortCausalHash
|
:> RequiredQueryParam "rootBranch" SCH.ShortCausalHash
|
||||||
:> QueryParam "relativeTo" Path.Path
|
:> QueryParam "relativeTo" Path.Path
|
||||||
:> QueryParam "limit" Int
|
:> QueryParam "limit" Int
|
||||||
:> QueryParam "renderWidth" Width
|
:> QueryParam "renderWidth" Width
|
||||||
@ -141,18 +142,18 @@ serveFuzzyFind ::
|
|||||||
forall m.
|
forall m.
|
||||||
(MonadIO m) =>
|
(MonadIO m) =>
|
||||||
Codebase m Symbol Ann ->
|
Codebase m Symbol Ann ->
|
||||||
Maybe (Either SCH.ShortCausalHash CausalHash) ->
|
Either SCH.ShortCausalHash CausalHash ->
|
||||||
Maybe Path.Path ->
|
Maybe Path.Path ->
|
||||||
Maybe Int ->
|
Maybe Int ->
|
||||||
Maybe Width ->
|
Maybe Width ->
|
||||||
Maybe String ->
|
Maybe String ->
|
||||||
Backend.Backend m [(FZF.Alignment, FoundResult)]
|
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
|
let path = fromMaybe Path.empty relativeTo
|
||||||
rootCausal <-
|
rootCausal <-
|
||||||
Backend.hoistBackend (Codebase.runTransaction codebase) do
|
Backend.hoistBackend (Codebase.runTransaction codebase) do
|
||||||
Backend.normaliseRootCausalHash mayRoot
|
Backend.normaliseRootCausalHash root
|
||||||
(localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path
|
(localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase rootCausal path
|
||||||
let alignments ::
|
let alignments ::
|
||||||
( [ ( FZF.Alignment,
|
( [ ( FZF.Alignment,
|
||||||
UnisonName,
|
UnisonName,
|
||||||
|
@ -35,6 +35,7 @@ import Unison.Server.Local.Definitions qualified as Local
|
|||||||
import Unison.Server.Types
|
import Unison.Server.Types
|
||||||
( APIGet,
|
( APIGet,
|
||||||
DefinitionDisplayResults,
|
DefinitionDisplayResults,
|
||||||
|
RequiredQueryParam,
|
||||||
Suffixify (..),
|
Suffixify (..),
|
||||||
defaultWidth,
|
defaultWidth,
|
||||||
)
|
)
|
||||||
@ -44,7 +45,7 @@ import Unison.Util.Pretty (Width)
|
|||||||
|
|
||||||
type DefinitionsAPI =
|
type DefinitionsAPI =
|
||||||
"getDefinition"
|
"getDefinition"
|
||||||
:> QueryParam "rootBranch" ShortCausalHash
|
:> RequiredQueryParam "rootBranch" ShortCausalHash
|
||||||
:> QueryParam "relativeTo" Path.Path
|
:> QueryParam "relativeTo" Path.Path
|
||||||
:> QueryParams "names" (HQ.HashQualified Name)
|
:> QueryParams "names" (HQ.HashQualified Name)
|
||||||
:> QueryParam "renderWidth" Width
|
:> QueryParam "renderWidth" Width
|
||||||
@ -96,7 +97,7 @@ instance ToParam (QueryParam "namespace" Path.Path) where
|
|||||||
)
|
)
|
||||||
Normal
|
Normal
|
||||||
|
|
||||||
instance ToParam (QueryParam "rootBranch" ShortCausalHash) where
|
instance ToParam (RequiredQueryParam "rootBranch" ShortCausalHash) where
|
||||||
toParam _ =
|
toParam _ =
|
||||||
DocQueryParam
|
DocQueryParam
|
||||||
"rootBranch"
|
"rootBranch"
|
||||||
@ -120,15 +121,15 @@ instance ToSample DefinitionDisplayResults where
|
|||||||
serveDefinitions ::
|
serveDefinitions ::
|
||||||
Rt.Runtime Symbol ->
|
Rt.Runtime Symbol ->
|
||||||
Codebase IO Symbol Ann ->
|
Codebase IO Symbol Ann ->
|
||||||
Maybe (Either ShortCausalHash CausalHash) ->
|
Either ShortCausalHash CausalHash ->
|
||||||
Maybe Path.Path ->
|
Maybe Path.Path ->
|
||||||
[HQ.HashQualified Name] ->
|
[HQ.HashQualified Name] ->
|
||||||
Maybe Width ->
|
Maybe Width ->
|
||||||
Maybe Suffixify ->
|
Maybe Suffixify ->
|
||||||
Backend.Backend IO DefinitionDisplayResults
|
Backend.Backend IO DefinitionDisplayResults
|
||||||
serveDefinitions rt codebase mayRoot relativePath hqns width suff =
|
serveDefinitions rt codebase root relativePath hqns width suff =
|
||||||
do
|
do
|
||||||
rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ mayRoot
|
rootCausalHash <- Backend.hoistBackend (Codebase.runTransaction codebase) . Backend.normaliseRootCausalHash $ root
|
||||||
hqns
|
hqns
|
||||||
& foldMapM
|
& foldMapM
|
||||||
( Local.prettyDefinitionsForHQName
|
( 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