unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-08-15 13:30:27 +03:00
Code Issues Projects Releases Wiki Activity

Merge trunk

Browse Source
This commit is contained in:
Chris Penner 2024-07-09 14:52:38 -07:00
commit 736ccf1434
164 changed files with 4366 additions and 4672 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitignore vendored
View File

@ -1,9 +1,14 @@
# Unison
.unison*
test-output
transcript-*
scratch.u
unisonLocal.zip
*.uc
# Ignore all scratch files...
*.u
# Except those in unison-src
!unison-src/**/*.u
# And integration tests
!unison-cli-integration/integration-tests/IntegrationTests/**/*.u
# Auto-generated
jit-tests.md

128
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -1,10 +1,5 @@
module U.Codebase.Sqlite.Operations
( -- * branches
saveRootBranch,
loadRootCausalHash,
expectRootCausalHash,
expectRootCausal,
expectRootBranchHash,
loadCausalHashAtPath,
expectCausalHashAtPath,
loadCausalBranchAtPath,
@ -13,6 +8,7 @@ module U.Codebase.Sqlite.Operations
saveBranchV3,
loadCausalBranchByCausalHash,
expectCausalBranchByCausalHash,
expectBranchByCausalHashId,
expectBranchByBranchHash,
expectBranchByBranchHashId,
expectNamespaceStatsByHash,
@ -100,9 +96,16 @@ module U.Codebase.Sqlite.Operations
fuzzySearchDefinitions,
namesPerspectiveForRootAndPath,
-- * Projects
expectProjectAndBranchNames,
expectProjectBranchHead,
-- * reflog
getReflog,
appendReflog,
getDeprecatedRootReflog,
getProjectReflog,
getProjectBranchReflog,
getGlobalReflog,
appendProjectReflog,
-- * low-level stuff
expectDbBranch,
@ -183,6 +186,9 @@ import U.Codebase.Sqlite.Patch.TermEdit qualified as S
import U.Codebase.Sqlite.Patch.TermEdit qualified as S.TermEdit
import U.Codebase.Sqlite.Patch.TypeEdit qualified as S
import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Reference qualified as S
import U.Codebase.Sqlite.Reference qualified as S.Reference
@ -200,6 +206,7 @@ import U.Codebase.TypeEdit qualified as C.TypeEdit
import U.Codebase.WatchKind (WatchKind)
import U.Util.Base32Hex qualified as Base32Hex
import U.Util.Serialization qualified as S
import Unison.Core.Project (ProjectBranchName, ProjectName)
import Unison.Hash qualified as H
import Unison.Hash32 qualified as Hash32
import Unison.NameSegment (NameSegment)
@ -232,23 +239,10 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId
loadValueHashById :: Db.BranchHashId -> Transaction BranchHash
loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId
expectRootCausalHash :: Transaction CausalHash
expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot
expectRootBranchHash :: Transaction BranchHash
expectRootBranchHash = do
rootCausalHashId <- Q.expectNamespaceRoot
expectValueHashByCausalHashId rootCausalHashId
loadRootCausalHash :: Transaction (Maybe CausalHash)
loadRootCausalHash =
runMaybeT $
lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot
-- | Load the causal hash at the given path from the provided root, if Nothing, use the
-- codebase root.
loadCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
loadCausalHashAtPath mayRootCausalHash =
loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
loadCausalHashAtPath rootCausalHash =
let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
go hashId = \case
[] -> lift (Q.expectCausalHash hashId)
@ -258,15 +252,13 @@ loadCausalHashAtPath mayRootCausalHash =
(_, hashId') <- MaybeT (pure (Map.lookup tid children))
go hashId' ts
in \path -> do
hashId <- case mayRootCausalHash of
Nothing -> Q.expectNamespaceRoot
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
runMaybeT (go hashId path)
-- | Expect the causal hash at the given path from the provided root, if Nothing, use the
-- codebase root.
expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash
expectCausalHashAtPath mayRootCausalHash =
expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash
expectCausalHashAtPath rootCausalHash =
let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
go hashId = \case
[] -> Q.expectCausalHash hashId
@ -276,23 +268,21 @@ expectCausalHashAtPath mayRootCausalHash =
let (_, hashId') = children Map.! tid
go hashId' ts
in \path -> do
hashId <- case mayRootCausalHash of
Nothing -> Q.expectNamespaceRoot
Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
go hashId path
loadCausalBranchAtPath ::
Maybe CausalHash ->
CausalHash ->
[NameSegment] ->
Transaction (Maybe (C.Branch.CausalBranch Transaction))
loadCausalBranchAtPath maybeRootCausalHash path =
loadCausalHashAtPath maybeRootCausalHash path >>= \case
loadCausalBranchAtPath rootCausalHash path =
loadCausalHashAtPath rootCausalHash path >>= \case
Nothing -> pure Nothing
Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
loadBranchAtPath maybeRootCausalHash path =
loadCausalBranchAtPath maybeRootCausalHash path >>= \case
loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
loadBranchAtPath rootCausalHash path =
loadCausalBranchAtPath rootCausalHash path >>= \case
Nothing -> pure Nothing
Just causal -> Just <$> C.Causal.value causal
@ -613,16 +603,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
boId <- Q.expectBranchObjectIdByCausalHashId chId
expectBranch boId
saveRootBranch ::
HashHandle ->
C.Branch.CausalBranch Transaction ->
Transaction (Db.BranchObjectId, Db.CausalHashId)
saveRootBranch hh c = do
when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c)
(boId, chId) <- saveBranch hh c
Q.setNamespaceRoot chId
pure (boId, chId)
-- saveBranch is kind of a "deep save causal"
-- we want a "shallow save causal" that could take a
@ -749,9 +729,6 @@ saveCausalObject hh (C.Causal.Causal hc he parents _) = do
Q.saveCausal hh chId bhId parentCausalHashIds
pure (chId, bhId)
expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction)
expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId
loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction))
loadCausalBranchByCausalHash hc = do
Q.loadCausalHashIdByCausalHash hc >>= \case
@ -1510,15 +1487,43 @@ namespaceStatsForDbBranch = \case
expectNamespaceStatsByHashId bhId
-- | Gets the specified number of reflog entries in chronological order, most recent first.
getReflog :: Int -> Transaction [Reflog.Entry CausalHash Text]
getReflog numEntries = do
entries <- Q.getReflog numEntries
getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHash Text]
getDeprecatedRootReflog numEntries = do
entries <- Q.getDeprecatedRootReflog numEntries
traverse (bitraverse Q.expectCausalHash pure) entries
appendReflog :: Reflog.Entry CausalHash Text -> Transaction ()
appendReflog entry = do
dbEntry <- (bitraverse Q.saveCausalHash pure) entry
Q.appendReflog dbEntry
-- | Gets the specified number of reflog entries for the given project in chronological order, most recent first.
getProjectReflog :: Int -> Db.ProjectId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]
getProjectReflog numEntries projectId = do
entries <- Q.getProjectReflog numEntries projectId
traverse hydrateProjectReflogEntry entries
-- | Gets the specified number of reflog entries for the specified ProjectBranch in chronological order, most recent first.
getProjectBranchReflog :: Int -> Db.ProjectBranchId -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]
getProjectBranchReflog numEntries projectBranchId = do
entries <- Q.getProjectBranchReflog numEntries projectBranchId
traverse hydrateProjectReflogEntry entries
-- | Gets the specified number of reflog entries in chronological order, most recent first.
getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]
getGlobalReflog numEntries = do
entries <- Q.getGlobalReflog numEntries
traverse hydrateProjectReflogEntry entries
hydrateProjectReflogEntry :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId Db.CausalHashId -> Transaction (ProjectReflog.Entry Project ProjectBranch CausalHash)
hydrateProjectReflogEntry entry = do
traverse Q.expectCausalHash entry
>>= ProjectReflog.projectAndBranch_
%%~ ( \(projId, branchId) -> do
proj <- Q.expectProject projId
branch <- Q.expectProjectBranch projId branchId
pure (proj, branch)
)
appendProjectReflog :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId CausalHash -> Transaction ()
appendProjectReflog entry = do
dbEntry <- traverse Q.saveCausalHash entry
Q.appendProjectBranchReflog dbEntry
-- | Delete any name lookup that's not in the provided list.
--
@ -1584,3 +1589,14 @@ stripPrefixFromNamedRef (PathSegments prefix) namedRef =
Nothing -> reversedName
Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath)
in namedRef {S.reversedSegments = newReversedName}
expectProjectAndBranchNames :: Db.ProjectId -> Db.ProjectBranchId -> Transaction (ProjectName, ProjectBranchName)
expectProjectAndBranchNames projectId projectBranchId = do
Project {name = pName} <- Q.expectProject projectId
ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId
pure (pName, bName)
expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash
expectProjectBranchHead projId projectBranchId = do
chId <- Q.expectProjectBranchHead projId projectBranchId
Q.expectCausalHash chId

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs
View File

@ -14,5 +14,5 @@ data Project = Project
{ projectId :: !ProjectId,
name :: !ProjectName
}
deriving stock (Generic, Show)
deriving stock (Generic, Show, Eq)
deriving anyclass (ToRow, FromRow)

50
codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs Normal file
View File

@ -0,0 +1,50 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module U.Codebase.Sqlite.ProjectReflog
( Entry (..),
project_,
branch_,
projectAndBranch_,
)
where
import Control.Lens
import Data.Text (Text)
import Data.Time (UTCTime)
import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId)
import Unison.Sqlite (FromRow (..), ToRow (..), field)
data Entry project branch causal = Entry
{ project :: project,
branch :: branch,
time :: UTCTime,
fromRootCausalHash :: Maybe causal,
toRootCausalHash :: causal,
reason :: Text
}
deriving stock (Eq, Show, Functor, Foldable, Traversable)
project_ :: Lens (Entry project branch causal) (Entry project' branch causal) project project'
project_ = lens project (\e p -> e {project = p})
branch_ :: Lens (Entry project branch causal) (Entry project branch' causal) branch branch'
branch_ = lens branch (\e b -> e {branch = b})
-- | Both Project and Branch Ids are required to load a branch, so this is often more useful.
projectAndBranch_ :: Lens (Entry project branch causal) (Entry project' branch' causal) (project, branch) (project', branch')
projectAndBranch_ = lens (\Entry {..} -> (project, branch)) (\e (project, branch) -> e {project = project, branch = branch})
instance ToRow (Entry ProjectId ProjectBranchId CausalHashId) where
toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) =
toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason)
instance FromRow (Entry ProjectId ProjectBranchId CausalHashId) where
fromRow = do
project <- field
branch <- field
time <- field
fromRootCausalHash <- field
toRootCausalHash <- field
reason <- field
pure $ Entry {..}

243
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -66,12 +66,6 @@ module U.Codebase.Sqlite.Queries
loadTermObject,
expectTermObject,
-- * namespace_root table
loadNamespaceRoot,
setNamespaceRoot,
expectNamespaceRoot,
expectNamespaceRootBranchHashId,
-- * namespace_statistics table
saveNamespaceStats,
loadNamespaceStatsByHashId,
@ -135,6 +129,8 @@ module U.Codebase.Sqlite.Queries
insertProjectBranch,
renameProjectBranch,
deleteProjectBranch,
setProjectBranchHead,
expectProjectBranchHead,
setMostRecentBranch,
loadMostRecentBranch,
@ -215,8 +211,11 @@ module U.Codebase.Sqlite.Queries
fuzzySearchTypes,
-- * Reflog
appendReflog,
getReflog,
getDeprecatedRootReflog,
appendProjectBranchReflog,
getProjectReflog,
getProjectBranchReflog,
getGlobalReflog,
-- * garbage collection
garbageCollectObjectsWithoutHashes,
@ -237,12 +236,12 @@ module U.Codebase.Sqlite.Queries
-- * elaborate hashes
elaborateHashes,
-- * most recent namespace
expectMostRecentNamespace,
setMostRecentNamespace,
-- * current project path
expectCurrentProjectPath,
setCurrentProjectPath,
-- * migrations
createSchema,
runCreateSql,
addTempEntityTables,
addReflogTable,
addNamespaceStatsTables,
@ -254,6 +253,9 @@ module U.Codebase.Sqlite.Queries
addSquashResultTable,
addSquashResultTableIfNotExists,
cdToProjectRoot,
addCurrentProjectPathTable,
addProjectBranchReflogTable,
addProjectBranchCausalHashIdColumn,
-- ** schema version
currentSchemaVersion,
@ -315,6 +317,7 @@ import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Time qualified as Time
import Data.Vector qualified as Vector
import GHC.Stack (callStack)
import Network.URI (URI)
@ -367,7 +370,8 @@ import U.Codebase.Sqlite.Orphans ()
import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Reference qualified as S (Reference, ReferenceH, TermReference, TermReferenceId, TextReference, TypeReference, TypeReferenceId)
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import U.Codebase.Sqlite.Reference qualified as S
import U.Codebase.Sqlite.Reference qualified as S.Reference
import U.Codebase.Sqlite.Referent qualified as S (TextReferent)
import U.Codebase.Sqlite.Referent qualified as S.Referent
@ -399,6 +403,7 @@ import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Prelude
import Unison.Sqlite
import Unison.Sqlite qualified as Sqlite
import Unison.Util.Alternative qualified as Alternative
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.FileEmbed (embedProjectStringFile)
@ -414,27 +419,11 @@ type TextPathSegments = [Text]
-- * main squeeze
currentSchemaVersion :: SchemaVersion
currentSchemaVersion = 16
currentSchemaVersion = 17
createSchema :: Transaction ()
createSchema = do
runCreateSql :: Transaction ()
runCreateSql =
executeStatements $(embedProjectStringFile "sql/create.sql")
addTempEntityTables
addNamespaceStatsTables
addReflogTable
fixScopedNameLookupTables
addProjectTables
addMostRecentBranchTable
addNameLookupMountTables
addMostRecentNamespaceTable
execute insertSchemaVersionSql
addSquashResultTable
where
insertSchemaVersionSql =
[sql|
INSERT INTO schema_version (version)
VALUES (:currentSchemaVersion)
|]
addTempEntityTables :: Transaction ()
addTempEntityTables =
@ -444,6 +433,7 @@ addNamespaceStatsTables :: Transaction ()
addNamespaceStatsTables =
executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql")
-- | Deprecated in favour of project-branch reflog
addReflogTable :: Transaction ()
addReflogTable =
executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql")
@ -482,6 +472,19 @@ cdToProjectRoot :: Transaction ()
cdToProjectRoot =
executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql")
addCurrentProjectPathTable :: Transaction ()
addCurrentProjectPathTable =
executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql")
-- | Deprecated in favour of project-branch reflog
addProjectBranchReflogTable :: Transaction ()
addProjectBranchReflogTable =
executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql")
addProjectBranchCausalHashIdColumn :: Transaction ()
addProjectBranchCausalHashIdColumn =
executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql")
schemaVersion :: Transaction SchemaVersion
schemaVersion =
queryOneCol
@ -1337,32 +1340,6 @@ loadCausalParentsByHash hash =
WHERE h1.base32 = :hash COLLATE NOCASE
|]
expectNamespaceRootBranchHashId :: Transaction BranchHashId
expectNamespaceRootBranchHashId = do
chId <- expectNamespaceRoot
expectCausalValueHashId chId
expectNamespaceRoot :: Transaction CausalHashId
expectNamespaceRoot =
queryOneCol loadNamespaceRootSql
loadNamespaceRoot :: Transaction (Maybe CausalHashId)
loadNamespaceRoot =
queryMaybeCol loadNamespaceRootSql
loadNamespaceRootSql :: Sql
loadNamespaceRootSql =
[sql|
SELECT causal_id
FROM namespace_root
|]
setNamespaceRoot :: CausalHashId -> Transaction ()
setNamespaceRoot id =
queryOneCol [sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case
False -> execute [sql| INSERT INTO namespace_root VALUES (:id) |]
True -> execute [sql| UPDATE namespace_root SET causal_id = :id |]
saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction ()
saveWatch k r blob = do
execute
@ -3496,16 +3473,8 @@ loadNamespaceStatsByHashId bhId = do
WHERE namespace_hash_id = :bhId
|]
appendReflog :: Reflog.Entry CausalHashId Text -> Transaction ()
appendReflog entry =
execute
[sql|
INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason)
VALUES (@entry, @, @, @)
|]
getReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
getReflog numEntries =
getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
getDeprecatedRootReflog numEntries =
queryListRow
[sql|
SELECT time, from_root_causal_id, to_root_causal_id, reason
@ -3514,6 +3483,49 @@ getReflog numEntries =
LIMIT :numEntries
|]
appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
appendProjectBranchReflog entry =
execute
[sql|
INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason)
VALUES (@entry, @, @, @, @, @)
|]
-- | Get x number of entries from the project reflog for the provided project
getProjectReflog :: Int -> ProjectId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getProjectReflog numEntries projectId =
queryListRow
[sql|
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
FROM project_branch_reflog
WHERE project_id = :projectId
ORDER BY time DESC
LIMIT :numEntries
|]
-- | Get x number of entries from the project reflog for the provided branch.
getProjectBranchReflog :: Int -> ProjectBranchId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getProjectBranchReflog numEntries projectBranchId =
queryListRow
[sql|
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
FROM project_branch_reflog
WHERE project_branch_id = :projectBranchId
ORDER BY time DESC
LIMIT :numEntries
|]
-- | Get x number of entries from the global reflog spanning all projects
getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getGlobalReflog numEntries =
queryListRow
[sql|
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
FROM project_branch_reflog
ORDER BY time DESC
LIMIT :numEntries
|]
-- | Does a project exist with this id?
projectExists :: ProjectId -> Transaction Bool
projectExists projectId =
@ -3803,12 +3815,15 @@ loadProjectAndBranchNames projectId branchId =
|]
-- | Insert a project branch.
insertProjectBranch :: ProjectBranch -> Transaction ()
insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
-- Ensure we never point at a causal we don't have the branch for.
_ <- expectBranchObjectIdByCausalHashId causalHashId
execute
[sql|
INSERT INTO project_branch (project_id, branch_id, name)
VALUES (:projectId, :branchId, :branchName)
INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
VALUES (:projectId, :branchId, :branchName, :causalHashId)
|]
whenJust maybeParentBranchId \parentBranchId ->
execute
@ -3816,6 +3831,16 @@ insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBran
INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id)
VALUES (:projectId, :parentBranchId, :branchId)
|]
time <- Sqlite.unsafeIO $ Time.getCurrentTime
appendProjectBranchReflog $
ProjectReflog.Entry
{ project = projectId,
branch = branchId,
time,
fromRootCausalHash = Nothing,
toRootCausalHash = causalHashId,
reason = description
}
-- | Rename a project branch.
--
@ -3864,7 +3889,7 @@ deleteProject projectId = do
-- After deleting `topic`:
--
-- main <- topic2
deleteProjectBranch :: ProjectId -> ProjectBranchId -> Transaction ()
deleteProjectBranch :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction ()
deleteProjectBranch projectId branchId = do
maybeParentBranchId :: Maybe ProjectBranchId <-
queryMaybeCol
@ -3888,6 +3913,38 @@ deleteProjectBranch projectId branchId = do
WHERE project_id = :projectId AND branch_id = :branchId
|]
-- | Set project branch HEAD
setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction ()
setProjectBranchHead description projectId branchId causalHashId = do
-- Ensure we never point at a causal we don't have the branch for.
_ <- expectBranchObjectIdByCausalHashId causalHashId
oldRootCausalHashId <- expectProjectBranchHead projectId branchId
execute
[sql|
UPDATE project_branch
SET causal_hash_id = :causalHashId
WHERE project_id = :projectId AND branch_id = :branchId
|]
time <- Sqlite.unsafeIO $ Time.getCurrentTime
appendProjectBranchReflog $
ProjectReflog.Entry
{ project = projectId,
branch = branchId,
time = time,
fromRootCausalHash = Just oldRootCausalHashId,
toRootCausalHash = causalHashId,
reason = description
}
expectProjectBranchHead :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction CausalHashId
expectProjectBranchHead projectId branchId =
queryOneCol
[sql|
SELECT causal_hash_id
FROM project_branch
WHERE project_id = :projectId AND branch_id = :branchId
|]
data LoadRemoteBranchFlag
= IncludeSelfRemote
| ExcludeSelfRemote
@ -4372,33 +4429,39 @@ data JsonParseFailure = JsonParseFailure
deriving anyclass (SqliteExceptionReason)
-- | Get the most recent namespace the user has visited.
expectMostRecentNamespace :: Transaction [NameSegment]
expectMostRecentNamespace =
queryOneColCheck
expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
expectCurrentProjectPath =
queryOneRowCheck
[sql|
SELECT namespace
FROM most_recent_namespace
SELECT project_id, branch_id, path
FROM current_project_path
|]
check
where
check :: Text -> Either JsonParseFailure [NameSegment]
check bytes =
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
Right namespace -> Right (map NameSegment namespace)
check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
check (projId, branchId, pathText) =
case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of
Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure}
Right namespace -> Right (projId, branchId, map NameSegment namespace)
-- | Set the most recent namespace the user has visited.
setMostRecentNamespace :: [NameSegment] -> Transaction ()
setMostRecentNamespace namespace =
setCurrentProjectPath ::
ProjectId ->
ProjectBranchId ->
[NameSegment] ->
Transaction ()
setCurrentProjectPath projId branchId path = do
execute
[sql| DELETE FROM current_project_path |]
execute
[sql|
UPDATE most_recent_namespace
SET namespace = :json
INSERT INTO current_project_path(project_id, branch_id, path)
VALUES (:projId, :branchId, :jsonPath)
|]
where
json :: Text
json =
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace)
jsonPath :: Text
jsonPath =
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path)
-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
-- at some point in the past.

1
codebase2/codebase-sqlite/package.yaml
View File

@ -27,6 +27,7 @@ dependencies:
- nonempty-containers
- safe
- text
- time
- transformers
- unison-codebase
- unison-codebase-sync

15
codebase2/codebase-sqlite/sql/012-add-current-project-path-table.sql Normal file
View File

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

32
codebase2/codebase-sqlite/sql/013-add-project-branch-reflog-table.sql Normal file
View File

@ -0,0 +1,32 @@
-- A reflog which is tied to the project/branch
CREATE TABLE project_branch_reflog (
project_id INTEGER NOT NULL,
project_branch_id INTEGER NOT NULL,
-- Reminder that SQLITE doesn't have any actual 'time' type,
-- This column contains TEXT values formatted as ISO8601 strings
-- ("YYYY-MM-DD HH:MM:SS.SSS")
time TEXT NOT NULL,
-- from_root_causal_id will be null if the branch was just created
from_root_causal_id INTEGER NULL REFERENCES causal(self_hash_id),
to_root_causal_id INTEGER NOT NULL REFERENCES causal(self_hash_id),
reason TEXT NOT NULL,
foreign key (project_id, project_branch_id)
references project_branch (project_id, branch_id)
on delete cascade
);
CREATE INDEX project_branch_reflog_by_time ON project_branch_reflog (
project_branch_id, time DESC
);
CREATE INDEX project_reflog_by_time ON project_branch_reflog (
project_id, time DESC
);
CREATE INDEX global_reflog_by_time ON project_branch_reflog (
time DESC
);

2
codebase2/codebase-sqlite/sql/014-add-project-branch-causal-hash-id.sql Normal file
View File

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

7
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.36.0.
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
@ -21,6 +21,9 @@ extra-source-files:
sql/009-add-squash-cache-table.sql
sql/010-ensure-squash-cache-table.sql
sql/011-cd-to-project-root.sql
sql/012-add-current-project-path-table.sql
sql/013-add-project-branch-reflog-table.sql
sql/014-add-project-branch-causal-hash-id.sql
sql/create.sql
source-repository head
@ -54,6 +57,7 @@ library
U.Codebase.Sqlite.Patch.TypeEdit
U.Codebase.Sqlite.Project
U.Codebase.Sqlite.ProjectBranch
U.Codebase.Sqlite.ProjectReflog
U.Codebase.Sqlite.Queries
U.Codebase.Sqlite.Reference
U.Codebase.Sqlite.Referent
@ -121,6 +125,7 @@ library
, nonempty-containers
, safe
, text
, time
, transformers
, unison-codebase
, unison-codebase-sync

34
lib/unison-sqlite/src/Unison/Sqlite/Connection.hs
View File

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

10
lib/unison-sqlite/src/Unison/Sqlite/Exception.hs
View File

@ -24,7 +24,8 @@ where
import Control.Concurrent (ThreadId, myThreadId)
import Data.Typeable (cast)
import Database.SQLite.Simple qualified as Sqlite
import GHC.Stack (currentCallStack)
import GHC.Stack (CallStack)
import GHC.Stack qualified as Stack
import Unison.Prelude
import Unison.Sqlite.Connection.Internal (Connection)
import Unison.Sqlite.Sql (Sql (..))
@ -112,7 +113,7 @@ data SqliteQueryException = SqliteQueryException
-- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally
-- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
exception :: SomeSqliteExceptionReason,
callStack :: [String],
callStack :: CallStack,
connection :: Connection,
threadId :: ThreadId
}
@ -137,16 +138,15 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo
exception :: SomeSqliteExceptionReason
}
throwSqliteQueryException :: SqliteQueryExceptionInfo -> IO a
throwSqliteQueryException :: HasCallStack => SqliteQueryExceptionInfo -> IO a
throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do
threadId <- myThreadId
callStack <- currentCallStack
throwIO
SqliteQueryException
{ sql,
params,
exception,
callStack,
callStack = Stack.callStack,
connection,
threadId
}

48
lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs
View File

@ -88,7 +88,7 @@ instance MonadIO TransactionWithMonadIO where
coerce @(IO a -> Transaction a) unsafeIO
-- | Run a transaction on the given connection.
runTransaction :: (MonadIO m) => Connection -> Transaction a -> m a
runTransaction :: (MonadIO m, HasCallStack) => Connection -> Transaction a -> m a
runTransaction conn (Transaction f) = liftIO do
uninterruptibleMask \restore -> do
Connection.begin conn
@ -117,7 +117,7 @@ instance Show RollingBack where
-- | Run a transaction on the given connection, providing a function that can short-circuit (and roll back) the
-- transaction.
runTransactionWithRollback ::
(MonadIO m) =>
(MonadIO m, HasCallStack) =>
Connection ->
((forall void. a -> Transaction void) -> Transaction a) ->
m a
@ -137,13 +137,13 @@ runTransactionWithRollback conn transaction = liftIO do
--
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does
-- attempt a write and gets SQLITE_BUSY, it's your fault!
runReadOnlyTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runReadOnlyTransaction :: (MonadUnliftIO m, HasCallStack) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runReadOnlyTransaction conn f =
withRunInIO \runInIO ->
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
runReadOnlyTransaction_ :: Connection -> IO a -> IO a
runReadOnlyTransaction_ :: HasCallStack => Connection -> IO a -> IO a
runReadOnlyTransaction_ conn action = do
bracketOnError_
(Connection.begin conn)
@ -160,7 +160,7 @@ runReadOnlyTransaction_ conn action = do
-- BEGIN/COMMIT statements.
--
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions.
runWriteTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runWriteTransaction :: (HasCallStack, MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
runWriteTransaction conn f =
withRunInIO \runInIO ->
uninterruptibleMask \restore ->
@ -170,7 +170,7 @@ runWriteTransaction conn f =
(runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
runWriteTransaction_ :: (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
runWriteTransaction_ :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
runWriteTransaction_ restore conn transaction = do
keepTryingToBeginImmediate restore conn
result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn)
@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do
pure result
-- @BEGIN IMMEDIATE@ until success.
keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> IO ()
keepTryingToBeginImmediate :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO ()
keepTryingToBeginImmediate restore conn =
let loop =
try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case
@ -217,7 +217,7 @@ savepoint (Transaction action) = do
-- transaction needs to retry.
--
-- /Warning/: attempting to run a transaction inside a transaction will cause an exception!
unsafeIO :: IO a -> Transaction a
unsafeIO :: HasCallStack => IO a -> Transaction a
unsafeIO action =
Transaction \_ -> action
@ -232,18 +232,18 @@ unsafeUnTransaction (Transaction action) =
-- Without results
execute :: Sql -> Transaction ()
execute :: HasCallStack => Sql -> Transaction ()
execute s =
Transaction \conn -> Connection.execute conn s
executeStatements :: Text -> Transaction ()
executeStatements :: HasCallStack => Text -> Transaction ()
executeStatements s =
Transaction \conn -> Connection.executeStatements conn s
-- With results, without checks
queryStreamRow ::
(Sqlite.FromRow a) =>
(Sqlite.FromRow a, HasCallStack) =>
Sql ->
(Transaction (Maybe a) -> Transaction r) ->
Transaction r
@ -254,7 +254,7 @@ queryStreamRow sql callback =
queryStreamCol ::
forall a r.
(Sqlite.FromField a) =>
(Sqlite.FromField a, HasCallStack) =>
Sql ->
(Transaction (Maybe a) -> Transaction r) ->
Transaction r
@ -264,34 +264,34 @@ queryStreamCol =
@(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r)
queryStreamRow
queryListRow :: (Sqlite.FromRow a) => Sql -> Transaction [a]
queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow s =
Transaction \conn -> Connection.queryListRow conn s
queryListCol :: (Sqlite.FromField a) => Sql -> Transaction [a]
queryListCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol s =
Transaction \conn -> Connection.queryListCol conn s
queryMaybeRow :: (Sqlite.FromRow a) => Sql -> Transaction (Maybe a)
queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow s =
Transaction \conn -> Connection.queryMaybeRow conn s
queryMaybeCol :: (Sqlite.FromField a) => Sql -> Transaction (Maybe a)
queryMaybeCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeCol s =
Transaction \conn -> Connection.queryMaybeCol conn s
queryOneRow :: (Sqlite.FromRow a) => Sql -> Transaction a
queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction a
queryOneRow s =
Transaction \conn -> Connection.queryOneRow conn s
queryOneCol :: (Sqlite.FromField a) => Sql -> Transaction a
queryOneCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol s =
Transaction \conn -> Connection.queryOneCol conn s
-- With results, with parameters, with checks
queryListRowCheck ::
(Sqlite.FromRow a, SqliteExceptionReason e) =>
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
([a] -> Either e r) ->
Transaction r
@ -299,7 +299,7 @@ queryListRowCheck sql check =
Transaction \conn -> Connection.queryListRowCheck conn sql check
queryListColCheck ::
(Sqlite.FromField a, SqliteExceptionReason e) =>
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
([a] -> Either e r) ->
Transaction r
@ -307,7 +307,7 @@ queryListColCheck sql check =
Transaction \conn -> Connection.queryListColCheck conn sql check
queryMaybeRowCheck ::
(Sqlite.FromRow a, SqliteExceptionReason e) =>
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
(a -> Either e r) ->
Transaction (Maybe r)
@ -315,7 +315,7 @@ queryMaybeRowCheck s check =
Transaction \conn -> Connection.queryMaybeRowCheck conn s check
queryMaybeColCheck ::
(Sqlite.FromField a, SqliteExceptionReason e) =>
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
(a -> Either e r) ->
Transaction (Maybe r)
@ -323,7 +323,7 @@ queryMaybeColCheck s check =
Transaction \conn -> Connection.queryMaybeColCheck conn s check
queryOneRowCheck ::
(Sqlite.FromRow a, SqliteExceptionReason e) =>
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
(a -> Either e r) ->
Transaction r
@ -331,7 +331,7 @@ queryOneRowCheck s check =
Transaction \conn -> Connection.queryOneRowCheck conn s check
queryOneColCheck ::
(Sqlite.FromField a, SqliteExceptionReason e) =>
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql ->
(a -> Either e r) ->
Transaction r

172
parser-typechecker/src/Unison/Codebase.hs
View File

@ -1,6 +1,11 @@
module Unison.Codebase
( Codebase,
-- * UCM session state
expectCurrentProjectPath,
setCurrentProjectPath,
resolveProjectPathIds,
-- * Terms
getTerm,
unsafeGetTerm,
@ -43,18 +48,19 @@ module Unison.Codebase
lca,
SqliteCodebase.Operations.before,
getShallowBranchAtPath,
getMaybeShallowBranchAtPath,
getShallowCausalAtPath,
getBranchAtPath,
Operations.expectCausalBranchByCausalHash,
getShallowCausalFromRoot,
getShallowRootBranch,
getShallowRootCausal,
getShallowCausalAtPathFromRootHash,
getShallowProjectBranchRoot,
expectShallowProjectBranchRoot,
getShallowBranchAtProjectPath,
getMaybeShallowBranchAtProjectPath,
getShallowProjectRootByNames,
expectProjectBranchRoot,
getBranchAtProjectPath,
-- * Root branch
getRootBranch,
SqliteCodebase.Operations.getRootBranchExists,
Operations.expectRootCausalHash,
putRootBranch,
SqliteCodebase.Operations.namesAtPath,
-- * Patches
@ -70,7 +76,10 @@ module Unison.Codebase
Queries.clearWatches,
-- * Reflog
Operations.getReflog,
Operations.getDeprecatedRootReflog,
Operations.getProjectBranchReflog,
Operations.getProjectReflog,
Operations.getGlobalReflog,
-- * Unambiguous hash length
SqliteCodebase.Operations.hashLength,
@ -103,16 +112,19 @@ module Unison.Codebase
toCodeLookup,
typeLookupForDependencies,
unsafeGetComponentLength,
SqliteCodebase.Operations.emptyCausalHash,
)
where
import Data.Map qualified as Map
import Data.Set qualified as Set
import U.Codebase.Branch qualified as V2
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Builtin qualified as Builtin
import Unison.Builtin.Terms qualified as Builtin
@ -122,11 +134,13 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
import Unison.Codebase.CodeLookup qualified as CL
import Unison.Codebase.Path
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
import Unison.Codebase.Type (Codebase (..))
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.Core.Project (ProjectAndBranch)
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DD
import Unison.Hash (Hash)
@ -134,6 +148,7 @@ import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Parser
import Unison.Prelude
import Unison.Project (ProjectAndBranch (ProjectAndBranch), ProjectBranchName, ProjectName)
import Unison.Reference (Reference, TermReferenceId, TypeReference)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
@ -164,72 +179,105 @@ runTransactionWithRollback ::
runTransactionWithRollback Codebase {withConnection} action =
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
getShallowCausalFromRoot ::
-- Optional root branch, if Nothing use the codebase's root branch.
Maybe CausalHash ->
getShallowCausalAtPathFromRootHash ::
-- Causal to start at, if Nothing use the codebase's root branch.
CausalHash ->
Path.Path ->
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
getShallowCausalFromRoot mayRootHash p = do
rootCausal <- case mayRootHash of
Nothing -> getShallowRootCausal
Just ch -> Operations.expectCausalBranchByCausalHash ch
getShallowCausalAtPath p (Just rootCausal)
-- | Get the shallow representation of the root branches without loading the children or
-- history.
getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction)
getShallowRootBranch = do
getShallowRootCausal >>= V2Causal.value
-- | Get the shallow representation of the root branches without loading the children or
-- history.
getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction)
getShallowRootCausal = do
hash <- Operations.expectRootCausalHash
Operations.expectCausalBranchByCausalHash hash
getShallowCausalAtPathFromRootHash rootCausalHash p = do
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
getShallowCausalAtPath p rootCausal
-- | Recursively descend into causals following the given path,
-- Use the root causal if none is provided.
getShallowCausalAtPath ::
Path ->
Maybe (V2Branch.CausalBranch Sqlite.Transaction) ->
(V2Branch.CausalBranch Sqlite.Transaction) ->
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
getShallowCausalAtPath path mayCausal = do
causal <- whenNothing mayCausal getShallowRootCausal
getShallowCausalAtPath path causal = do
case path of
Path.Empty -> pure causal
ns Path.:< p -> do
b <- V2Causal.value causal
case V2Branch.childAt ns b of
Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
Just childCausal -> getShallowCausalAtPath p (Just childCausal)
Just childCausal -> getShallowCausalAtPath p childCausal
-- | Recursively descend into causals following the given path,
-- Use the root causal if none is provided.
getShallowBranchAtPath ::
Path ->
Maybe (V2Branch.Branch Sqlite.Transaction) ->
V2Branch.Branch Sqlite.Transaction ->
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
getShallowBranchAtPath path mayBranch = do
branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch
-- | Recursively descend into causals following the given path,
-- Use the root causal if none is provided.
getMaybeShallowBranchAtPath ::
Path ->
V2Branch.Branch Sqlite.Transaction ->
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
getMaybeShallowBranchAtPath path branch = do
case path of
Path.Empty -> pure branch
Path.Empty -> pure $ Just branch
ns Path.:< p -> do
case V2Branch.childAt ns branch of
Nothing -> pure V2Branch.empty
Nothing -> pure Nothing
Just childCausal -> do
childBranch <- V2Causal.value childCausal
getShallowBranchAtPath p (Just childBranch)
getMaybeShallowBranchAtPath p childBranch
-- | Get a v1 branch from the root following the given path.
getBranchAtPath ::
-- | Recursively descend into causals following the given path,
-- Use the root causal if none is provided.
getShallowBranchAtProjectPath ::
PP.ProjectPath ->
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp
-- | Recursively descend into causals following the given path,
-- Use the root causal if none is provided.
getMaybeShallowBranchAtProjectPath ::
PP.ProjectPath ->
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
getShallowProjectBranchRoot projectBranch >>= \case
Nothing -> pure Nothing
Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do
ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName
causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId
causalHash <- lift $ Q.expectCausalHash causalHashId
lift $ Operations.expectCausalBranchByCausalHash causalHash
expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m)
expectProjectBranchRoot codebase projectId branchId = do
causalHash <- runTransaction codebase $ do
causalHashId <- Q.expectProjectBranchHead projectId branchId
Q.expectCausalHash causalHashId
expectBranchForHash codebase causalHash
expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
causalHashId <- Q.expectProjectBranchHead projectId branchId
causalHash <- Q.expectCausalHash causalHashId
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
causalHashId <- Q.expectProjectBranchHead projectId branchId
causalHash <- Q.expectCausalHash causalHashId
Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value
getBranchAtProjectPath ::
(MonadIO m) =>
Codebase m v a ->
Path.Absolute ->
m (Branch m)
getBranchAtPath codebase path = do
V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing
expectBranchForHash codebase causalHash
PP.ProjectPath ->
m (Maybe (Branch m))
getBranchAtProjectPath codebase pp = runMaybeT do
rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId
hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch
-- | Like 'getBranchForHash', but for when the hash is known to be in the codebase.
expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m)
@ -347,9 +395,12 @@ typeLookupForDependencies codebase s = do
unseen :: TL.TypeLookup Symbol a -> Reference -> Bool
unseen tl r =
isNothing
( Map.lookup r (TL.dataDecls tl) $> ()
<|> Map.lookup r (TL.typeOfTerms tl) $> ()
<|> Map.lookup r (TL.effectDecls tl) $> ()
( Map.lookup r (TL.dataDecls tl)
$> ()
<|> Map.lookup r (TL.typeOfTerms tl)
$> ()
<|> Map.lookup r (TL.effectDecls tl)
$> ()
)
toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
@ -509,3 +560,22 @@ unsafeGetTermComponent codebase hash =
getTermComponentWithTypes codebase hash <&> \case
Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found"))
Just terms -> terms
expectCurrentProjectPath :: (HasCallStack) => Sqlite.Transaction PP.ProjectPath
expectCurrentProjectPath = do
(projectId, projectBranchId, path) <- Q.expectCurrentProjectPath
proj <- Q.expectProject projectId
projBranch <- Q.expectProjectBranch projectId projectBranchId
let absPath = Path.Absolute (Path.fromList path)
pure $ PP.ProjectPath proj projBranch absPath
setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction ()
setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) =
Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path))
-- | Hydrate the project and branch from IDs.
resolveProjectPathIds :: PP.ProjectPathIds -> Sqlite.Transaction PP.ProjectPath
resolveProjectPathIds (PP.ProjectPath projectId projectBranchId path) = do
proj <- Q.expectProject projectId
projBranch <- Q.expectProjectBranch projectId projectBranchId
pure $ PP.ProjectPath proj projBranch path

9
parser-typechecker/src/Unison/Codebase/BranchUtil.hs
View File

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

41
parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs
View File

@ -1,8 +1,5 @@
module Unison.Codebase.Editor.RemoteRepo where
import Control.Lens (Lens')
import Control.Lens qualified as Lens
import Data.Void (absurd)
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.NameSegment qualified as NameSegment
@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path =
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void
writeNamespaceToRead = \case
WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} ->
ReadShare'LooseCode ReadShareLooseCode {server, repo, path}
WriteRemoteProjectBranch v -> absurd v
-- | print remote namespace
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
printReadRemoteNamespace printProject = \case
@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case
ReadShare'ProjectBranch project -> printProject project
-- | Render a 'WriteRemoteNamespace' as text.
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
printWriteRemoteNamespace = \case
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
displayShareCodeserver server repo path
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text
printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
maybePrintPath :: Path -> Text
maybePrintPath path =
@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} =
case path of
(segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
_ -> False
data WriteRemoteNamespace a
= WriteRemoteNamespaceShare !WriteShareRemoteNamespace
| WriteRemoteProjectBranch a
deriving stock (Eq, Functor, Show)
-- | A lens which focuses the path of a remote namespace.
remotePath_ :: Lens' (WriteRemoteNamespace Void) Path
remotePath_ = Lens.lens getter setter
where
getter = \case
WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path
WriteRemoteProjectBranch v -> absurd v
setter remote path =
case remote of
WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) ->
WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path
WriteRemoteProjectBranch v -> absurd v
data WriteShareRemoteNamespace = WriteShareRemoteNamespace
{ server :: !ShareCodeserver,
repo :: !ShareUserHandle,
path :: !Path
}
deriving stock (Eq, Show)

31
parser-typechecker/src/Unison/Codebase/Execute.hs
View File

@ -6,19 +6,23 @@
module Unison.Codebase.Execute where
import Control.Exception (finally)
import Control.Monad.Except (throwError, runExceptT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.MainTerm (getMainTerm)
import Unison.Codebase.MainTerm qualified as MainTerm
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Codebase.Runtime qualified as Runtime
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
@ -27,15 +31,22 @@ import Unison.Util.Pretty qualified as P
execute ::
Codebase.Codebase IO Symbol Ann ->
Runtime Symbol ->
HQ.HashQualified Name ->
PP.ProjectPathNames ->
IO (Either Runtime.Error ())
execute codebase runtime mainName =
execute codebase runtime mainPath =
(`finally` Runtime.terminate runtime) . runExceptT $ do
root <- liftIO $ Codebase.getRootBranch codebase
let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
loadTypeOfTerm = Codebase.getTypeOfTerm codebase
(project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do
project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project))
branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch))
pure . Right $ (project, branch)
projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId
let loadTypeOfTerm = Codebase.getTypeOfTerm codebase
let mainType = Runtime.mainType runtime
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
mainName <- case Path.toName (mainPath ^. PP.path_) of
Just n -> pure (HQ.NameOnly n)
Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath)))
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType
case mt of
MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s))
MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()")

46
parser-typechecker/src/Unison/Codebase/Path.hs
View File

@ -5,7 +5,9 @@ module Unison.Codebase.Path
Path' (..),
Absolute (..),
pattern AbsolutePath',
absPath_,
Relative (..),
relPath_,
pattern RelativePath',
Resolve (..),
pattern Empty,
@ -30,6 +32,8 @@ module Unison.Codebase.Path
prefixNameIfRel,
unprefixName,
HQSplit,
HQSplitAbsolute,
AbsSplit,
Split,
Split',
HQSplit',
@ -58,6 +62,8 @@ module Unison.Codebase.Path
toName',
toText,
toText',
absToText,
relToText,
unsplit,
unsplit',
unsplitAbsolute,
@ -113,12 +119,19 @@ instance GHC.IsList Path where
toList (Path segs) = Foldable.toList segs
fromList = Path . Seq.fromList
-- | A namespace path that starts from the root.
-- | An absolute from the current project root
newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord)
absPath_ :: Lens' Absolute Path
absPath_ = lens unabsolute (\_ new -> Absolute new)
-- | A namespace path that doesn’t necessarily start from the root.
-- Typically refers to a path from the current namespace.
newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord)
relPath_ :: Lens' Relative Path
relPath_ = lens unrelative (\_ new -> Relative new)
-- | A namespace that may be either absolute or relative, This is the most general type that should be used.
newtype Path' = Path' {unPath' :: Either Absolute Relative}
deriving (Eq, Ord)
@ -148,14 +161,14 @@ absoluteToPath' = AbsolutePath'
instance Show Path' where
show = \case
AbsolutePath' abs -> show abs
RelativePath' rel -> show rel
AbsolutePath' abs -> Text.unpack $ absToText abs
RelativePath' rel -> Text.unpack $ relToText rel
instance Show Absolute where
show s = "." ++ show (unabsolute s)
show s = Text.unpack $ absToText s
instance Show Relative where
show = show . unrelative
show = Text.unpack . relToText
unsplit' :: Split' -> Path'
unsplit' = \case
@ -175,6 +188,8 @@ nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative)
nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
type AbsSplit = (Absolute, NameSegment)
type Split = (Path, NameSegment)
type HQSplit = (Path, HQ'.HQSegment)
@ -368,11 +383,29 @@ empty = Path mempty
instance Show Path where
show = Text.unpack . toText
instance From Path Text where
from = toText
instance From Absolute Text where
from = absToText
instance From Relative Text where
from = relToText
instance From Path' Text where
from = toText'
-- | Note: This treats the path as relative.
toText :: Path -> Text
toText =
maybe Text.empty Name.toText . toName
absToText :: Absolute -> Text
absToText abs = "." <> toText (unabsolute abs)
relToText :: Relative -> Text
relToText rel = toText (unrelative rel)
unsafeParseText :: Text -> Path
unsafeParseText = \case
"" -> empty
@ -509,6 +542,9 @@ instance Resolve Absolute Relative Absolute where
instance Resolve Absolute Relative Path' where
resolve l r = AbsolutePath' (resolve l r)
instance Resolve Absolute Path Absolute where
resolve (Absolute l) r = Absolute (resolve l r)
instance Resolve Path' Path' Path' where
resolve _ a@(AbsolutePath' {}) = a
resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)

136
parser-typechecker/src/Unison/Codebase/ProjectPath.hs Normal file
View 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

110
parser-typechecker/src/Unison/Codebase/RootBranchCache.hs
View File

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

8
parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs
View File

@ -10,6 +10,7 @@ where
import Data.Set qualified as Set
import Data.Text qualified as Text
import U.Codebase.HashTags (CausalHash (unCausalHash))
import U.Util.Base32Hex qualified as Base32Hex
import Unison.Hash qualified as Hash
import Unison.Prelude
@ -24,9 +25,9 @@ toString = Text.unpack . toText
toHash :: (Coercible Hash.Hash h) => ShortCausalHash -> Maybe h
toHash = fmap coerce . Hash.fromBase32HexText . toText
fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash
fromHash :: Int -> CausalHash -> ShortCausalHash
fromHash len =
ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce
ShortCausalHash . Text.take len . Hash.toBase32HexText . unCausalHash
-- | This allows a full hash to be preserved as a `ShortCausalHash`.
--
@ -47,3 +48,6 @@ fromText _ = Nothing
instance Show ShortCausalHash where
show (ShortCausalHash h) = '#' : Text.unpack h
instance From ShortCausalHash Text where
from = toText

44
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

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

133
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs
View File

@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6)
@ -30,27 +31,28 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2
import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath)
import Unison.Codebase.Type (LocalOrRemote (..))
import Unison.ConstructorType qualified as CT
import Unison.Debug qualified as Debug
import Unison.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
import Unison.Sqlite.Connection qualified as Sqlite.Connection
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty qualified as Pretty
import UnliftIO qualified
-- | Mapping from schema version to the migration required to get there.
-- E.g. The migration at index 2 must be run on a codebase at version 1.
migrations ::
(MVar Region.ConsoleRegion) ->
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
TVar (Map Hash Ops2.TermBufferEntry) ->
TVar (Map Hash Ops2.DeclBufferEntry) ->
CodebasePath ->
Map SchemaVersion (Sqlite.Transaction ())
migrations getDeclType termBuffer declBuffer rootCodebasePath =
Map SchemaVersion (Sqlite.Connection -> IO ())
migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
Map.fromList
[ (2, migrateSchema1To2 getDeclType termBuffer declBuffer),
[ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer),
-- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this
-- caused an issue:
--
@ -67,30 +69,34 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath =
-- This migration drops all the v1 hash objects to avoid this issue, since these hash objects
-- weren't being used for anything anyways.
sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)),
(4, migrateSchema3To4),
(4, runT (migrateSchema3To4 *> runIntegrityChecks regionVar)),
-- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
sqlMigration 5 Q.addTempEntityTables,
(6, migrateSchema5To6 rootCodebasePath),
(7, migrateSchema6To7),
(8, migrateSchema7To8),
(6, runT $ migrateSchema5To6 rootCodebasePath),
(7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)),
(8, runT migrateSchema7To8),
-- Recreates the name lookup tables because the primary key was missing the root hash id.
sqlMigration 9 Q.fixScopedNameLookupTables,
sqlMigration 10 Q.addProjectTables,
sqlMigration 11 Q.addMostRecentBranchTable,
(12, migrateSchema11To12),
(12, runT migrateSchema11To12),
sqlMigration 13 Q.addMostRecentNamespaceTable,
sqlMigration 14 Q.addSquashResultTable,
sqlMigration 15 Q.addSquashResultTableIfNotExists,
sqlMigration 16 Q.cdToProjectRoot
sqlMigration 16 Q.cdToProjectRoot,
(17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn)
]
where
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ())
runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()
runT t conn = Sqlite.runWriteTransaction conn (\run -> run t)
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ())
sqlMigration ver migration =
( ver,
do
Q.expectSchemaVersion (ver - 1)
migration
Q.setSchemaVersion ver
\conn -> Sqlite.runWriteTransaction conn \run -> run
do
Q.expectSchemaVersion (ver - 1)
migration
Q.setSchemaVersion ver
)
data CodebaseVersionStatus
@ -140,7 +146,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
Region.displayConsoleRegions do
(`UnliftIO.finally` finalizeRegion) do
let migs = migrations getDeclType termBuffer declBuffer root
let migs = migrations regionVar getDeclType termBuffer declBuffer root
-- The highest schema that this ucm knows how to migrate to.
let highestKnownSchemaVersion = fst . head $ Map.toDescList migs
currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion
@ -149,11 +155,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
when shouldPrompt do
putStrLn "Press <enter> to start the migration once all other ucm processes are shutdown..."
void $ liftIO getLine
ranMigrations <-
Sqlite.runWriteTransaction conn \run -> do
ranMigrations <- do
currentSchemaVersion <- Sqlite.runTransaction conn $ do
-- Get the schema version again now that we're in a transaction.
currentSchemaVersion <- run Q.schemaVersion
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
Q.schemaVersion
-- This is a bit of a hack, hopefully we can remove this when we have a more
-- reliable way to freeze old migration code in time.
-- The problem is that 'saveObject' has been changed to flush temp entity tables,
@ -163,48 +168,29 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
--
-- Hopefully we can remove this once we've got better methods of freezing migration
-- code in time.
when (currentSchemaVersion < 5) $ run Q.addTempEntityTables
when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
run migration
let ranMigrations = not (null migrationsToRun)
when ranMigrations do
region <-
UnliftIO.mask_ do
region <- Region.openConsoleRegion Region.Linear
putMVar regionVar region
pure region
result <- do
-- Ideally we'd check everything here, but certain codebases are known to have objects
-- with missing Hash Objects, we'll want to clean that up in a future migration.
-- integrityCheckAllHashObjects,
let checks =
Monoid.whenM
(currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked
[ integrityCheckAllBranches,
integrityCheckAllCausals
]
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
Region.setConsoleRegion
region
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
run check
case result of
NoIntegrityErrors -> pure ()
IntegrityErrorDetected errs -> do
let msg = prettyPrintIntegrityErrors errs
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
Region.setConsoleRegion region (Text.pack rendered)
run (abortMigration "Codebase integrity error detected.")
pure ranMigrations
when (currentSchemaVersion < 5) Q.addTempEntityTables
when (currentSchemaVersion < 6) Q.addNamespaceStatsTables
pure currentSchemaVersion
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
migration conn
let ranMigrations = not (null migrationsToRun)
pure ranMigrations
Debug.debugLogM Debug.Migration "Migrations complete"
when ranMigrations do
region <- readMVar regionVar
region <-
UnliftIO.mask_ do
region <- Region.openConsoleRegion Region.Linear
putMVar regionVar region
pure region
-- Vacuum once now that any migrations have taken place.
Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text)
case vacuumStrategy of
Vacuum -> void $ Sqlite.Connection.vacuum conn
Vacuum -> do
Debug.debugLogM Debug.Migration "About to VACUUM"
void $ Sqlite.Connection.vacuum conn
Debug.debugLogM Debug.Migration "Done VACUUM"
NoVacuum -> pure ()
Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text)
@ -224,3 +210,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion
Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL
putStrLn ("📋 I backed up your codebase to " ++ (root </> backupPath))
putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase."
runIntegrityChecks ::
(MVar Region.ConsoleRegion) ->
Sqlite.Transaction ()
runIntegrityChecks regionVar = do
region <- Sqlite.unsafeIO . UnliftIO.mask_ $ do
region <- Region.openConsoleRegion Region.Linear
putMVar regionVar region
pure region
result <- do
-- Ideally we'd check everything here, but certain codebases are known to have objects
-- with missing Hash Objects, we'll want to clean that up in a future migration.
-- integrityCheckAllHashObjects,
let checks =
[ integrityCheckAllBranches,
integrityCheckAllCausals
]
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
Sqlite.unsafeIO $
Region.setConsoleRegion
region
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
check
case result of
NoIntegrityErrors -> pure ()
IntegrityErrorDetected errs -> do
let msg = prettyPrintIntegrityErrors errs
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
Sqlite.unsafeIO $ Region.setConsoleRegion region (Text.pack rendered)
(abortMigration "Codebase integrity error detected.")

225
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs Normal file
View File

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

22
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
@ -103,7 +104,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones."
log "Updating Namespace Root..."
rootCausalHashId <- Q.expectNamespaceRoot
rootCausalHashId <- expectNamespaceRoot
numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches]
v2EmptyBranchHashInfo <- saveV2EmptyBranch
watches <-
@ -115,7 +116,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
`execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo
let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId
log "Updating Namespace Root..."
Q.setNamespaceRoot newRootCausalHashId
setNamespaceRoot newRootCausalHashId
log "Rewriting old object IDs..."
ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do
Q.recordObjectRehash oldObjId newObjId
@ -149,6 +150,23 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
allDone = lift $ log $ "\nFinished migrating, initiating cleanup."
in Sync.Progress {need, done, error = errorHandler, allDone}
expectNamespaceRoot :: Sqlite.Transaction CausalHashId
expectNamespaceRoot =
Sqlite.queryOneCol loadNamespaceRootSql
loadNamespaceRootSql :: Sqlite.Sql
loadNamespaceRootSql =
[Sqlite.sql|
SELECT causal_id
FROM namespace_root
|]
setNamespaceRoot :: CausalHashId -> Sqlite.Transaction ()
setNamespaceRoot id =
Sqlite.queryOneCol [Sqlite.sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case
False -> Sqlite.execute [Sqlite.sql| INSERT INTO namespace_root VALUES (:id) |]
True -> Sqlite.execute [Sqlite.sql| UPDATE namespace_root SET causal_id = :id |]
log :: String -> Sqlite.Transaction ()
log =
Sqlite.unsafeIO . putStrLn

13
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs
View File

@ -81,7 +81,7 @@ numMigrated =
migrateSchema3To4 :: Sqlite.Transaction ()
migrateSchema3To4 = do
Q.expectSchemaVersion 3
rootCausalHashId <- Q.expectNamespaceRoot
rootCausalHashId <- expectNamespaceRoot
totalCausals <- causalCount
migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId]
let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState
@ -98,6 +98,17 @@ migrateSchema3To4 = do
SELECT count(*) FROM causal;
|]
expectNamespaceRoot :: Sqlite.Transaction DB.CausalHashId
expectNamespaceRoot =
Sqlite.queryOneCol loadNamespaceRootSql
loadNamespaceRootSql :: Sqlite.Sql
loadNamespaceRootSql =
[Sqlite.sql|
SELECT causal_id
FROM namespace_root
|]
migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId
migrationProgress totalCausals =
Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone}

16
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs
View File

@ -1,11 +1,14 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) where
import Data.Bitraversable
import Data.Text qualified as Text
import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import System.FilePath ((</>))
import U.Codebase.HashTags (CausalHash (CausalHash))
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Operations qualified as Ops
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Codebase (CodebasePath)
import Unison.Hash qualified as Hash
@ -30,12 +33,21 @@ migrateCurrentReflog codebasePath = do
-- so we check first to avoid triggering a bad foreign key constraint.
haveFrom <- isJust <$> Q.loadCausalByCausalHash (Reflog.fromRootCausalHash oldEntry)
haveTo <- isJust <$> Q.loadCausalByCausalHash (Reflog.toRootCausalHash oldEntry)
when (haveFrom && haveTo) $ Ops.appendReflog oldEntry
when (haveFrom && haveTo) $ appendReflog oldEntry
Sqlite.unsafeIO . putStrLn $ "I migrated old reflog entries from " <> reflogPath <> " into the codebase; you may delete that file now if you like."
where
reflogPath :: FilePath
reflogPath = codebasePath </> "reflog"
appendReflog :: Reflog.Entry CausalHash Text -> Sqlite.Transaction ()
appendReflog entry = do
dbEntry <- (bitraverse Q.saveCausalHash pure) entry
Sqlite.execute
[Sqlite.sql|
INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason)
VALUES (@dbEntry, @, @, @)
|]
oldReflogEntries :: CodebasePath -> UTCTime -> IO [Reflog.Entry CausalHash Text]
oldReflogEntries reflogPath now =
( do

94
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
-- monad.
@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.UUID.V4 qualified as UUID
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
import U.Codebase.Branch.Diff qualified as BranchDiff
@ -30,11 +33,14 @@ import U.Codebase.Sqlite.NamedRef qualified as S
import U.Codebase.Sqlite.ObjectType qualified as OT
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
import U.Codebase.Sqlite.Operations qualified as Ops
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.Project qualified as Project
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import Unison.Builtin qualified as Builtins
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
@ -43,7 +49,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType qualified as CT
import Unison.Core.Project (ProjectBranchName, ProjectName)
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as Decl
import Unison.Hash (Hash)
@ -74,6 +80,35 @@ import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as UF
import UnliftIO.STM
createSchema :: Transaction ()
createSchema = do
Q.runCreateSql
Q.addTempEntityTables
Q.addNamespaceStatsTables
Q.addReflogTable
Q.fixScopedNameLookupTables
Q.addProjectTables
Q.addMostRecentBranchTable
Q.addNameLookupMountTables
Q.addMostRecentNamespaceTable
Sqlite.execute insertSchemaVersionSql
Q.addSquashResultTable
Q.addCurrentProjectPathTable
Q.addProjectBranchReflogTable
Q.addProjectBranchCausalHashIdColumn
(_, emptyCausalHashId) <- emptyCausalHash
(_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
Q.setCurrentProjectPath projectId branchId []
where
scratchProjectName = UnsafeProjectName "scratch"
scratchBranchName = UnsafeProjectBranchName "main"
currentSchemaVersion = Q.currentSchemaVersion
insertSchemaVersionSql =
[Sqlite.sql|
INSERT INTO schema_version (version)
VALUES (:currentSchemaVersion)
|]
------------------------------------------------------------------------------------------------------------------------
-- Buffer entry
@ -382,25 +417,6 @@ tryFlushDeclBuffer termBuffer declBuffer =
h
in loop
uncachedLoadRootBranch ::
BranchCache Sqlite.Transaction ->
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
Transaction (Branch Transaction)
uncachedLoadRootBranch branchCache getDeclType = do
causal2 <- Ops.expectRootCausal
Cv.causalbranch2to1 branchCache getDeclType causal2
-- | Get whether the root branch exists.
getRootBranchExists :: Transaction Bool
getRootBranchExists =
isJust <$> Ops.loadRootCausalHash
putRootBranch :: Branch Transaction -> Transaction ()
putRootBranch branch1 = do
-- todo: check to see if root namespace hash has been externally modified
-- and do something (merge?) it if necessary. But for now, we just overwrite it.
void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1))
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
-- to one that returns Maybe.
getBranchForHash ::
@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do
conn <- Sqlite.unsafeGetConnection
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
insertProjectAndBranch projectId projectName branchId branchName = do
Q.insertProject projectId projectName
-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project.
insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch)
insertProjectAndBranch projectName branchName chId = do
projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do
projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom)
Q.insertProject projectId projectName
pure projectId
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
let projectBranch =
ProjectBranch
{ projectId,
branchId,
name = branchName,
parentBranchId = Nothing
}
Q.insertProjectBranch
ProjectBranch
{ projectId,
branchId,
name = branchName,
parentBranchId = Nothing
}
"Project Created"
chId
projectBranch
Q.setMostRecentBranch projectId branchId
pure (Project {name = projectName, projectId}, ProjectBranch {projectId, name = branchName, branchId, parentBranchId = Nothing})
-- | Often we need to assign something to an empty causal, this ensures the empty causal
-- exists in the codebase and returns its hash.
emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId)
emptyCausalHash = do
let emptyBranch = Branch.empty
putBranch emptyBranch
let causalHash = Branch.headHash emptyBranch
causalHashId <- Q.expectCausalHashIdByCausalHash causalHash
pure (causalHash, causalHashId)

7
parser-typechecker/src/Unison/Codebase/Type.hs
View File

@ -55,13 +55,6 @@ data Codebase m v a = Codebase
putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]),
-- | Get the root branch.
getRootBranch :: m (Branch m),
-- | Like 'putBranch', but also adjusts the root branch pointer afterwards.
putRootBranch ::
Text -> -- Reason for the change, will be recorded in the reflog
Branch m ->
m (),
getBranchForHash :: CausalHash -> m (Maybe (Branch m)),
-- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't
-- already exist.

5
parser-typechecker/src/Unison/Codebase/UniqueTypeGuidLookup.hs
View File

@ -10,6 +10,7 @@ import U.Codebase.Branch qualified as Codebase.Branch
import U.Codebase.Decl qualified as Codebase.Decl
import U.Codebase.Reference qualified as Codebase.Reference
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
@ -21,8 +22,8 @@ import Witherable (witherM)
-- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed
-- by a cache.
loadUniqueTypeGuid ::
([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
[NameSegment] ->
(ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
ProjectPath ->
NameSegment ->
Sqlite.Transaction (Maybe Text)
loadUniqueTypeGuid loadNamespaceAtPath path name =

158
parser-typechecker/src/Unison/Project/Util.hs
View File

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

4
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -60,8 +60,8 @@ library
Unison.Codebase.Patch
Unison.Codebase.Path
Unison.Codebase.Path.Parse
Unison.Codebase.ProjectPath
Unison.Codebase.PushBehavior
Unison.Codebase.RootBranchCache
Unison.Codebase.Runtime
Unison.Codebase.Serialization
Unison.Codebase.ShortCausalHash
@ -72,6 +72,7 @@ library
Unison.Codebase.SqliteCodebase.Migrations
Unison.Codebase.SqliteCodebase.Migrations.Helpers
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4
@ -131,7 +132,6 @@ library
Unison.PrettyPrintEnvDecl.Names
Unison.PrettyPrintEnvDecl.Sqlite
Unison.PrintError
Unison.Project.Util
Unison.Result
Unison.Runtime.ANF
Unison.Runtime.ANF.Rehash

17
unison-cli-integration/integration-tests/IntegrationTests/transcript.md
View File

@ -1,18 +1,13 @@
# Integration test: transcript
```ucm:hide
.> builtins.mergeio
.> load ./unison-src/transcripts-using-base/base.u
```
```ucm:hide
.> builtins.mergeio
.> load ./unison-src/transcripts-using-base/base.u
.> add
scratch/main> builtins.mergeio lib.builtins
scratch/main> load ./unison-src/transcripts-using-base/base.u
scratch/main> add
```
```unison
use .builtin
use lib.builtins
unique type MyBool = MyTrue | MyFalse
@ -39,6 +34,6 @@ main = do
```
```ucm
.> add
.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
scratch/main> add
scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
```

6
unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md
View File

@ -1,7 +1,7 @@
# Integration test: transcript
```unison
use .builtin
use lib.builtins
unique type MyBool = MyTrue | MyFalse
@ -44,7 +44,7 @@ main = do
```
```ucm
.> add
scratch/main> add
⍟ I've added these definitions:
@ -53,6 +53,6 @@ main = do
main : '{IO, Exception} ()
resume : Request {g, Break} x -> x
.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
```

40
unison-cli/src/ArgParse.hs
View File

@ -52,14 +52,19 @@ import Options.Applicative.Help (bold, (<+>))
import Options.Applicative.Help.Pretty qualified as P
import Stats
import System.Environment (lookupEnv)
import Text.Megaparsec qualified as Megaparsec
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathNames)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.CommandLine.Types (ShouldWatchFiles (..))
import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
import Unison.HashQualified (HashQualified)
import Unison.LSP (LspFormattingConfig (..))
import Unison.Name (Name)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PT
import Unison.Project qualified as Project
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
import Unison.Server.CodebaseServer qualified as Server
import Unison.Syntax.HashQualified qualified as HQ
@ -68,7 +73,7 @@ import Unison.Util.Pretty (Width (..))
-- | Valid ways to provide source code to the run command
data RunSource
= RunFromPipe (HashQualified Name)
| RunFromSymbol (HashQualified Name)
| RunFromSymbol ProjectPathNames
| RunFromFile FilePath (HashQualified Name)
| RunCompiled FilePath
deriving (Show, Eq)
@ -102,8 +107,8 @@ data Command
= Launch
IsHeadless
CodebaseServerOpts
-- Starting path
(Maybe Path.Absolute)
-- Starting project
(Maybe (ProjectAndBranch ProjectName ProjectBranchName))
ShouldWatchFiles
| PrintVersion
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
@ -357,9 +362,9 @@ launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command
launchParser envOpts isHeadless = do
-- ApplicativeDo
codebaseServerOpts <- codebaseServerOptsParser envOpts
startingPath <- startingPathOption
startingProject <- startingProjectOption
shouldWatchFiles <- noFileWatchFlag
pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles)
pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles)
initParser :: Parser Command
initParser = pure Init
@ -374,9 +379,13 @@ runHQParser :: Parser (HashQualified Name)
runHQParser =
argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL")
runProjectPathParser :: Parser PP.ProjectPathNames
runProjectPathParser =
argument (maybeReader (eitherToMaybe . PP.parseProjectPath . Text.pack)) (metavar "@myproject/mybranch:.path.in.project")
runSymbolParser :: Parser Command
runSymbolParser =
Run . RunFromSymbol <$> runHQParser <*> runArgumentParser
Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser
runFileParser :: Parser Command
runFileParser =
@ -422,15 +431,15 @@ saveCodebaseToFlag = do
_ -> DontSaveCodebase
)
startingPathOption :: Parser (Maybe Path.Absolute)
startingPathOption =
startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
startingProjectOption =
let meta =
metavar ".path.in.codebase"
<> long "path"
metavar "project/branch"
<> long "project"
<> short 'p'
<> help "Launch the UCM session at the provided path location."
<> help "Launch the UCM session at the provided project and branch."
<> noGlobal
in optional $ option readAbsolutePath meta
in optional (option readProjectAndBranchNames meta)
noFileWatchFlag :: Parser ShouldWatchFiles
noFileWatchFlag =
@ -469,6 +478,13 @@ readPath' = do
Left err -> OptParse.readerError (Text.unpack err)
Right path' -> pure path'
readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName)
readProjectAndBranchNames = do
str <- OptParse.str
case Megaparsec.parse Project.fullyQualifiedProjectAndBranchNamesParser "arg" str of
Left errBundle -> OptParse.readerError $ Megaparsec.errorBundlePretty errBundle
Right projectAndBranch -> pure projectAndBranch
fileArgument :: String -> Parser FilePath
fileArgument varName =
strArgument

87
unison-cli/src/Unison/Cli/Monad.hs
View File

@ -14,6 +14,7 @@ module Unison.Cli.Monad
-- * Immutable state
LoopState (..),
loopState0,
getProjectPathIds,
-- * Lifting IO actions
ioE,
@ -33,6 +34,7 @@ module Unison.Cli.Monad
-- * Changing the current directory
cd,
popd,
switchProject,
-- * Communicating output to the user
respond,
@ -46,38 +48,42 @@ module Unison.Cli.Monad
runTransaction,
runTransactionWithRollback,
-- * Internal
setMostRecentProjectPath,
-- * Misc types
LoadSourceResult (..),
)
where
import Control.Exception (throwIO)
import Control.Lens (lens, (.=))
import Control.Lens
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.State.Strict (MonadState)
import Control.Monad.State.Strict qualified as State
import Data.Configurator.Types qualified as Configurator
import Data.List.NonEmpty qualified as List (NonEmpty)
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.List.NonEmpty qualified as NonEmpty
import Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
import Data.Time.Clock.System (getSystemTime, systemToTAITime)
import Data.Time.Clock.TAI (diffAbsoluteTime)
import Data.Unique (Unique, newUnique)
import GHC.OverloadedLabels (IsLabel (..))
import System.CPUTime (getCPUTime)
import Text.Printf (printf)
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Queries qualified as Queries
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager (CredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Editor.Input (Input)
import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Core.Project (ProjectAndBranch (..))
import Unison.Debug qualified as Debug
import Unison.Parser.Ann (Ann)
import Unison.Prelude
@ -88,7 +94,8 @@ import Unison.Syntax.Parser qualified as Parser
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.UnisonFile qualified as UF
import UnliftIO.STM
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO
import Unsafe.Coerce (unsafeCoerce)
-- | The main command-line app monad.
@ -170,7 +177,10 @@ data Env = Env
sandboxedRuntime :: Runtime Symbol,
nativeRuntime :: Runtime Symbol,
serverBaseUrl :: Maybe Server.BaseUrl,
ucmVersion :: UCMVersion
ucmVersion :: UCMVersion,
-- | Whether we're running in a transcript test or not.
-- Avoid using this except when absolutely necessary.
isTranscriptTest :: Bool
}
deriving stock (Generic)
@ -178,10 +188,8 @@ data Env = Env
--
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
data LoopState = LoopState
{ root :: TMVar (Branch IO),
lastSavedRootHash :: CausalHash,
-- the current position in the namespace
currentPathStack :: List.NonEmpty Path.Absolute,
{ -- the current position in the codebase, with the head being the most recent lcoation.
projectPathStack :: List.NonEmpty PP.ProjectPathIds,
-- TBD
-- , _activeEdits :: Set Branch.EditGuid
@ -206,26 +214,11 @@ data LoopState = LoopState
}
deriving stock (Generic)
instance
{-# OVERLAPS #-}
(Functor f) =>
IsLabel "currentPath" ((Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState))
where
fromLabel :: (Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState)
fromLabel =
lens
(\LoopState {currentPathStack} -> List.NonEmpty.head currentPathStack)
( \loopState@LoopState {currentPathStack = _ List.NonEmpty.:| paths} path ->
loopState {currentPathStack = path List.NonEmpty.:| paths}
)
-- | Create an initial loop state given a root branch and the current path.
loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
loopState0 lastSavedRootHash b p = do
loopState0 :: PP.ProjectPathIds -> LoopState
loopState0 p = do
LoopState
{ root = b,
lastSavedRootHash = lastSavedRootHash,
currentPathStack = pure p,
{ projectPathStack = pure p,
latestFile = Nothing,
latestTypecheckedFile = Nothing,
lastInput = Nothing,
@ -387,11 +380,29 @@ time label action =
ms = ns / 1_000_000
s = ns / 1_000_000_000
getProjectPathIds :: Cli PP.ProjectPathIds
getProjectPathIds = do
NonEmpty.head <$> use #projectPathStack
cd :: Path.Absolute -> Cli ()
cd path = do
setMostRecentNamespace path
State.modify' \state ->
state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)}
pp <- getProjectPathIds
let newPP = pp & PP.absPath_ .~ path
setMostRecentProjectPath newPP
#projectPathStack %= NonEmpty.cons newPP
switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
switchProject (ProjectAndBranch projectId branchId) = do
Env {codebase} <- ask
let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty
#projectPathStack %= NonEmpty.cons newPP
runTransaction $ do Q.setMostRecentBranch projectId branchId
setMostRecentProjectPath newPP
-- Prime the cache with the new project branch root so it's ready when a command needs it.
void . liftIO . UnliftIO.forkIO $ do
b <- Codebase.expectProjectBranchRoot codebase projectId branchId
-- Force the branch in the background thread to avoid delays later.
void $ UnliftIO.evaluate b
-- | Pop the latest path off the stack, if it's not the only path in the stack.
--
@ -399,16 +410,16 @@ cd path = do
popd :: Cli Bool
popd = do
state <- State.get
case List.NonEmpty.uncons (currentPathStack state) of
case List.NonEmpty.uncons (projectPathStack state) of
(_, Nothing) -> pure False
(_, Just paths) -> do
setMostRecentNamespace (List.NonEmpty.head paths)
State.put state {currentPathStack = paths}
setMostRecentProjectPath (List.NonEmpty.head paths)
State.put state {projectPathStack = paths}
pure True
setMostRecentNamespace :: Path.Absolute -> Cli ()
setMostRecentNamespace =
runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute
setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
setMostRecentProjectPath loc =
runTransaction $ Codebase.setCurrentProjectPath loc
respond :: Output -> Cli ()
respond output = do

374
unison-cli/src/Unison/Cli/MonadUtils.hs
View File

@ -6,10 +6,18 @@ module Unison.Cli.MonadUtils
-- * Paths
getCurrentPath,
getCurrentProjectName,
getCurrentProjectBranchName,
getCurrentProjectPath,
resolvePath,
resolvePath',
resolvePath'ToAbsolute,
resolveSplit',
-- * Project and branch resolution
getCurrentProjectAndBranch,
getCurrentProjectBranch,
-- * Branches
-- ** Resolving branch identifiers
@ -20,18 +28,15 @@ module Unison.Cli.MonadUtils
resolveShortCausalHash,
-- ** Getting/setting branches
getRootBranch,
setRootBranch,
modifyRootBranch,
getRootBranch0,
getCurrentProjectRoot,
getCurrentProjectRoot0,
getCurrentBranch,
getCurrentBranch0,
getBranchAt,
getBranch0At,
getLastSavedRootHash,
setLastSavedRootHash,
getMaybeBranchAt,
getMaybeBranch0At,
getProjectBranchRoot,
getBranchFromProjectPath,
getBranch0FromProjectPath,
getMaybeBranchFromProjectPath,
getMaybeBranch0FromProjectPath,
expectBranchAtPath,
expectBranchAtPath',
expectBranch0AtPath,
@ -43,13 +48,10 @@ module Unison.Cli.MonadUtils
stepAt',
stepAt,
stepAtM,
stepAtNoSync',
stepAtNoSync,
stepManyAt,
stepManyAtMNoSync,
stepManyAtNoSync,
syncRoot,
updateRoot,
stepManyAtM,
updateProjectBranchRoot,
updateProjectBranchRoot_,
updateAtM,
updateAt,
updateAndStepAt,
@ -91,6 +93,9 @@ import U.Codebase.Branch qualified as V2 (Branch)
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Sqlite.Project (Project)
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Codebase qualified as Codebase
@ -103,6 +108,8 @@ import Unison.Codebase.Patch (Patch (..))
import Unison.Codebase.Patch qualified as Patch
import Unison.Codebase.Path (Path, Path' (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.HashQualified qualified as HQ
@ -112,6 +119,7 @@ import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names)
import Unison.Parser.Ann (Ann (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Reference (TypeReference)
import Unison.Referent (Referent)
import Unison.Sqlite qualified as Sqlite
@ -123,7 +131,6 @@ import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UFN
import Unison.Util.Set qualified as Set
import Unison.Var qualified as Var
import UnliftIO.STM
------------------------------------------------------------------------------------------------------------------------
-- .unisonConfig things
@ -137,25 +144,50 @@ getConfig key = do
------------------------------------------------------------------------------------------------------------------------
-- Getting paths, path resolution, etc.
-- | Get the current path.
getCurrentProjectPath :: Cli PP.ProjectPath
getCurrentProjectPath = do
ppIds <- Cli.getProjectPathIds
Cli.runTransaction $ Codebase.resolveProjectPathIds ppIds
getCurrentProjectAndBranch :: Cli (ProjectAndBranch Project ProjectBranch)
getCurrentProjectAndBranch = do
PP.toProjectAndBranch <$> getCurrentProjectPath
getCurrentProjectBranch :: Cli ProjectBranch
getCurrentProjectBranch = do
view #branch <$> getCurrentProjectPath
-- | Get the current path relative to the current project.
getCurrentPath :: Cli Path.Absolute
getCurrentPath = do
use #currentPath
view PP.absPath_ <$> getCurrentProjectPath
getCurrentProjectName :: Cli ProjectName
getCurrentProjectName = do
view (#project . #name) <$> getCurrentProjectPath
getCurrentProjectBranchName :: Cli ProjectBranchName
getCurrentProjectBranchName = do
view (#branch . #name) <$> getCurrentProjectPath
-- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path.
resolvePath :: Path -> Cli Path.Absolute
resolvePath :: Path -> Cli PP.ProjectPath
resolvePath path = do
currentPath <- getCurrentPath
pure (Path.resolve currentPath (Path.Relative path))
pp <- getCurrentProjectPath
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path
-- | Resolve a @Path'@ to a @Path.Absolute@, per the current path.
resolvePath' :: Path' -> Cli Path.Absolute
resolvePath' path = do
currentPath <- getCurrentPath
pure (Path.resolve currentPath path)
resolvePath' :: Path' -> Cli PP.ProjectPath
resolvePath' path' = do
pp <- getCurrentProjectPath
pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path'
resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute
resolvePath'ToAbsolute path' = do
view PP.absPath_ <$> resolvePath' path'
-- | Resolve a path split, per the current path.
resolveSplit' :: (Path', a) -> Cli (Path.Absolute, a)
resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a)
resolveSplit' =
traverseOf _1 resolvePath'
@ -166,23 +198,27 @@ resolveSplit' =
-- branches by path are OK - the empty branch will be returned).
resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO)
resolveAbsBranchId = \case
Left hash -> resolveShortCausalHash hash
Right path -> getBranchAt path
Input.BranchAtSCH hash -> resolveShortCausalHash hash
Input.BranchAtPath absPath -> do
pp <- resolvePath' (Path' (Left absPath))
getBranchFromProjectPath pp
Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp
-- | V2 version of 'resolveAbsBranchId2'.
resolveAbsBranchIdV2 ::
(forall void. Output.Output -> Sqlite.Transaction void) ->
ProjectAndBranch Project ProjectBranch ->
Input.AbsBranchId ->
Sqlite.Transaction (V2.Branch Sqlite.Transaction)
resolveAbsBranchIdV2 rollback = \case
Left shortHash -> do
resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case
Input.BranchAtSCH shortHash -> do
hash <- resolveShortCausalHashToCausalHash rollback shortHash
succeed (Codebase.expectCausalBranchByCausalHash hash)
Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path))
where
succeed getCausal = do
causal <- getCausal
V2Causal.value causal
causal <- (Codebase.expectCausalBranchByCausalHash hash)
V2Causal.value causal
Input.BranchAtPath absPath -> do
let pp = PP.ProjectPath proj branch absPath
Codebase.getShallowBranchAtProjectPath pp
Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
-- branches by path are OK - the empty branch will be returned).
@ -194,7 +230,7 @@ resolveBranchId branchId = do
-- | Resolve a @BranchId@ to an @AbsBranchId@.
resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId
resolveBranchIdToAbsBranchId =
traverseOf _Right resolvePath'
traverse (fmap (view PP.absPath_) . resolvePath')
-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
@ -222,77 +258,54 @@ resolveShortCausalHashToCausalHash rollback shortHash = do
-- Getting/Setting branches
-- | Get the root branch.
getRootBranch :: Cli (Branch IO)
getRootBranch = do
use #root >>= atomically . readTMVar
getCurrentProjectRoot :: Cli (Branch IO)
getCurrentProjectRoot = do
Cli.Env {codebase} <- ask
ProjectAndBranch proj branch <- getCurrentProjectAndBranch
liftIO $ Codebase.expectProjectBranchRoot codebase proj.projectId branch.branchId
-- | Get the root branch0.
getRootBranch0 :: Cli (Branch0 IO)
getRootBranch0 =
Branch.head <$> getRootBranch
-- | Set a new root branch.
--
-- Note: This does _not_ update the codebase, the caller is responsible for that.
setRootBranch :: Branch IO -> Cli ()
setRootBranch b = do
void $ modifyRootBranch (const b)
-- | Modify the root branch.
--
-- Note: This does _not_ update the codebase, the caller is responsible for that.
modifyRootBranch :: (Branch IO -> Branch IO) -> Cli (Branch IO)
modifyRootBranch f = do
rootVar <- use #root
atomically do
root <- takeTMVar rootVar
let !newRoot = f root
putTMVar rootVar newRoot
pure newRoot
getCurrentProjectRoot0 :: Cli (Branch0 IO)
getCurrentProjectRoot0 =
Branch.head <$> getCurrentProjectRoot
-- | Get the current branch.
getCurrentBranch :: Cli (Branch IO)
getCurrentBranch = do
path <- getCurrentPath
Cli.Env {codebase} <- ask
liftIO $ Codebase.getBranchAtPath codebase path
pp <- getCurrentProjectPath
fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp)
-- | Get the current branch0.
getCurrentBranch0 :: Cli (Branch0 IO)
getCurrentBranch0 = do
Branch.head <$> getCurrentBranch
-- | Get the last saved root hash.
getLastSavedRootHash :: Cli CausalHash
getLastSavedRootHash = do
use #lastSavedRootHash
-- | Set a new root branch.
-- Note: This does _not_ update the codebase, the caller is responsible for that.
setLastSavedRootHash :: CausalHash -> Cli ()
setLastSavedRootHash ch = do
#lastSavedRootHash .= ch
-- | Get the branch at an absolute path.
getBranchAt :: Path.Absolute -> Cli (Branch IO)
getBranchAt path =
getMaybeBranchAt path <&> fromMaybe Branch.empty
-- | Get the branch at an absolute path from the project root.
getBranchFromProjectPath :: PP.ProjectPath -> Cli (Branch IO)
getBranchFromProjectPath pp =
getMaybeBranchFromProjectPath pp <&> fromMaybe Branch.empty
-- | Get the branch0 at an absolute path.
getBranch0At :: Path.Absolute -> Cli (Branch0 IO)
getBranch0At path =
Branch.head <$> getBranchAt path
getBranch0FromProjectPath :: PP.ProjectPath -> Cli (Branch0 IO)
getBranch0FromProjectPath pp =
Branch.head <$> getBranchFromProjectPath pp
getProjectBranchRoot :: ProjectBranch -> Cli (Branch IO)
getProjectBranchRoot projectBranch = do
Cli.Env {codebase} <- ask
liftIO $ Codebase.expectProjectBranchRoot codebase projectBranch.projectId projectBranch.branchId
-- | Get the maybe-branch at an absolute path.
getMaybeBranchAt :: Path.Absolute -> Cli (Maybe (Branch IO))
getMaybeBranchAt path = do
rootBranch <- getRootBranch
pure (Branch.getAt (Path.unabsolute path) rootBranch)
getMaybeBranchFromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch IO))
getMaybeBranchFromProjectPath pp = do
Cli.Env {codebase} <- ask
liftIO $ Codebase.getBranchAtProjectPath codebase pp
-- | Get the maybe-branch0 at an absolute path.
getMaybeBranch0At :: Path.Absolute -> Cli (Maybe (Branch0 IO))
getMaybeBranch0At path =
fmap Branch.head <$> getMaybeBranchAt path
getMaybeBranch0FromProjectPath :: PP.ProjectPath -> Cli (Maybe (Branch0 IO))
getMaybeBranch0FromProjectPath pp =
fmap Branch.head <$> getMaybeBranchFromProjectPath pp
-- | Get the branch at a relative path, or return early if there's no such branch.
expectBranchAtPath :: Path -> Cli (Branch IO)
@ -303,7 +316,7 @@ expectBranchAtPath =
expectBranchAtPath' :: Path' -> Cli (Branch IO)
expectBranchAtPath' path0 = do
path <- resolvePath' path0
getMaybeBranchAt path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0))
getMaybeBranchFromProjectPath path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0))
-- | Get the branch0 at an absolute or relative path, or return early if there's no such branch.
expectBranch0AtPath' :: Path' -> Cli (Branch0 IO)
@ -329,167 +342,138 @@ assertNoBranchAtPath' path' = do
-- current terms/types etc).
branchExistsAtPath' :: Path' -> Cli Bool
branchExistsAtPath' path' = do
absPath <- resolvePath' path'
pp <- resolvePath' path'
Cli.runTransaction do
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute absPath)
branch <- V2Causal.value causal
branch <- Codebase.getShallowBranchAtProjectPath pp
isEmpty <- V2Branch.isEmpty branch
pure (not isEmpty)
------------------------------------------------------------------------------------------------------------------------
-- Updating branches
makeActionsUnabsolute :: (Functor f) => f (Path.Absolute, x) -> f (Path, x)
makeActionsUnabsolute = fmap (first Path.unabsolute)
stepAt ::
Text ->
(Path, Branch0 IO -> Branch0 IO) ->
(ProjectPath, Branch0 IO -> Branch0 IO) ->
Cli ()
stepAt cause = stepManyAt @[] cause . pure
stepAt cause (pp, action) = stepManyAt pp.branch cause [(pp.absPath, action)]
stepAt' ::
Text ->
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
(ProjectPath, Branch0 IO -> Cli (Branch0 IO)) ->
Cli Bool
stepAt' cause = stepManyAt' @[] cause . pure
stepAtNoSync' ::
(Path, Branch0 IO -> Cli (Branch0 IO)) ->
Cli Bool
stepAtNoSync' = stepManyAtNoSync' @[] . pure
stepAtNoSync ::
(Path, Branch0 IO -> Branch0 IO) ->
Cli ()
stepAtNoSync = stepManyAtNoSync @[] . pure
stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)]
stepAtM ::
Text ->
(Path, Branch0 IO -> IO (Branch0 IO)) ->
(ProjectPath, Branch0 IO -> IO (Branch0 IO)) ->
Cli ()
stepAtM cause = stepManyAtM @[] cause . pure
stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)]
stepManyAt ::
(Foldable f) =>
ProjectBranch ->
Text ->
f (Path, Branch0 IO -> Branch0 IO) ->
[(Path.Absolute, Branch0 IO -> Branch0 IO)] ->
Cli ()
stepManyAt reason actions = do
stepManyAtNoSync actions
syncRoot reason
stepManyAt pb reason actions = do
updateProjectBranchRoot_ pb reason $ Branch.stepManyAt (makeActionsUnabsolute actions)
stepManyAt' ::
(Foldable f) =>
ProjectBranch ->
Text ->
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
[(Path.Absolute, Branch0 IO -> Cli (Branch0 IO))] ->
Cli Bool
stepManyAt' reason actions = do
res <- stepManyAtNoSync' actions
syncRoot reason
pure res
stepManyAtNoSync' ::
(Foldable f) =>
f (Path, Branch0 IO -> Cli (Branch0 IO)) ->
Cli Bool
stepManyAtNoSync' actions = do
origRoot <- getRootBranch
newRoot <- Branch.stepManyAtM actions origRoot
setRootBranch newRoot
pure (origRoot /= newRoot)
stepManyAt' pb reason actions = do
origRoot <- getProjectBranchRoot pb
newRoot <- Branch.stepManyAtM (makeActionsUnabsolute actions) origRoot
didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot))
pure didChange
-- Like stepManyAt, but doesn't update the last saved root
stepManyAtNoSync ::
(Foldable f) =>
f (Path, Branch0 IO -> Branch0 IO) ->
Cli ()
stepManyAtNoSync actions =
void . modifyRootBranch $ Branch.stepManyAt actions
stepManyAtM ::
(Foldable f) =>
ProjectBranch ->
Text ->
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
[(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] ->
Cli ()
stepManyAtM reason actions = do
stepManyAtMNoSync actions
syncRoot reason
stepManyAtMNoSync ::
(Foldable f) =>
f (Path, Branch0 IO -> IO (Branch0 IO)) ->
Cli ()
stepManyAtMNoSync actions = do
oldRoot <- getRootBranch
newRoot <- liftIO (Branch.stepManyAtM actions oldRoot)
setRootBranch newRoot
-- | Sync the in-memory root branch.
syncRoot :: Text -> Cli ()
syncRoot description = do
rootBranch <- getRootBranch
updateRoot rootBranch description
stepManyAtM pb reason actions = do
updateProjectBranchRoot pb reason \oldRoot -> do
newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot)
pure (newRoot, ())
-- | Update a branch at the given path, returning `True` if
-- an update occurred and false otherwise
updateAtM ::
Text ->
Path.Absolute ->
ProjectPath ->
(Branch IO -> Cli (Branch IO)) ->
Cli Bool
updateAtM reason (Path.Absolute p) f = do
b <- getRootBranch
b' <- Branch.modifyAtM p f b
updateRoot b' reason
pure $ b /= b'
updateAtM reason pp f = do
oldRootBranch <- getProjectBranchRoot (pp ^. #branch)
newRootBranch <- Branch.modifyAtM (pp ^. PP.path_) f oldRootBranch
updateProjectBranchRoot_ (pp ^. #branch) reason (const newRootBranch)
pure $ oldRootBranch /= newRootBranch
-- | Update a branch at the given path, returning `True` if
-- an update occurred and false otherwise
updateAt ::
Text ->
Path.Absolute ->
ProjectPath ->
(Branch IO -> Branch IO) ->
Cli Bool
updateAt reason p f = do
updateAtM reason p (pure . f)
updateAt reason pp f = do
updateAtM reason pp (pure . f)
updateAndStepAt ::
(Foldable f, Foldable g) =>
(Foldable f, Foldable g, Functor g) =>
Text ->
ProjectBranch ->
f (Path.Absolute, Branch IO -> Branch IO) ->
g (Path, Branch0 IO -> Branch0 IO) ->
g (Path.Absolute, Branch0 IO -> Branch0 IO) ->
Cli ()
updateAndStepAt reason updates steps = do
root <-
(Branch.stepManyAt steps)
. (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
<$> getRootBranch
updateRoot root reason
updateAndStepAt reason projectBranch updates steps = do
let f b =
b
& (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
& (Branch.stepManyAt (first Path.unabsolute <$> steps))
updateProjectBranchRoot_ projectBranch reason f
updateRoot :: Branch IO -> Text -> Cli ()
updateRoot new reason =
Cli.time "updateRoot" do
Cli.Env {codebase} <- ask
let newHash = Branch.headHash new
oldHash <- getLastSavedRootHash
when (oldHash /= newHash) do
liftIO (Codebase.putRootBranch codebase reason new)
setRootBranch new
setLastSavedRootHash newHash
updateProjectBranchRoot :: ProjectBranch -> Text -> (Branch IO -> Cli (Branch IO, r)) -> Cli r
updateProjectBranchRoot projectBranch reason f = do
Cli.Env {codebase} <- ask
Cli.time "updateProjectBranchRoot" do
old <- getProjectBranchRoot projectBranch
(new, result) <- f old
when (old /= new) do
liftIO $ Codebase.putBranch codebase new
Cli.runTransaction $ do
-- TODO: If we transactionally check that the project branch hasn't changed while we were computing the new
-- branch, and if it has, abort the transaction and return an error, then we can
-- remove the single UCM per codebase restriction.
causalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash new)
Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId
pure result
updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli ()
updateProjectBranchRoot_ projectBranch reason f = do
updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ()))
------------------------------------------------------------------------------------------------------------------------
-- Getting terms
getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent)
getTermsAt path = do
rootBranch0 <- getRootBranch0
pure (BranchUtil.getTerm (first Path.unabsolute path) rootBranch0)
getTermsAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set Referent)
getTermsAt (pp, hqSeg) = do
rootBranch0 <- getBranch0FromProjectPath pp
pure (BranchUtil.getTerm (mempty, hqSeg) rootBranch0)
------------------------------------------------------------------------------------------------------------------------
-- Getting types
getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference)
getTypesAt path = do
rootBranch0 <- getRootBranch0
pure (BranchUtil.getType (first Path.unabsolute path) rootBranch0)
getTypesAt :: (PP.ProjectPath, HQ'.HQSegment) -> Cli (Set TypeReference)
getTypesAt (pp, hqSeg) = do
rootBranch0 <- getBranch0FromProjectPath pp
pure (BranchUtil.getType (mempty, hqSeg) rootBranch0)
------------------------------------------------------------------------------------------------------------------------
-- Getting patches
@ -507,8 +491,8 @@ getPatchAt path =
-- | Get the patch at a path.
getMaybePatchAt :: Path.Split' -> Cli (Maybe Patch)
getMaybePatchAt path0 = do
(path, name) <- resolveSplit' path0
branch <- getBranch0At path
(pp, name) <- resolveSplit' path0
branch <- getBranch0FromProjectPath pp
liftIO (Branch.getMaybePatch name branch)
------------------------------------------------------------------------------------------------------------------------

16
unison-cli/src/Unison/Cli/NamesUtils.hs
View File

@ -1,15 +1,27 @@
-- | Utilities that have to do with constructing names objects.
module Unison.Cli.NamesUtils
( currentNames,
currentProjectRootNames,
projectBranchNames,
)
where
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
import Unison.Cli.Monad (Cli)
import Unison.Cli.MonadUtils (getCurrentBranch0)
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Names (Names)
-- | Produce a 'Names' object which contains names for the current branch.
currentNames :: Cli Names
currentNames = do
Branch.toNames <$> getCurrentBranch0
Branch.toNames <$> Cli.getCurrentBranch0
currentProjectRootNames :: Cli Names
currentProjectRootNames = do
Branch.toNames <$> Cli.getCurrentProjectRoot0
projectBranchNames :: ProjectBranch -> Cli Names
projectBranchNames pb = do
Branch.toNames . Branch.head <$> Cli.getProjectBranchRoot pb

56
unison-cli/src/Unison/Cli/Pretty.hs
View File

@ -5,7 +5,8 @@
module Unison.Cli.Pretty
( displayBranchHash,
prettyAbsolute,
prettyAbsoluteStripProject,
prettyProjectPath,
prettyBranchRelativePath,
prettyBase32Hex#,
prettyBase32Hex,
prettyBranchId,
@ -33,7 +34,6 @@ module Unison.Cli.Pretty
prettyRepoInfo,
prettySCH,
prettySemver,
prettyShareLink,
prettySharePath,
prettyShareURI,
prettySlashProjectBranchName,
@ -57,12 +57,10 @@ import Control.Monad.Writer (Writer, runWriter)
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time (UTCTime)
import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
import Network.URI (URI)
import Network.URI qualified as URI
import Network.URI.Encode qualified as URI
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as Reference
import U.Codebase.Sqlite.Project qualified as Sqlite
@ -70,23 +68,20 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Util.Base32Hex (Base32Hex)
import U.Util.Base32Hex qualified as Base32Hex
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
import Unison.Cli.Share.Projects.Types qualified as Share
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.RemoteRepo
( ReadRemoteNamespace (..),
ShareUserHandle (..),
WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..),
shareUserHandleToText,
)
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
import Unison.Core.Project (ProjectBranchName)
import Unison.DataDeclaration qualified as DD
import Unison.Debug qualified as Debug
@ -126,6 +121,7 @@ import Unison.Term (Term)
import Unison.Type (Type)
import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UF
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty qualified as P
import Unison.Var (Var)
import Unison.Var qualified as Var
@ -150,7 +146,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty
prettyReadRemoteNamespaceWith printProject =
P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject
prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
prettyWriteRemoteNamespace =
P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace
@ -161,14 +157,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty
prettyRepoInfo (Share.RepoInfo repoInfo) =
P.blue (P.text repoInfo)
prettyShareLink :: WriteShareRemoteNamespace -> Pretty
prettyShareLink WriteShareRemoteNamespace {repo, path} =
let encodedPath =
Path.toList path
& fmap (URI.encodeText . NameSegment.toUnescapedText)
& Text.intercalate "/"
in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath
prettySharePath :: Share.Path -> Pretty
prettySharePath =
prettyRelative
@ -194,16 +182,17 @@ prettyPath' p' =
then "the current namespace"
else P.blue (P.shown p')
prettyNamespaceKey :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
prettyNamespaceKey :: Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
prettyNamespaceKey = \case
Left path -> prettyPath' path
Left path -> prettyProjectPath path
Right (ProjectAndBranch project branch) ->
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
prettyBranchId :: Input.AbsBranchId -> Pretty
prettyBranchId = \case
Left sch -> prettySCH sch
Right absPath -> prettyAbsolute $ absPath
Input.BranchAtSCH sch -> prettySCH sch
Input.BranchAtPath absPath -> prettyAbsolute $ absPath
Input.BranchAtProjectPath pp -> prettyProjectPath pp
prettyRelative :: Path.Relative -> Pretty
prettyRelative = P.blue . P.shown
@ -211,6 +200,13 @@ prettyRelative = P.blue . P.shown
prettyAbsolute :: Path.Absolute -> Pretty
prettyAbsolute = P.blue . P.shown
prettyProjectPath :: PP.ProjectPath -> Pretty
prettyProjectPath (PP.ProjectPath project branch path) =
prettyProjectAndBranchName (ProjectAndBranch project.name branch.name)
<>
-- Only show the path if it's not the root
Monoid.whenM (path /= Path.absoluteEmpty) (P.cyan (":" <> P.shown path))
prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
@ -271,6 +267,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName ->
prettyProjectAndBranchName (ProjectAndBranch project branch) =
P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch)
prettyBranchRelativePath :: BranchRelativePath -> Pretty
prettyBranchRelativePath = P.blue . P.text . into @Text
-- produces:
-- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0
-- Optional.None, Maybe.Nothing : Maybe a
@ -343,7 +342,7 @@ prettyTypeName ppe r =
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
prettyWhichBranchEmpty = \case
WhichBranchEmptyHash hash -> P.shown hash
WhichBranchEmptyPath path -> prettyPath' path
WhichBranchEmptyPath pp -> prettyProjectPath pp
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
displayBranchHash :: CausalHash -> Text
@ -389,15 +388,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
<> " on "
<> P.shown host
stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path
stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism
prettyAbsoluteStripProject :: Path.Absolute -> Pretty
prettyAbsoluteStripProject path =
P.blue case stripProjectBranchInfo path of
Just p -> P.shown p
Nothing -> P.shown path
prettyLabeledDependencies :: PPE.PrettyPrintEnv -> Set LabeledDependency -> Pretty
prettyLabeledDependencies ppe lds =
P.syntaxToColor (P.sep ", " (ld <$> toList lds))

7
unison-cli/src/Unison/Cli/PrettyPrintUtils.hs
View File

@ -3,9 +3,11 @@
module Unison.Cli.PrettyPrintUtils
( prettyPrintEnvDeclFromNames,
currentPrettyPrintEnvDecl,
projectBranchPPED,
)
where
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.NamesUtils qualified as Cli
@ -14,6 +16,7 @@ import Unison.Names (Names)
import Unison.Prelude
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo)
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
-- | Builds a pretty print env decl from a names object.
@ -30,3 +33,7 @@ prettyPrintEnvDeclFromNames ns =
currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl
currentPrettyPrintEnvDecl = do
Cli.currentNames >>= prettyPrintEnvDeclFromNames
projectBranchPPED :: ProjectBranch -> Cli PPED.PrettyPrintEnvDecl
projectBranchPPED pb = do
Cli.projectBranchNames pb >>= prettyPrintEnvDeclFromNames

189
unison-cli/src/Unison/Cli/ProjectUtils.hs
View File

@ -1,21 +1,10 @@
-- | Project-related utilities.
module Unison.Cli.ProjectUtils
( -- * Project/path helpers
getCurrentProject,
expectCurrentProject,
expectCurrentProjectIds,
getCurrentProjectIds,
getCurrentProjectBranch,
getProjectBranchForPath,
expectCurrentProjectBranch,
expectProjectBranchByName,
projectPath,
projectBranchesPath,
projectBranchPath,
projectBranchSegment,
projectBranchPathPrism,
resolveBranchRelativePath,
branchRelativePathToAbsolute,
resolveProjectBranch,
resolveProjectBranchInProject,
-- * Name hydration
hydrateNames,
@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils
-- * Loading local project info
expectProjectAndBranchByIds,
getProjectAndBranchByTheseNames,
expectProjectAndBranchByTheseNames,
getProjectAndBranchByNames,
expectLooseCodeOrProjectBranch,
expectProjectAndBranchByTheseNames,
getProjectBranchCausalHash,
-- * Loading remote project info
@ -59,65 +47,43 @@ import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.These (These (..))
import U.Codebase.Causal qualified
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project (Project)
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.Share.Projects (IncludeSquashedHead)
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Input (LooseCodeOrProject)
import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath)
import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
import Unison.Codebase.ProjectPath qualified as PP
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
import Unison.Core.Project (ProjectBranchName (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectName)
import Unison.Project.Util
import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite
import Witch (unsafeFrom)
branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
branchRelativePathToAbsolute brp =
resolveBranchRelativePath brp <&> \case
BranchRelativePath.ResolvedLoosePath p -> p
BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
let projectBranchIds = getIds projectBranch
handleRel = case mRel of
Nothing -> id
Just rel -> flip Path.resolve rel
in handleRel (projectBranchPath projectBranchIds)
where
getIds = \case
ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath
resolveBranchRelativePath = \case
BranchRelativePath.BranchRelative brp -> case brp of
This projectBranch -> do
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing)
That path -> do
(projectBranch, _) <- expectCurrentProjectBranch
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
These projectBranch path -> do
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
BranchRelativePath.LoosePath path ->
BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path
where
toThese = \case
Left branchName -> That branchName
Right (projectName, branchName) -> These projectName branchName
resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath
resolveBranchRelativePath brp = do
case brp of
BranchPathInCurrentProject projBranchName path -> do
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
pure $ PP.fromProjectAndBranch projectAndBranch path
QualifiedBranchPath projName projBranchName path -> do
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
pure $ PP.fromProjectAndBranch projectAndBranch path
UnqualifiedPath newPath' -> do
pp <- Cli.getCurrentProjectPath
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
justTheIds x =
@ -152,58 +118,11 @@ findTemporaryBranchName projectId preferred = do
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
-- | Get the current project that a user is on.
getCurrentProject :: Cli (Maybe Sqlite.Project)
getCurrentProject = do
path <- Cli.getCurrentPath
case preview projectBranchPathPrism path of
Nothing -> pure Nothing
Just (ProjectAndBranch projectId _branchId, _restPath) ->
Cli.runTransaction do
project <- Queries.expectProject projectId
pure (Just project)
-- | Like 'getCurrentProject', but fails with a message if the user is not on a project branch.
expectCurrentProject :: Cli Sqlite.Project
expectCurrentProject = do
getCurrentProject & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
-- | Get the current project ids that a user is on.
getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId))
getCurrentProjectIds =
fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath
-- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch.
expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId)
expectCurrentProjectIds =
getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
-- | Get the current project+branch+branch path that a user is on.
getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
getCurrentProjectBranch = do
path <- Cli.getCurrentPath
getProjectBranchForPath path
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
expectProjectBranchByName project branchName =
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
getProjectBranchForPath :: Path.Absolute -> Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
getProjectBranchForPath path = do
case preview projectBranchPathPrism path of
Nothing -> pure Nothing
Just (ProjectAndBranch projectId branchId, restPath) ->
Cli.runTransaction do
project <- Queries.expectProject projectId
branch <- Queries.expectProjectBranch projectId branchId
pure (Just (ProjectAndBranch project branch, restPath))
-- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch.
expectCurrentProjectBranch :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)
expectCurrentProjectBranch =
getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
-- We often accept a `These ProjectName ProjectBranchName` from the user, so they can leave off either a project or
-- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following
-- defaults if a name is missing:
@ -214,8 +133,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
hydrateNames = \case
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
That branchName -> do
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
pure (ProjectAndBranch (project ^. #name) branchName)
pp <- Cli.getCurrentProjectPath
pure (ProjectAndBranch (pp ^. #project . #name) branchName)
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
@ -244,11 +163,15 @@ getProjectAndBranchByTheseNames ::
getProjectAndBranchByTheseNames = \case
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
That branchName -> runMaybeT do
(ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName))
pure (ProjectAndBranch project branch)
These projectName branchName ->
Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName))
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
pure (ProjectAndBranch proj branch)
These projectName branchName -> do
Cli.runTransaction do
runMaybeT do
project <- MaybeT (Queries.loadProjectByName projectName)
branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName)
pure (ProjectAndBranch project branch)
-- Expect a local project branch by a "these names", using the following defaults if a name is missing:
--
@ -260,7 +183,7 @@ expectProjectAndBranchByTheseNames ::
expectProjectAndBranchByTheseNames = \case
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
That branchName -> do
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
branch <-
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
@ -275,31 +198,33 @@ expectProjectAndBranchByTheseNames = \case
maybeProjectAndBranch & onNothing do
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
-- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules:
-- | Expect/resolve branch reference with the following rules:
--
-- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database.
-- 2. If we have an unambiguous `loose.code.path`, just return it.
-- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*,
-- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash).
expectLooseCodeOrProjectBranch ::
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ->
Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
expectLooseCodeOrProjectBranch =
_Right expectProjectAndBranchByTheseNames . f
where
f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName)
f = \case
This path -> Left path
That (ProjectAndBranch Nothing branch) -> Right (That branch)
That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
These path _ -> Left path -- (3) above
-- 1. If the project is missing, use the provided project.
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
-- project, defaulting to 'main' if branch is unspecified.
resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
pure projectAndBranch
-- | Expect/resolve branch reference with the following rules:
--
-- 1. If the project is missing, use the current project.
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
-- project, defaulting to 'main' if branch is unspecified.
resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
resolveProjectBranch pab = do
pp <- Cli.getCurrentProjectPath
resolveProjectBranchInProject (pp ^. #project) pab
-- | Get the causal hash of a project branch.
getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash
getProjectBranchCausalHash branch = do
let path = projectBranchPath branch
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
pure causal.causalHash
getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash
getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do
causalHashId <- Q.expectProjectBranchHead projectId branchId
Q.expectCausalHash causalHashId
------------------------------------------------------------------------------------------------------------------------
-- Remote project utils
@ -384,7 +309,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
let remoteBranchName = unsafeFrom @Text "main"
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
That branchName -> do
(ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
let localProjectId = localProject ^. #projectId
let localBranchId = localBranch ^. #branchId
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case

31
unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs
View File

@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup
)
where
import Control.Lens (unsnoc)
import Data.Foldable qualified as Foldable
import Data.Maybe (fromJust)
import U.Codebase.Branch qualified as Codebase.Branch
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.UniqueTypeGuidLookup qualified as Codebase
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text)
loadUniqueTypeGuid currentPath name0 = do
-- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path
-- to the unique type, plus its final distinguished name segment.
let (branchPath, name) =
name0
& Path.fromName'
& Path.resolve currentPath
& Path.unabsolute
& Path.toSeq
& unsnoc
-- This is safe because we were handed a Name, which can't be empty
& fromJust
loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text)
loadUniqueTypeGuid pp name0 = do
let (namePath, finalSegment) = Path.splitFromName name0
let fullPP = pp & over PP.path_ (<> namePath)
-- Define an operation to load a branch by its full path from the root namespace.
--
-- This ought to probably lean somewhat on a cache (so long as the caller is aware of the cache, and discrads it at
-- an appropriate time, such as after the current unison file finishes parsing).
let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
loadBranchAtPath = Operations.loadBranchAtPath Nothing
let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath
Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name
Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment

90
unison-cli/src/Unison/Cli/UnisonConfigUtils.hs
View File

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

504
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -21,7 +21,6 @@ import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as NESet
import Data.Text qualified as Text
import Data.These (These (..))
import Data.Time (UTCTime)
import Data.Tuple.Extra (uncurry3)
import Text.Megaparsec qualified as Megaparsec
@ -29,14 +28,13 @@ import U.Codebase.Branch.Diff qualified as V2Branch.Diff
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.ABT qualified as ABT
import Unison.Builtin qualified as Builtin
import Unison.Builtin.Terms qualified as Builtin
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils (getCurrentProjectBranch)
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.NamesUtils qualified as Cli
import Unison.Cli.PrettyPrintUtils qualified as Cli
@ -83,6 +81,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch)
import Unison.Codebase.Editor.HandleInput.Reflogs qualified as Reflogs
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
import Unison.Codebase.Editor.HandleInput.Run (handleRun)
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
@ -95,7 +94,6 @@ import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2)
import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN
@ -107,9 +105,10 @@ import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityChec
import Unison.Codebase.Metadata qualified as Metadata
import Unison.Codebase.Path (Path, Path' (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
import Unison.CommandLine.Completion qualified as Completion
import Unison.CommandLine.DisplayValues qualified as DisplayValues
import Unison.CommandLine.InputPattern qualified as IP
@ -117,7 +116,6 @@ import Unison.CommandLine.InputPatterns qualified as IP
import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DataDeclaration qualified as DD
import Unison.Hash qualified as Hash
import Unison.HashQualified qualified as HQ
import Unison.HashQualified' qualified as HQ'
import Unison.LabeledDependency (LabeledDependency)
@ -134,12 +132,8 @@ import Unison.Parser.Ann qualified as Ann
import Unison.Parsers qualified as Parsers
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty)
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..))
import Unison.Project.Util (projectContextFromPath)
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
@ -204,6 +198,7 @@ loop e = do
Cli.respond $ Typechecked (Text.pack sourceName) suffixifiedPPE sr uf
in Cli.time "InputPattern" case input of
ApiI -> do
pp <- Cli.getCurrentProjectPath
Cli.Env {serverBaseUrl} <- ask
whenJust serverBaseUrl \baseUrl ->
Cli.respond $
@ -211,17 +206,17 @@ loop e = do
P.lines
[ "The API information is as follows:",
P.newline,
P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl))),
P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.ProjectBranchUI (PP.toProjectAndBranch . PP.toNames $ pp) Path.absoluteEmpty Nothing) baseUrl))),
P.newline,
P.indentN 2 (P.hiBlue ("API: " <> Pretty.text (Server.urlFor Server.Api baseUrl)))
]
CreateMessage pretty ->
Cli.respond $ PrintMessage pretty
ShowReflogI -> do
ShowRootReflogI -> do
let numEntriesToShow = 500
(schLength, entries) <-
Cli.runTransaction $
(,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow
(,) <$> Codebase.branchHashLength <*> Codebase.getDeprecatedRootReflog numEntriesToShow
let moreEntriesToLoad = length entries == numEntriesToShow
let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad)
let (shortEntries, numberedEntries) =
@ -250,86 +245,20 @@ loop e = do
-- No expectation, either because this is the most recent entry or
-- because we're recovering from a discontinuity
Nothing -> ((Just time, toRootCausalHash, reason), (rest, Just fromRootCausalHash, moreEntriesToLoad))
ShowProjectBranchReflogI mayProjBranch -> do
Reflogs.showProjectBranchReflog mayProjBranch
ShowGlobalReflogI -> do
Reflogs.showGlobalReflog
ShowProjectReflogI mayProj -> do
Reflogs.showProjectReflog mayProj
ResetI newRoot mtarget -> do
newRoot <-
case newRoot of
This newRoot -> case newRoot of
Left hash -> Cli.resolveShortCausalHash hash
Right path' -> Cli.expectBranchAtPath' path'
That (ProjectAndBranch mProjectName branchName) -> do
let arg = case mProjectName of
Nothing -> That branchName
Just projectName -> These projectName branchName
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
Cli.expectBranchAtPath'
( Path.absoluteToPath'
( ProjectUtils.projectBranchPath
(ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
)
)
These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do
absPath <- case branchId of
Left hash -> jump =<< Cli.resolveShortCausalHash hash
Right path' -> Cli.resolvePath' path'
mrelativePath <-
Cli.getMaybeBranchAt absPath <&> \case
Nothing -> Nothing
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
projectAndBranch <- do
let arg = case mProjectName of
Nothing -> That branchName
Just projectName -> These projectName branchName
ProjectUtils.getProjectAndBranchByTheseNames arg
thePath <- case (mrelativePath, projectAndBranch) of
(Nothing, Nothing) ->
ProjectUtils.getCurrentProject >>= \case
Nothing -> pure absPath
Just project ->
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
Cli.returnEarlyWithoutOutput
(Just _relativePath, Nothing) -> pure absPath
(Nothing, Just (ProjectAndBranch project branch)) ->
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
Cli.expectBranchAtPath' (Path.absoluteToPath' thePath)
newRoot <- resolveBranchId2 newRoot
target <-
case mtarget of
Nothing -> Cli.getCurrentPath
Just looseCodeOrProject -> case looseCodeOrProject of
This path' -> Cli.resolvePath' path'
That (ProjectAndBranch mProjectName branchName) -> do
let arg = case mProjectName of
Nothing -> That branchName
Just projectName -> These projectName branchName
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
These path' (ProjectAndBranch mProjectName branchName) -> do
absPath <- Cli.resolvePath' path'
mrelativePath <-
Cli.getMaybeBranchAt absPath <&> \case
Nothing -> Nothing
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
projectAndBranch <- do
let arg = case mProjectName of
Nothing -> That branchName
Just projectName -> These projectName branchName
ProjectUtils.getProjectAndBranchByTheseNames arg
case (mrelativePath, projectAndBranch) of
(Nothing, Nothing) ->
ProjectUtils.getCurrentProject >>= \case
Nothing -> pure absPath
Just project ->
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
Cli.returnEarlyWithoutOutput
(Just _relativePath, Nothing) -> pure absPath
(Nothing, Just (ProjectAndBranch project branch)) ->
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
Nothing -> Cli.getCurrentProjectPath
Just unresolvedProjectAndBranch -> do
targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch)
pure $ PP.projectBranchRoot targetProjectAndBranch
description <- inputDescription input
_ <- Cli.updateAt description target (const newRoot)
Cli.respond Success
@ -337,22 +266,23 @@ loop e = do
Cli.time "reset-root" do
newRoot <-
case src0 of
Left hash -> Cli.resolveShortCausalHash hash
Right path' -> Cli.expectBranchAtPath' path'
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
BranchAtPath path' -> Cli.expectBranchAtPath' path'
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
description <- inputDescription input
Cli.updateRoot newRoot description
pb <- getCurrentProjectBranch
void $ Cli.updateProjectBranchRoot_ pb description (const newRoot)
Cli.respond Success
ForkLocalBranchI src0 dest0 -> do
(srcb, branchEmpty) <-
case src0 of
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
Right path' -> do
absPath <- ProjectUtils.branchRelativePathToAbsolute path'
let srcp = Path.AbsolutePath' absPath
srcb <- Cli.expectBranchAtPath' srcp
pure (srcb, WhichBranchEmptyPath srcp)
srcPP <- ProjectUtils.resolveBranchRelativePath path'
srcb <- Cli.getBranchFromProjectPath srcPP
pure (srcb, WhichBranchEmptyPath srcPP)
description <- inputDescription input
dest <- ProjectUtils.branchRelativePathToAbsolute dest0
dest <- ProjectUtils.resolveBranchRelativePath dest0
ok <- Cli.updateAtM description dest (const $ pure srcb)
Cli.respond
if ok
@ -360,54 +290,51 @@ loop e = do
else BranchEmpty branchEmpty
MergeI branch -> handleMerge branch
MergeCommitI -> handleCommitMerge
MergeLocalBranchI src0 dest0 mergeMode -> do
MergeLocalBranchI unresolvedSrc mayUnresolvedDest mergeMode -> do
description <- inputDescription input
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
let srcp = looseCodeOrProjectToPath src0
let destp = looseCodeOrProjectToPath dest0
srcb <- Cli.expectBranchAtPath' srcp
dest <- Cli.resolvePath' destp
let err =
Just $
MergeAlreadyUpToDate
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
PreviewMergeLocalBranchI src0 dest0 -> do
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
(destPP, destBRP) <- case mayUnresolvedDest of
Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_))
Just unresolvedDest -> do
ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest)
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP
mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP
PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do
Cli.Env {codebase} <- ask
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0
dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0
destb <- Cli.getBranchAt dest
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
if merged == destb
then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0)
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
destPP <- case mayUnresolvedDest of
Nothing -> Cli.getCurrentProjectPath
Just unresolvedDest -> do
ProjectUtils.resolveBranchRelativePath unresolvedDest
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
destBranch <- Cli.getProjectBranchRoot destPP.branch
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch)
if merged == destBranch
then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP)
else do
(ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged)
Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff)
(ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged)
Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff)
DiffNamespaceI before after -> do
absBefore <- traverseOf _Right Cli.resolvePath' before
absAfter <- traverseOf _Right Cli.resolvePath' after
beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore
afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter
beforeLoc <- traverse ProjectUtils.resolveBranchRelativePath before
beforeBranch0 <- Branch.head <$> resolveBranchId2 before
afterLoc <- traverse ProjectUtils.resolveBranchRelativePath after
afterBranch0 <- Branch.head <$> resolveBranchId2 after
case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [])
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| [])
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc])
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [])
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| [])
(False, False) -> pure ()
(ppe, diff) <- diffHelper beforeBranch0 afterBranch0
Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff)
MoveBranchI src' dest' -> do
hasConfirmed <- confirmedCommand input
description <- inputDescription input
doMoveBranch description hasConfirmed src' dest'
doMoveBranch description src' dest'
SwitchBranchI path' -> do
path <- Cli.resolvePath' path'
branchExists <- Cli.branchExistsAtPath' path'
when (not branchExists) (Cli.respond $ CreatedNewBranch path)
Cli.cd path
when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_))
Cli.cd (path ^. PP.absPath_)
UpI -> do
path0 <- Cli.getCurrentPath
whenJust (unsnoc path0) \(path, _) ->
@ -418,10 +345,11 @@ loop e = do
HistoryI resultsCap diffCap from -> do
branch <-
case from of
Left hash -> Cli.resolveShortCausalHash hash
Right path' -> do
path <- Cli.resolvePath' path'
Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
BranchAtPath path' -> do
pp <- Cli.resolvePath' path'
Cli.getBranchFromProjectPath pp
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
schLength <- Cli.runTransaction Codebase.branchHashLength
history <- liftIO (doHistory schLength 0 branch [])
Cli.respondNumbered history
@ -439,7 +367,7 @@ loop e = do
let elem = (Branch.headHash b, Branch.namesDiff b' b)
doHistory schLength (n + 1) b' (elem : acc)
UndoI -> do
rootBranch <- Cli.getRootBranch
rootBranch <- Cli.getCurrentProjectRoot
(_, prev) <-
liftIO (Branch.uncons rootBranch) & onNothingM do
Cli.returnEarly . CantUndo $
@ -447,7 +375,8 @@ loop e = do
then CantUndoPastStart
else CantUndoPastMerge
description <- inputDescription input
Cli.updateRoot prev description
pb <- getCurrentProjectBranch
Cli.updateProjectBranchRoot_ pb description (const prev)
(ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch)
Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff)
UiI path' -> openUI path'
@ -466,8 +395,8 @@ loop e = do
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
DocsToHtmlI namespacePath' sourceDirectory -> do
Cli.Env {codebase, sandboxedRuntime} <- ask
absPath <- ProjectUtils.branchRelativePathToAbsolute namespacePath'
branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
projPath <- ProjectUtils.resolveBranchRelativePath namespacePath'
branch <- Cli.getBranchFromProjectPath projPath
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
pure ()
AliasTermI force src' dest' -> do
@ -492,7 +421,7 @@ loop e = do
when (not force && not (Set.null destTerms)) do
Cli.returnEarly (TermAlreadyExists dest' destTerms)
description <- inputDescription input
Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm)
Cli.stepAt description (BranchUtil.makeAddTermName dest srcTerm)
Cli.respond Success
AliasTypeI force src' dest' -> do
src <- traverseOf _Right Cli.resolveSplit' src'
@ -515,22 +444,22 @@ loop e = do
when (not force && not (Set.null destTypes)) do
Cli.returnEarly (TypeAlreadyExists dest' destTypes)
description <- inputDescription input
Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType)
Cli.stepAt description (BranchUtil.makeAddTypeName dest srcType)
Cli.respond Success
-- this implementation will happily produce name conflicts,
-- but will surface them in a normal diff at the end of the operation.
AliasManyI srcs dest' -> do
root0 <- Cli.getRootBranch0
root0 <- Cli.getCurrentProjectRoot0
currentBranch0 <- Cli.getCurrentBranch0
destAbs <- Cli.resolvePath' dest'
old <- Cli.getBranch0At destAbs
destPP <- Cli.resolvePath' dest'
old <- Cli.getBranch0FromProjectPath destPP
description <- inputDescription input
let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs
Cli.stepManyAt description actions
new <- Cli.getBranch0At destAbs
let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs
Cli.stepManyAt destPP.branch description actions
new <- Cli.getBranch0FromProjectPath destPP
(ppe, diff) <- diffHelper old new
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff)
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff)
when (not (null unknown)) do
Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown
where
@ -539,28 +468,29 @@ loop e = do
Branch0 IO ->
Branch0 IO ->
Path.Absolute ->
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) ->
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) ->
Path.HQSplit ->
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)])
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)])
go root0 currentBranch0 dest (missingSrcs, actions) hqsrc =
let proposedDest :: Path.Split
let proposedDest :: Path.AbsSplit
proposedDest = second HQ'.toName hqProposedDest
hqProposedDest :: Path.HQSplit
hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc
hqProposedDest :: Path.HQSplitAbsolute
hqProposedDest = Path.resolve dest hqsrc
-- `Nothing` if src doesn't exist
doType :: Maybe [(Path, Branch0 m -> Branch0 m)]
doType :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
doType = case ( BranchUtil.getType hqsrc currentBranch0,
BranchUtil.getType hqProposedDest root0
BranchUtil.getType (first Path.unabsolute hqProposedDest) root0
) of
(null -> True, _) -> Nothing -- missing src
(rsrcs, existing) ->
-- happy path
Just . map addAlias . toList $ Set.difference rsrcs existing
where
addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m)
addAlias r = BranchUtil.makeAddTypeName proposedDest r
doTerm :: Maybe [(Path, Branch0 m -> Branch0 m)]
doTerm :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0,
BranchUtil.getTerm hqProposedDest root0
BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0
) of
(null -> True, _) -> Nothing -- missing src
(rsrcs, existing) ->
@ -577,15 +507,10 @@ loop e = do
fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
NamesI global query -> do
hqLength <- Cli.runTransaction Codebase.hashLength
root <- Cli.getRootBranch
(names, pped) <-
if global || any Name.isAbsolute query
if global
then do
let root0 = Branch.head root
-- Use an absolutely qualified ppe for view.global
let names = Names.makeAbsolute $ Branch.toNames root0
let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names)
pure (names, pped)
error "TODO: Implement names.global."
else do
names <- Cli.currentNames
pped <- Cli.prettyPrintEnvDeclFromNames names
@ -615,11 +540,13 @@ loop e = do
authorPath <- Cli.resolveSplit' authorPath'
copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment)
guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment)
pb <- Cli.getCurrentProjectBranch
Cli.stepManyAt
pb
description
[ BranchUtil.makeAddTermName (first Path.unabsolute authorPath) (d authorRef),
BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
[ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef),
BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef),
BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef)
]
currentPath <- Cli.getCurrentPath
finalBranch <- Cli.getCurrentBranch0
@ -639,51 +566,56 @@ loop e = do
MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input
MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input
MoveAllI src' dest' -> do
hasConfirmed <- confirmedCommand input
desc <- inputDescription input
handleMoveAll hasConfirmed src' dest' desc
DeleteI dtarget -> case dtarget of
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
DeleteTarget'Namespace insistence Nothing -> do
hasConfirmed <- confirmedCommand input
if hasConfirmed || insistence == Force
then do
description <- inputDescription input
Cli.updateRoot Branch.empty description
Cli.respond DeletedEverything
else Cli.respond DeleteEverythingConfirmation
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
branch <- Cli.expectBranchAtPath (Path.unsplit p)
description <- inputDescription input
let toDelete =
Names.prefix0
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
(Branch.toNames (Branch.head branch))
afterDelete <- do
names <- Cli.currentNames
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
case (null endangerments, insistence) of
(True, _) -> pure (Cli.respond Success)
(False, Force) -> do
ppeDecl <- Cli.currentPrettyPrintEnvDecl
pure do
Cli.respond Success
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
(False, Try) -> do
ppeDecl <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
Cli.returnEarlyWithoutOutput
parentPathAbs <- Cli.resolvePath parentPath
-- We have to modify the parent in order to also wipe out the history at the
-- child.
Cli.updateAt description parentPathAbs \parentBranch ->
parentBranch
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
afterDelete
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
DeleteTarget'Project name -> handleDeleteProject name
handleMoveAll src' dest' desc
DeleteI dtarget -> do
pp <- Cli.getCurrentProjectPath
let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg)
let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg)
case dtarget of
DeleteTarget'TermOrType doutput hqs -> do
delete input doutput getTerms getTypes hqs
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs
DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs
DeleteTarget'Namespace insistence Nothing -> do
hasConfirmed <- confirmedCommand input
if hasConfirmed || insistence == Force
then do
description <- inputDescription input
pp <- Cli.getCurrentProjectPath
_ <- Cli.updateAt description pp (const Branch.empty)
Cli.respond DeletedEverything
else Cli.respond DeleteEverythingConfirmation
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
branch <- Cli.expectBranchAtPath (Path.unsplit p)
description <- inputDescription input
let toDelete =
Names.prefix0
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
(Branch.toNames (Branch.head branch))
afterDelete <- do
names <- Cli.currentNames
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
case (null endangerments, insistence) of
(True, _) -> pure (Cli.respond Success)
(False, Force) -> do
ppeDecl <- Cli.currentPrettyPrintEnvDecl
pure do
Cli.respond Success
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
(False, Try) -> do
ppeDecl <- Cli.currentPrettyPrintEnvDecl
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
Cli.returnEarlyWithoutOutput
parentPathAbs <- Cli.resolvePath parentPath
-- We have to modify the parent in order to also wipe out the history at the
-- child.
Cli.updateAt description parentPathAbs \parentBranch ->
parentBranch
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
afterDelete
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
DeleteTarget'Project name -> handleDeleteProject name
DisplayI outputLoc namesToDisplay -> do
traverse_ (displayI outputLoc) namesToDisplay
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
@ -699,16 +631,15 @@ loop e = do
let vars = Set.map Name.toVar requestedNames
uf <- Cli.expectLatestTypecheckedFile
Cli.Env {codebase} <- ask
currentPath <- Cli.getCurrentPath
currentNames <- Branch.toNames <$> Cli.getCurrentBranch0
let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
let adds = SlurpResult.adds sr
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
pp <- Cli.getCurrentProjectPath
Cli.stepAt description (pp, doSlurpAdds adds uf)
pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames
let suffixifiedPPE = PPED.suffixifiedPPE pped
Cli.respond $ SlurpOutput input suffixifiedPPE sr
Cli.syncRoot description
SaveExecuteResultI resultName -> handleAddRun input resultName
PreviewAddI requestedNames -> do
(sourceName, _) <- Cli.expectLatestFile
@ -758,7 +689,8 @@ loop e = do
let destPath = case opath of
Just path -> Path.resolve currentPath (Path.Relative path)
Nothing -> currentPath `snoc` NameSegment.builtinSegment
_ <- Cli.updateAtM description destPath \destb ->
pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath
_ <- Cli.updateAtM description pp \destb ->
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
Cli.respond Success
MergeIOBuiltinsI opath -> do
@ -785,7 +717,8 @@ loop e = do
let destPath = case opath of
Just path -> Path.resolve currentPath (Path.Relative path)
Nothing -> currentPath `snoc` NameSegment.builtinSegment
_ <- Cli.updateAtM description destPath \destb ->
pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath
_ <- Cli.updateAtM description pp \destb ->
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
Cli.respond Success
PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
@ -807,22 +740,21 @@ loop e = do
Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
DebugTabCompletionI inputs -> do
Cli.Env {authHTTPClient, codebase} <- ask
currentPath <- Cli.getCurrentPath
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
pp <- Cli.getCurrentProjectPath
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp
(_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
Cli.respond (DisplayDebugCompletions completions)
DebugLSPNameCompletionI prefix -> do
LSPDebug.debugLspNameCompletion prefix
DebugFuzzyOptionsI command args -> do
Cli.Env {codebase} <- ask
currentPath <- Cli.getCurrentPath
currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0
let projCtx = projectContextFromPath currentPath
case Map.lookup command InputPatterns.patternMap of
Just (IP.InputPattern {args = argTypes}) -> do
zip argTypes args & Monoid.foldMapM \case
((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do
results <- liftIO $ getOptions codebase projCtx currentBranch
pp <- Cli.getCurrentProjectPath
results <- liftIO $ getOptions codebase pp currentBranch
Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results))
((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do
Cli.respond DebugFuzzyOptionsNoResolver
@ -892,13 +824,13 @@ loop e = do
prettyRef renderR r = P.indentN 2 $ P.text (renderR r)
prettyDefn renderR (r, Foldable.toList -> names) =
P.lines (P.text <$> if null names then ["<unnamed>"] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r
rootBranch <- Cli.getRootBranch
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
projectRoot <- Cli.getCurrentProjectRoot
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot]
DebugDumpNamespaceSimpleI -> do
rootBranch0 <- Cli.getRootBranch0
for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) ->
projectRootBranch0 <- Cli.getCurrentProjectRoot0
for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) ->
traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) ->
for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) ->
traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
DebugLSPFoldRangesI -> do
@ -938,7 +870,7 @@ loop e = do
Cli.respond $ PrintVersion ucmVersion
ProjectRenameI name -> handleProjectRename name
ProjectSwitchI name -> projectSwitch name
ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name
ProjectCreateI tryDownloadingBase name -> void $ projectCreate tryDownloadingBase name
ProjectsI -> handleProjects
BranchI source name -> handleBranch source name
BranchRenameI name -> handleBranchRename name
@ -959,26 +891,23 @@ inputDescription input =
dest <- brp dest0
pure ("fork " <> src <> " " <> dest)
MergeLocalBranchI src0 dest0 mode -> do
src <- looseCodeOrProjectToText src0
dest <- looseCodeOrProjectToText dest0
let src = into @Text src0
let dest = maybe "" (into @Text) dest0
let command =
case mode of
Branch.RegularMerge -> "merge"
Branch.SquashMerge -> "merge.squash"
pure (command <> " " <> src <> " " <> dest)
ResetI hash tgt -> do
hashTxt <- case hash of
This hash -> hp' hash
That pr -> pure (into @Text pr)
These hash _pr -> hp' hash
ResetI newRoot tgt -> do
hashTxt <- bid2 newRoot
tgt <- case tgt of
Nothing -> pure ""
Just tgt -> do
tgt <- looseCodeOrProjectToText tgt
pure (" " <> tgt)
let tgtText = into @Text tgt
pure (" " <> tgtText)
pure ("reset " <> hashTxt <> tgt)
ResetRootI src0 -> do
src <- hp' src0
let src = into @Text src0
pure ("reset-root " <> src)
AliasTermI force src0 dest0 -> do
src <- hhqs' src0
@ -1117,9 +1046,19 @@ inputDescription input =
QuitI {} -> wat
ReleaseDraftI {} -> wat
ShowDefinitionI {} -> wat
ShowReflogI {} -> wat
StructuredFindI {} -> wat
StructuredFindReplaceI {} -> wat
ShowRootReflogI {} -> pure "deprecated.root-reflog"
ShowGlobalReflogI {} -> pure "reflog.global"
ShowProjectReflogI mayProjName -> do
case mayProjName of
Nothing -> pure "project.reflog"
Just projName -> pure $ "project.reflog" <> into @Text projName
ShowProjectBranchReflogI mayProjBranch -> do
case mayProjBranch of
Nothing -> pure "branch.reflog"
Just (PP.ProjectAndBranch Nothing branchName) -> pure $ "branch.reflog" <> into @Text branchName
Just (PP.ProjectAndBranch (Just projName) branchName) -> pure $ "branch.reflog" <> into @Text (PP.ProjectAndBranch projName branchName)
SwitchBranchI {} -> wat
TestI {} -> wat
TodoI {} -> wat
@ -1129,14 +1068,12 @@ inputDescription input =
UpgradeI {} -> wat
VersionI -> wat
where
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
hp' = either (pure . Text.pack . show) p'
p :: Path -> Cli Text
p = fmap tShow . Cli.resolvePath
p = fmap (into @Text) . Cli.resolvePath
p' :: Path' -> Cli Text
p' = fmap tShow . Cli.resolvePath'
p' = fmap (into @Text) . Cli.resolvePath'
brp :: BranchRelativePath -> Cli Text
brp = fmap from . ProjectUtils.resolveBranchRelativePath
brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath
ops :: Maybe Path.Split -> Cli Text
ops = maybe (pure ".") ps
wat = error $ show input ++ " is not expected to alter the branch"
@ -1151,12 +1088,10 @@ inputDescription input =
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
ps' = p' . Path.unsplit'
ps = p . Path.unsplit
looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text
looseCodeOrProjectToText = \case
This path -> p' path
That branch -> pure (into @Text branch)
-- just trying to recover the syntax the user wrote
These path _branch -> pure (Path.toText' path)
bid2 :: BranchId2 -> Cli Text
bid2 = \case
Left sch -> pure $ into @Text sch
Right p -> brp p
handleFindI ::
Bool ->
@ -1169,7 +1104,7 @@ handleFindI isVerbose fscope ws input = do
(pped, names, searchRoot, branch0) <- case fscope of
FindLocal p -> do
searchRoot <- Cli.resolvePath' p
branch0 <- Cli.getBranch0At searchRoot
branch0 <- Cli.getBranch0FromProjectPath searchRoot
let names = Branch.toNames (Branch.withoutLib branch0)
-- Don't exclude anything from the pretty printer, since the type signatures we print for
-- results may contain things in lib.
@ -1177,17 +1112,18 @@ handleFindI isVerbose fscope ws input = do
pure (pped, names, Just p, branch0)
FindLocalAndDeps p -> do
searchRoot <- Cli.resolvePath' p
branch0 <- Cli.getBranch0At searchRoot
branch0 <- Cli.getBranch0FromProjectPath searchRoot
let names = Branch.toNames (Branch.withoutTransitiveLibs branch0)
-- Don't exclude anything from the pretty printer, since the type signatures we print for
-- results may contain things in lib.
pped <- Cli.currentPrettyPrintEnvDecl
pure (pped, names, Just p, branch0)
FindGlobal -> do
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
pped <- Cli.prettyPrintEnvDeclFromNames globalNames
-- TODO: Rewrite to be properly global again
projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
currentBranch0 <- Cli.getCurrentBranch0
pure (pped, globalNames, Nothing, currentBranch0)
pure (pped, projectRootNames, Nothing, currentBranch0)
let suffixifiedPPE = PPED.suffixifiedPPE pped
let getResults :: Names -> Cli [SearchResult]
getResults names =
@ -1323,16 +1259,16 @@ handleShowDefinition outputLoc showDefinitionScope query = do
hqLength <- Cli.runTransaction Codebase.hashLength
let hasAbsoluteQuery = any (any Name.isAbsolute) query
(names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of
-- If any of the queries are absolute, use global names.
-- TODO: We should instead print each definition using the names from its project-branch root.
(True, _) -> do
root <- Cli.getRootBranch
root <- Cli.getCurrentProjectRoot
let root0 = Branch.head root
let names = Names.makeAbsolute $ Branch.toNames root0
pped <- Cli.prettyPrintEnvDeclFromNames names
pure (names, pped)
(_, ShowDefinitionGlobal) -> do
root <- Cli.getRootBranch
-- TODO: Maybe rewrite to be properly global
root <- Cli.getCurrentProjectRoot
let root0 = Branch.head root
let names = Names.makeAbsolute $ Branch.toNames root0
pped <- Cli.prettyPrintEnvDeclFromNames names
@ -1534,8 +1470,8 @@ delete input doutput getTerms getTypes hqs' = do
traverse
( \hq -> do
absolute <- Cli.resolveSplit' hq
types <- getTypes absolute
terms <- getTerms absolute
types <- getTypes (first PP.absPath absolute)
terms <- getTerms (first PP.absPath absolute)
return (hq, types, terms)
)
hqs'
@ -1554,25 +1490,20 @@ checkDeletes :: [(Path.HQSplit', Set Reference, Set Referent)] -> DeleteOutput -
checkDeletes typesTermsTuples doutput inputs = do
let toSplitName ::
(Path.HQSplit', Set Reference, Set Referent) ->
Cli (Path.Split, Name, Set Reference, Set Referent)
Cli (Path.AbsSplit, Name, Set Reference, Set Referent)
toSplitName hq = do
-- __FIXME__: `resolvedPath` is ostensiby `Absolute`, but the paths here must be `Relative` below
resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
(pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
let resolvedSplit = (pp.absPath, ns)
return
( resolvedPath,
Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
hq ^. _2,
hq ^. _3
)
(resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3)
-- get the splits and names with terms and types
splitsNames <- traverse toSplitName typesTermsTuples
let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref
toRel setRef name = R.fromList (fmap (name,) (toList setRef))
let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames
-- make sure endangered is compeletely contained in paths
-- TODO: We should just check for endangerments from the project root, not the
-- global root!
rootNames <- Branch.toNames <$> Cli.getRootBranch0
projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0
-- get only once for the entire deletion set
let allTermsToDelete :: Set LabeledDependency
allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
@ -1581,7 +1512,7 @@ checkDeletes typesTermsTuples doutput inputs = do
Cli.runTransaction $
traverse
( \targetToDelete ->
getEndangeredDependents targetToDelete (allTermsToDelete) rootNames
getEndangeredDependents targetToDelete (allTermsToDelete) projectNames
)
toDelete
-- If the overall dependency map is not completely empty, abort deletion
@ -1596,7 +1527,8 @@ checkDeletes typesTermsTuples doutput inputs = do
)
before <- Cli.getCurrentBranch0
description <- inputDescription inputs
Cli.stepManyAt description deleteTypesTerms
pb <- Cli.getCurrentProjectBranch
Cli.stepManyAt pb description deleteTypesTerms
case doutput of
DeleteOutput'Diff -> do
after <- Cli.getCurrentBranch0
@ -1605,7 +1537,7 @@ checkDeletes typesTermsTuples doutput inputs = do
DeleteOutput'NoDiff -> do
Cli.respond Success
else do
ppeDecl <- Cli.prettyPrintEnvDeclFromNames rootNames
ppeDecl <- Cli.prettyPrintEnvDeclFromNames projectNames
let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions
Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs)
@ -1666,7 +1598,7 @@ displayI outputLoc hq = do
(names, pped) <-
if useRoot
then do
root <- Cli.getRootBranch
root <- Cli.getCurrentProjectRoot
let root0 = Branch.head root
let names = Names.makeAbsolute $ Branch.toNames root0
pped <- Cli.prettyPrintEnvDeclFromNames names
@ -1778,14 +1710,10 @@ addWatch watchName (Just uf) = do
)
_ -> addWatch watchName Nothing
looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path'
looseCodeOrProjectToPath = \case
Left pth -> pth
Right (ProjectAndBranch prj br) ->
Path.absoluteToPath'
( ProjectUtils.projectBranchPath
( ProjectAndBranch
(prj ^. #projectId)
(br ^. #branchId)
)
)
resolveBranchId2 :: BranchId2 -> Cli (Branch IO)
resolveBranchId2 = \case
Left sch -> Cli.resolveShortCausalHash sch
Right brp -> do
pp <- ProjectUtils.resolveBranchRelativePath brp
Cli.Env {codebase} <- ask
fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp)

7
unison-cli/src/Unison/Codebase/Editor/HandleInput/AddRun.hs
View File

@ -19,7 +19,6 @@ import Unison.Codebase.Editor.Input (Input)
import Unison.Codebase.Editor.Output (Output (NoLastRunResult, SaveTermNameConflict, SlurpOutput))
import Unison.Codebase.Editor.Slurp qualified as Slurp
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
import Unison.Codebase.Path qualified as Path
import Unison.CommandLine.InputPattern qualified as InputPattern
import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.Name (Name)
@ -37,16 +36,16 @@ handleAddRun input resultName = do
let resultVar = Name.toVar resultName
uf <- addSavedTermToUnisonFile resultName
Cli.Env {codebase} <- ask
currentPath <- Cli.getCurrentPath
currentNames <- Cli.currentNames
let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
let adds = SlurpResult.adds sr
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
let description = (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName)
pp <- Cli.getCurrentProjectPath
Cli.stepAt description (pp, doSlurpAdds adds uf)
let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames
pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
let suffixifiedPPE = PPE.suffixifiedPPE pped
Cli.syncRoot (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName)
Cli.respond $ SlurpOutput input suffixifiedPPE sr
addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann)

163
unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs
View File

@ -1,44 +1,42 @@
-- | @branch@ input handler
module Unison.Codebase.Editor.HandleInput.Branch
( handleBranch,
CreateFrom (..),
doCreateBranch,
doCreateBranch',
( CreateFrom (..),
handleBranch,
createBranch,
)
where
import Data.These (These (..))
import Control.Monad.Reader
import Data.UUID.V4 qualified as UUID
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli (getBranchAt, getCurrentPath, updateAt)
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Branch qualified as Branch (empty)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
import Unison.Sqlite qualified as Sqlite
data CreateFrom
= CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
| CreateFrom'LooseCode Path.Absolute
= CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
| CreateFrom'ParentBranch Sqlite.ProjectBranch
| CreateFrom'Namespace (Branch IO)
| CreateFrom'Nothingness
-- | Create a new project branch from an existing project branch or namespace.
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleBranch sourceI projectAndBranchNames0 = do
projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <-
case projectAndBranchNames0 of
ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName)
ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName)
handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do
-- You can only create release branches with `branch.clone`
--
-- We do allow creating draft release branches with `branch`, but you'll get different output if you use
@ -50,93 +48,81 @@ handleBranch sourceI projectAndBranchNames0 = do
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
ProjectBranchNameKind'NothingSpecial -> pure ()
currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name)
let projectName = (fromMaybe currentProjectName mayProjectName)
destProject <- do
Cli.runTransactionWithRollback
\rollback -> do
Queries.loadProjectByName projectName & onNothingM do
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName))
-- Compute what we should create the branch from.
createFrom <-
maySrcProjectAndBranch <-
case sourceI of
Input.BranchSourceI'CurrentContext ->
ProjectUtils.getCurrentProjectBranch >>= \case
Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath
Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch)
Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness
Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do
currentPath <- Cli.getCurrentPath
pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath))
Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) ->
fmap CreateFrom'Branch do
ProjectUtils.expectProjectAndBranchByTheseNames
case sourceBranch of
ProjectAndBranch Nothing b -> That b
ProjectAndBranch (Just p) b -> These p b
-- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a
-- branch from a relative one-segment namespace.
--
-- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they
-- really meant create a branch from that namespace.
Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) ->
fmap CreateFrom'Branch do
ProjectUtils.expectProjectAndBranchByTheseNames
case sourceBranch of
ProjectAndBranch Nothing b -> That b
ProjectAndBranch (Just p) b -> These p b
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
Input.BranchSourceI'Empty -> pure Nothing
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
pp <- Cli.getCurrentProjectPath
Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
project <-
Cli.runTransactionWithRollback \rollback -> do
Queries.loadProjectByName projectName & onNothingM do
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
_ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
case maySrcProjectAndBranch of
Just srcProjectAndBranch -> do
let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name))
void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName)
Nothing -> do
let description = "Empty branch created"
void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName)
Cli.respond $
Output.CreatedProjectBranch
( case createFrom of
CreateFrom'Branch sourceBranch ->
if sourceBranch ^. #project . #projectId == project ^. #projectId
( case maySrcProjectAndBranch of
Just sourceBranch ->
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path
CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
)
projectAndBranchNames
(projectAndBranchNames & #project .~ projectName)
-- | @doCreateBranch createFrom project branch description@:
-- | @createBranchFromParent createFrom project branch description@:
--
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@)
-- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog.
-- 3. cds to the new branch in the root namespace.
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@).
-- 3. Switches to the new branch.
--
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
-- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
--
-- Returns the branch id of the newly-created branch.
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
doCreateBranch createFrom project newBranchName description = do
sourceNamespaceObject <-
case createFrom of
CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do
let sourceProjectId = sourceBranch ^. #projectId
let sourceBranchId = sourceBranch ^. #branchId
Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId))
CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath
CreateFrom'Nothingness -> pure Branch.empty
let parentBranchId =
case createFrom of
CreateFrom'Branch (ProjectAndBranch _ sourceBranch)
| sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId
_ -> Nothing
(newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description
pure newBranchId
doCreateBranch' ::
Branch IO ->
Maybe ProjectBranchId ->
createBranch ::
Text ->
CreateFrom ->
Sqlite.Project ->
Sqlite.Transaction ProjectBranchName ->
Text ->
Cli (ProjectBranchId, ProjectBranchName)
doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do
createBranch description createFrom project getNewBranchName = do
let projectId = project ^. #projectId
(newBranchId, newBranchName) <-
Cli.Env {codebase} <- ask
(mayParentBranchId, newBranchCausalHashId) <- case createFrom of
CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do
newBranchCausalHashId <- Q.expectProjectBranchHead parentBranch.projectId parentBranch.branchId
let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing
pure (parentBranchId, newBranchCausalHashId)
CreateFrom'Nothingness -> Cli.runTransaction do
(_, causalHashId) <- Codebase.emptyCausalHash
pure (Nothing, causalHashId)
CreateFrom'NamespaceWithParent parentBranch namespace -> do
liftIO $ Codebase.putBranch codebase namespace
Cli.runTransaction $ do
newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash namespace)
let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing
pure (parentBranchId, newBranchCausalHashId)
CreateFrom'Namespace branch -> do
liftIO $ Codebase.putBranch codebase branch
Cli.runTransaction $ do
newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch)
pure (Nothing, newBranchCausalHashId)
(newBranchName, newBranchId) <-
Cli.runTransactionWithRollback \rollback -> do
newBranchName <- getNewBranchName
Queries.projectBranchExistsByName projectId newBranchName >>= \case
@ -146,16 +132,15 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de
-- `bar`, so the fork will succeed.
newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
Queries.insertProjectBranch
description
newBranchCausalHashId
Sqlite.ProjectBranch
{ projectId,
branchId = newBranchId,
name = newBranchName,
parentBranchId = parentBranchId
parentBranchId = mayParentBranchId
}
Queries.setMostRecentBranch projectId newBranchId
pure (newBranchId, newBranchName)
pure (newBranchName, newBranchId)
let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
Cli.cd newBranchPath
Cli.switchProject (ProjectAndBranch projectId newBranchId)
pure (newBranchId, newBranchName)

5
unison-cli/src/Unison/Codebase/Editor/HandleInput/BranchRename.hs
View File

@ -7,14 +7,15 @@ where
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName)
handleBranchRename :: ProjectBranchName -> Cli ()
handleBranchRename newBranchName = do
(ProjectAndBranch project branch, _path) <- ProjectUtils.expectCurrentProjectBranch
PP.ProjectPath project branch _path <- Cli.getCurrentProjectPath
case classifyProjectBranchName newBranchName of
ProjectBranchNameKind'Contributor {} -> pure ()

9
unison-cli/src/Unison/Codebase/Editor/HandleInput/Branches.hs
View File

@ -10,14 +10,14 @@ import Network.URI (URI)
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Project (ProjectBranchName, ProjectName)
handleBranches :: Maybe ProjectName -> Cli ()
handleBranches maybeProjectName = do
maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds
pp <- Cli.getCurrentProjectPath
(project, branches) <-
Cli.runTransactionWithRollback \rollback -> do
project <-
@ -26,8 +26,7 @@ handleBranches maybeProjectName = do
Queries.loadProjectByName projectName & onNothingM do
rollback (Output.LocalProjectDoesntExist projectName)
Nothing -> do
ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch)
Queries.expectProject projectId
pure (pp ^. #project)
branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId)
pure (project, branches)
Cli.respondNumbered (Output.ListBranches (project ^. #name) (f branches))

6
unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitMerge.hs
View File

@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
handleCommitMerge :: Cli ()
handleCommitMerge = do
(mergeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
mergeProjectAndBranch <- Cli.getCurrentProjectAndBranch
-- Assert that this is a "merge" branch, get its parent (which is the branch we were on when we ran `merge`),
-- and switch to the parent.
@ -33,9 +34,8 @@ handleCommitMerge = do
parentBranch <-
Cli.runTransaction do
parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
pure parentBranch
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId)
-- Merge the merge branch into the parent

6
unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs
View File

@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
handleCommitUpgrade :: Cli ()
handleCommitUpgrade = do
(upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
upgradeProjectAndBranch <- Cli.getCurrentProjectAndBranch
-- Assert that this is an "upgrade" branch, get its parent (which is the branch we were on when we ran `upgrade`),
-- and switch to the parent.
@ -33,9 +34,8 @@ handleCommitUpgrade = do
parentBranch <-
Cli.runTransaction do
parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
pure parentBranch
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId)
-- Merge the upgrade branch into the parent

99
unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs
View File

@ -5,19 +5,26 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch
)
where
import Data.Map.Strict qualified as Map
import Data.These (These (..))
import Control.Lens
import Data.List qualified as List
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Path qualified as Path
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput.ProjectCreate
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Project (ProjectAndBranch (..))
import Unison.Sqlite qualified as Sqlite
import Witch (unsafeFrom)
-- | Delete a project branch.
@ -27,44 +34,64 @@ import Witch (unsafeFrom)
-- project.
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleDeleteBranch projectAndBranchNamesToDelete = do
projectAndBranchToDelete <-
ProjectUtils.expectProjectAndBranchByTheseNames
case projectAndBranchNamesToDelete of
ProjectAndBranch Nothing branch -> That branch
ProjectAndBranch (Just project) branch -> These project branch
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
doDeleteProjectBranch projectAndBranchToDelete
ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath
projectAndBranchToDelete@(ProjectAndBranch projectOfBranchToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just)
-- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
--
-- 1. cd to parent branch, if it exists
-- 2. cd to "main", if it exists
-- 3. cd to loose code path `.`
whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
newPath <-
case projectAndBranchToDelete.branch.parentBranchId of
Nothing ->
let loadMain =
Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
in Cli.runTransaction loadMain <&> \case
Nothing -> Path.Absolute Path.empty
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
Just parentBranchId ->
pure $
ProjectUtils.projectBranchPath
(ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
Cli.cd newPath
-- 3. Any other branch in the codebase
-- 4. Create a dummy project and go to /main
when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do
mayNextLocation <-
Cli.runTransaction . runMaybeT $
asum
[ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId),
findMainBranchInProjectExcept (currentProject ^. #projectId) (branchToDelete ^. #branchId),
-- Any branch in the codebase except the one we're deleting
findAnyBranchInProjectExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId),
findAnyBranchInCodebaseExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId),
createNewBranchInProjectExcept projectOfBranchToDelete.name branchToDelete.name
]
nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing
Cli.switchProject nextLoc
doDeleteProjectBranch projectAndBranchToDelete
where
parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
parentBranch projectId mayParentBranchId = do
parentBranchId <- hoistMaybe mayParentBranchId
pure (ProjectAndBranch projectId parentBranchId)
findMainBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
findMainBranchInProjectExcept projectId exceptBranchId = do
branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")
guard (branch ^. #branchId /= exceptBranchId)
pure (ProjectAndBranch projectId (branch ^. #branchId))
findAnyBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
findAnyBranchInProjectExcept projectId exceptBranchId = do
(someBranchId, _) <- MaybeT . fmap (List.find (\(branchId, _) -> branchId /= exceptBranchId)) $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing
pure (ProjectAndBranch projectId someBranchId)
findAnyBranchInCodebaseExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
findAnyBranchInCodebaseExcept exceptProjectId exceptBranchId = do
(_, pbIds) <- MaybeT . fmap (List.find (\(_, ids) -> ids /= ProjectAndBranch exceptProjectId exceptBranchId)) $ Queries.loadAllProjectBranchNamePairs
pure pbIds
createNewBranchInProjectExcept :: ProjectName -> ProjectBranchName -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
createNewBranchInProjectExcept projectName (UnsafeProjectBranchName "main") = lift $ do
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main2") emptyCausalHashId
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId
createNewBranchInProjectExcept projectName _ = lift $ do
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main") emptyCausalHashId
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId
-- | Delete a project branch and record an entry in the reflog.
doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
doDeleteProjectBranch :: (HasCallStack) => ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
doDeleteProjectBranch projectAndBranch = do
Cli.runTransaction do
Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId
Cli.stepAt
("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch))
( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId),
over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId))
)

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

@ -4,39 +4,53 @@ module Unison.Codebase.Editor.HandleInput.DeleteProject
)
where
import Data.Function (on)
import Control.Lens
import Data.List qualified as List
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectName)
import Unison.Project (ProjectAndBranch (..))
import Unison.Sqlite qualified as Sqlite
-- | Delete a project
handleDeleteProject :: ProjectName -> Cli ()
handleDeleteProject projectName = do
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
ProjectPath currentProject _ _ <- Cli.getCurrentProjectPath
deletedProject <-
projectToDelete <-
Cli.runTransactionWithRollback \rollback -> do
project <-
Queries.loadProjectByName projectName & onNothingM do
rollback (Output.LocalProjectDoesntExist projectName)
Queries.deleteProject (project ^. #projectId)
pure project
Queries.loadProjectByName projectName & onNothingM do
rollback (Output.LocalProjectDoesntExist projectName)
let projectId = deletedProject ^. #projectId
when (projectToDelete.projectId == currentProject.projectId) do
nextLoc <- Cli.runTransaction $ findAnyBranchInCodebaseNotInProject (projectToDelete.projectId) `whenNothingM` createDummyProjectExcept projectToDelete.name
Cli.switchProject nextLoc
Cli.updateAt
("delete.project " <> into @Text projectName)
(ProjectUtils.projectPath projectId)
(const Branch.empty)
Cli.runTransaction do
Queries.deleteProject (projectToDelete ^. #projectId)
where
findAnyBranchInCodebaseNotInProject :: ProjectId -> Sqlite.Transaction (Maybe (ProjectAndBranch ProjectId ProjectBranchId))
findAnyBranchInCodebaseNotInProject exceptProjectId = do
Queries.loadAllProjectBranchNamePairs
<&> List.find (\(_, ProjectAndBranch projId _) -> projId /= exceptProjectId)
<&> fmap \(_, pbIds) -> pbIds
-- If the user is on the project that they're deleting, we cd to the root path
whenJust maybeCurrentBranch \(ProjectAndBranch currentProject _currentBranch, _restPath) ->
when (on (==) (view #projectId) deletedProject currentProject) do
Cli.cd (Path.Absolute Path.empty)
createDummyProjectExcept :: ProjectName -> Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
createDummyProjectExcept (UnsafeProjectName "scratch") = do
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
Ops.insertProjectAndBranch (UnsafeProjectName "scratch2") (UnsafeProjectBranchName "main") emptyCausalHashId
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId
createDummyProjectExcept _ = do
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
Ops.insertProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main") emptyCausalHashId
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId

22
unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs
View File

@ -10,8 +10,6 @@ import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
import Unison.Cli.DownloadUtils
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
@ -22,6 +20,7 @@ import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Core.Project (ProjectBranchName)
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment (libSegment)
@ -40,14 +39,6 @@ import Unison.Syntax.NameSegment qualified as NameSegment (unsafeParseText)
handleInstallLib :: Bool -> ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease) -> Cli ()
handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBranchName) = do
(currentProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
let currentProjectBranchPath =
ProjectUtils.projectBranchPath $
ProjectAndBranch
currentProjectAndBranch.project.projectId
currentProjectAndBranch.branch.branchId
libdepProject <- ProjectUtils.expectRemoteProjectByName libdepProjectName
libdepBranchName <-
@ -79,7 +70,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran
--
-- For example, if the best name is "foo", and libdeps "foo" and "foo__2" already exist, then we'll get "foo__3".
libdepNameSegment :: NameSegment <- do
currentBranchObject <- Cli.getBranch0At currentProjectBranchPath
currentBranchObject <- Cli.getCurrentProjectRoot0
pure $
fresh
(\i -> NameSegment.unsafeParseText . (<> "__" <> tShow i) . NameSegment.toUnescapedText)
@ -90,13 +81,12 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran
(makeDependencyName libdepProjectName libdepBranchName)
let libdepPath :: Path.Absolute
libdepPath =
Path.resolve
currentProjectBranchPath
(Path.Relative (Path.fromList [NameSegment.libSegment, libdepNameSegment]))
libdepPath = Path.Absolute $ Path.fromList [NameSegment.libSegment, libdepNameSegment]
let reflogDescription = "lib.install " <> into @Text libdepProjectAndBranchNames
_didUpdate <- Cli.updateAt reflogDescription libdepPath (\_empty -> remoteBranchObject)
pp <- Cli.getCurrentProjectPath
let libDepPP = pp & PP.absPath_ .~ libdepPath
_didUpdate <- Cli.updateAt reflogDescription libDepPP (\_empty -> remoteBranchObject)
Cli.respond (Output.InstalledLibdep libdepProjectAndBranchNames libdepNameSegment)

4
unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs
View File

@ -78,7 +78,7 @@ loadUnisonFile sourceName text = do
Text ->
Cli (TypecheckedUnisonFile Symbol Ann)
withFile names sourceName text = do
currentPath <- Cli.getCurrentPath
pp <- Cli.getCurrentProjectPath
State.modify' \loopState ->
loopState
& #latestFile .~ Just (Text.unpack sourceName, False)
@ -88,7 +88,7 @@ loadUnisonFile sourceName text = do
let parsingEnv =
Parser.ParsingEnv
{ uniqueNames = uniqueName,
uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath,
uniqueTypeGuid = Cli.loadUniqueTypeGuid pp,
names
}
unisonFile <-

8
unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs
View File

@ -8,9 +8,11 @@ import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.PrettyPrintUtils qualified as Cli
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.Codebase.Path (Path')
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Prelude
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Server.Backend qualified as Backend
@ -18,9 +20,9 @@ import Unison.Server.Backend qualified as Backend
handleLs :: Path' -> Cli ()
handleLs pathArg = do
Cli.Env {codebase} <- ask
pathArgAbs <- Cli.resolvePath' pathArg
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
pp <- Cli.resolvePath' pathArg
projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch
entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath))
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
pped <- Cli.currentPrettyPrintEnvDecl
let suffixifiedPPE = PPED.suffixifiedPPE pped

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

@ -66,6 +66,8 @@ import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
@ -86,6 +88,7 @@ import Unison.Merge.EitherWay (EitherWay (..))
import Unison.Merge.EitherWayI (EitherWayI (..))
import Unison.Merge.EitherWayI qualified as EitherWayI
import Unison.Merge.Libdeps qualified as Merge
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
import Unison.Merge.Synhashed (Synhashed (..))
import Unison.Merge.Synhashed qualified as Synhashed
@ -139,12 +142,12 @@ import Unison.Util.SyntaxText (SyntaxText')
import Unison.Var (Var)
import Witch (unsafeFrom)
import Prelude hiding (unzip, zip, zipWith)
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
-- Assert that Alice (us) is on a project branch, and grab the causal hash.
(aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath
let aliceProjectAndBranch = ProjectAndBranch aliceProject aliceProjectBranch
-- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch
-- name, and causal hash.
@ -194,7 +197,6 @@ doMerge info = do
then realDebugFunctions
else fakeDebugFunctions
let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch)
let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
let mergeSource = MergeSourceOrTarget'Source info.bob.source
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
@ -211,7 +213,7 @@ doMerge info = do
-- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
when (info.lca.causalHash == Just info.alice.causalHash) do
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
_ <- Cli.updateAt info.description (PP.projectBranchRoot info.alice.projectAndBranch) (\_aliceBranch -> bobBranch)
done (Output.MergeSuccessFastForward mergeSourceAndTarget)
-- Create a bunch of cached database lookup functions
@ -398,7 +400,7 @@ doMerge info = do
in if thisMergeHasConflicts
then pure Nothing
else do
currentPath <- Cli.getCurrentPath
currentPath <- Cli.getCurrentProjectPath
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
@ -409,12 +411,12 @@ doMerge info = do
Nothing -> do
Cli.Env {writeSource} <- ask
(_temporaryBranchId, temporaryBranchName) <-
HandleInput.Branch.doCreateBranch'
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
(Just info.alice.projectAndBranch.branch.branchId)
HandleInput.Branch.createBranch
info.description
(HandleInput.Branch.CreateFrom'NamespaceWithParent info.alice.projectAndBranch.branch (Branch.mergeNode stageOneBranch parents.alice parents.bob))
info.alice.projectAndBranch.project
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
info.description
scratchFilePath <-
Cli.getLatestFile <&> \case
Nothing -> "scratch.u"
@ -424,11 +426,10 @@ doMerge info = do
Just tuf -> do
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
_ <-
Cli.updateAt
info.description
alicePath
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
Cli.updateProjectBranchRoot_
info.alice.projectAndBranch.branch
info.description
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
pure (Output.MergeSuccess mergeSourceAndTarget)
Cli.respond finalOutput
@ -437,8 +438,8 @@ doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
doMergeLocalBranch branches = do
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
Cli.runTransaction do
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch)
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch)
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)

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

@ -11,9 +11,9 @@ import Unison.Codebase.Path qualified as Path
import Unison.HashQualified' qualified as HQ'
import Unison.Prelude
handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli ()
handleMoveAll hasConfirmed src' dest' description = do
moveBranchFunc <- moveBranchFunc hasConfirmed src' dest'
handleMoveAll :: Path.Path' -> Path.Path' -> Text -> Cli ()
handleMoveAll src' dest' description = do
moveBranchFunc <- moveBranchFunc src' dest'
moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
Nothing -> pure []
Just (fmap HQ'.NameOnly -> src, dest) -> do
@ -23,5 +23,6 @@ handleMoveAll hasConfirmed src' dest' description = do
case (moveBranchFunc, moveTermTypeSteps) of
(Nothing, []) -> Cli.respond (Output.MoveNothingFound src')
(mupdates, steps) -> do
Cli.updateAndStepAt description (maybeToList mupdates) steps
pp <- Cli.getCurrentProjectPath
Cli.updateAndStepAt description (pp ^. #branch) (maybeToList mupdates) steps
Cli.respond Output.Success

30
unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveBranch.hs
View File

@ -7,17 +7,18 @@ import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Output (Output (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Prelude
moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
moveBranchFunc hasConfirmed src' dest' = do
srcAbs <- Cli.resolvePath' src'
destAbs <- Cli.resolvePath' dest'
-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if
-- needed.
moveBranchFunc :: Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
moveBranchFunc src' dest' = do
-- We currently only support moving within the same project branch.
srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src'
PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest'
destBranchExists <- Cli.branchExistsAtPath' dest'
let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
when (isRootMove && not hasConfirmed) do
Cli.returnEarly MoveRootBranchConfirmation
Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do
-- We want the move to appear as a single step in the root namespace, but we need to make
-- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
-- those changes such that they appear as a single change in the root.
@ -26,17 +27,18 @@ moveBranchFunc hasConfirmed src' dest' = do
changeRoot
& Branch.modifyAt srcLoc (const Branch.empty)
& Branch.modifyAt destLoc (const srcBranch)
if (destBranchExists && not isRootMove)
if destBranchExists
then Cli.respond (MovedOverExistingBranch dest')
else pure ()
pure (Path.Absolute changeRootPath, doMove)
-- | Moves a branch and its history from one location to another, and saves the new root
-- branch.
doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
doMoveBranch actionDescription hasConfirmed src' dest' = do
moveBranchFunc hasConfirmed src' dest' >>= \case
doMoveBranch :: Text -> Path.Path' -> Path.Path' -> Cli ()
doMoveBranch actionDescription src' dest' = do
moveBranchFunc src' dest' >>= \case
Nothing -> Cli.respond (BranchNotFound src')
Just (path, func) -> do
_ <- Cli.updateAt actionDescription path func
Just (absPath, func) -> do
pp <- Cli.resolvePath' (Path.AbsolutePath' absPath)
_ <- Cli.updateAt actionDescription pp func
Cli.respond Success

14
unison-cli/src/Unison/Codebase/Editor/HandleInput/MoveTerm.hs
View File

@ -1,6 +1,6 @@
module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where
import Control.Lens (_2)
import Control.Lens (_1, _2)
import Data.Set qualified as Set
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.BranchUtil qualified as BranchUtil
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path (Path, Path')
import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.HashQualified' qualified as HQ'
import Unison.NameSegment (NameSegment)
import Unison.Prelude
moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)]
moveTermSteps src' dest' = do
src <- Cli.resolveSplit' src'
srcTerms <- Cli.getTermsAt src
@ -29,11 +30,11 @@ moveTermSteps src' dest' = do
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
when (not (Set.null destTerms)) do
Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
let p = first Path.unabsolute src
let p = src & _1 %~ view PP.absPath_
pure
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm
BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm
]
doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
@ -41,5 +42,6 @@ doMoveTerm src' dest' description = do
steps <- moveTermSteps src' dest'
when (null steps) do
Cli.returnEarly (Output.TermNotFound src')
Cli.stepManyAt description steps
pb <- Cli.getCurrentProjectBranch
Cli.stepManyAt pb description steps
Cli.respond Output.Success

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

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

19
unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs
View File

@ -14,7 +14,6 @@ import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.DataDeclaration qualified as DD
@ -22,7 +21,6 @@ import Unison.LabeledDependency (LabeledDependency)
import Unison.LabeledDependency qualified as LD
import Unison.Name (Name)
import Unison.NameSegment qualified as NameSegment
import Unison.Names qualified as Names
import Unison.Prelude
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference qualified as Reference
@ -35,19 +33,16 @@ import Unison.Util.Relation qualified as Relation
handleNamespaceDependencies :: Maybe Path.Path' -> Cli.Cli ()
handleNamespaceDependencies namespacePath' = do
Cli.Env {codebase} <- ask
path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath'
pp <- maybe Cli.getCurrentProjectPath Cli.resolvePath' namespacePath'
let pb = pp ^. #branch
branch <-
Cli.getMaybeBranch0At path & onNothingM do
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath (Path.absoluteToPath' path)))
Cli.getMaybeBranch0FromProjectPath pp & onNothingM do
Cli.returnEarly (Output.BranchEmpty (Output.WhichBranchEmptyPath pp))
externalDependencies <-
Cli.runTransaction (namespaceDependencies codebase branch)
currentPPED <- Cli.currentPrettyPrintEnvDecl
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
globalPPED <- Cli.prettyPrintEnvDeclFromNames globalNames
-- We explicitly include a global unsuffixified fallback on namespace dependencies since
-- the things we want names for are obviously outside of our scope.
let ppeWithFallback = PPED.unsuffixifiedPPE $ PPED.addFallback globalPPED currentPPED
Cli.respondNumbered $ Output.ListNamespaceDependencies ppeWithFallback path externalDependencies
pped <- Cli.projectBranchPPED pb
let ppe = PPED.unsuffixifiedPPE pped
Cli.respondNumbered $ Output.ListNamespaceDependencies ppe pp externalDependencies
-- | Check the dependencies of all types and terms in the current namespace,
-- returns a map of dependencies which do not have a name within the current namespace,

140
unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs
View File

@ -5,24 +5,21 @@ module Unison.Codebase.Editor.HandleInput.ProjectClone
where
import Control.Lens (_2)
import Control.Monad.Reader (ask)
import Data.These (These (..))
import Data.UUID.V4 qualified as UUID
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
import U.Codebase.Sqlite.DbId qualified as Sqlite
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli (updateAt)
import Unison.Cli.ProjectUtils (projectBranchPath)
import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch)
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path (Path)
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
import Unison.Sqlite qualified as Sqlite
@ -39,9 +36,9 @@ data RemoteProjectKey
-- | Clone a remote branch.
handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
handleClone remoteNames0 maybeLocalNames0 = do
maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
currentProjectBranch <- Cli.getCurrentProjectAndBranch
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0
localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0
cloneInto localNames1 resolvedRemoteNames.branch
data ResolvedRemoteNames = ResolvedRemoteNames
@ -78,63 +75,59 @@ data ResolvedRemoteNamesFrom
-- otherwise abort
resolveRemoteNames ::
Share.IncludeSquashedHead ->
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
ProjectAndBranchNames ->
Cli ResolvedRemoteNames
resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
case maybeCurrentProjectBranch of
Nothing -> resolveP remoteProjectName
Just (currentProjectAndBranch, _path) ->
case projectNameUserSlug remoteProjectName of
Nothing -> resolveB remoteBranchName
Just _ ->
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
Nothing -> resolveP remoteProjectName
Just remoteBranchProjectId -> do
-- Fetching these in parallel would be an improvement
maybeRemoteProject <- Share.getProjectByName remoteProjectName
maybeRemoteBranch <-
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
Share.GetProjectBranchResponseBranchNotFound -> Nothing
Share.GetProjectBranchResponseProjectNotFound -> Nothing
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
case (maybeRemoteProject, maybeRemoteBranch) of
(Just remoteProject, Nothing) -> do
let remoteProjectId = remoteProject.projectId
let remoteProjectName = remoteProject.projectName
let remoteBranchName = unsafeFrom @Text "main"
remoteBranch <-
ProjectUtils.expectRemoteProjectBranchByName
includeSquashed
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
pure
ResolvedRemoteNames
{ branch = remoteBranch,
from = ResolvedRemoteNamesFrom'Project
}
(Nothing, Just remoteBranch) ->
pure
ResolvedRemoteNames
{ branch = remoteBranch,
from = ResolvedRemoteNamesFrom'Branch
}
-- Treat neither existing and both existing uniformly as "ambiguous input"
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
-- wouldn't help, because we did enough work to know neither thing exists"
_ -> do
branchProjectName <-
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
Cli.returnEarly $
Output.AmbiguousCloneRemote
remoteProjectName
(ProjectAndBranch branchProjectName remoteBranchName)
resolveRemoteNames includeSquashed currentProjectAndBranch = \case
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do
case projectNameUserSlug remoteProjectName of
Nothing -> resolveB remoteBranchName
Just _ ->
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
Nothing -> resolveP remoteProjectName
Just remoteBranchProjectId -> do
-- Fetching these in parallel would be an improvement
maybeRemoteProject <- Share.getProjectByName remoteProjectName
maybeRemoteBranch <-
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
Share.GetProjectBranchResponseBranchNotFound -> Nothing
Share.GetProjectBranchResponseProjectNotFound -> Nothing
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
case (maybeRemoteProject, maybeRemoteBranch) of
(Just remoteProject, Nothing) -> do
let remoteProjectId = remoteProject.projectId
let remoteProjectName = remoteProject.projectName
let remoteBranchName = unsafeFrom @Text "main"
remoteBranch <-
ProjectUtils.expectRemoteProjectBranchByName
includeSquashed
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
pure
ResolvedRemoteNames
{ branch = remoteBranch,
from = ResolvedRemoteNamesFrom'Project
}
(Nothing, Just remoteBranch) ->
pure
ResolvedRemoteNames
{ branch = remoteBranch,
from = ResolvedRemoteNamesFrom'Branch
}
-- Treat neither existing and both existing uniformly as "ambiguous input"
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
-- wouldn't help, because we did enough work to know neither thing exists"
_ -> do
branchProjectName <-
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
Cli.returnEarly $
Output.AmbiguousCloneRemote
remoteProjectName
(ProjectAndBranch branchProjectName remoteBranchName)
ProjectAndBranchNames'Unambiguous (This p) -> resolveP p
ProjectAndBranchNames'Unambiguous (That b) -> resolveB b
ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b
where
resolveB branchName = do
(currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
remoteProjectId <-
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do
Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch)
@ -181,11 +174,11 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
-- `clone @foo/bar` resulted in treating `@foo/bar` as a contributor branch of the current project, then it is as if
-- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`.
resolveLocalNames ::
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
ResolvedRemoteNames ->
Maybe ProjectAndBranchNames ->
Cli (ProjectAndBranch LocalProjectKey ProjectBranchName)
resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames =
resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames =
resolve case maybeLocalNames of
Nothing ->
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
@ -199,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
resolve names =
case names of
ProjectAndBranchNames'Ambiguous localProjectName localBranchName ->
case maybeCurrentProjectBranch of
Nothing -> resolveP localProjectName
Just (ProjectAndBranch currentProject _, _path) -> do
Cli.returnEarly $
Output.AmbiguousCloneLocal
(ProjectAndBranch localProjectName remoteBranchName)
(ProjectAndBranch currentProject.name localBranchName)
ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do
Cli.returnEarly $
Output.AmbiguousCloneLocal
(ProjectAndBranch localProjectName remoteBranchName)
(ProjectAndBranch currentProject.name localBranchName)
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
@ -215,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
go (LocalProjectKey'Name localProjectName) remoteBranchName
resolveB localBranchName = do
(ProjectAndBranch currentProject _, _path) <-
maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
go (LocalProjectKey'Project currentProject) localBranchName
resolvePB localProjectName localBranchName =
@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do
pure (localProjectId, localProjectName)
Right localProject -> pure (localProject.projectId, localProject.name)
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
causalHashId <- Q.expectCausalHashIdByCausalHash branchHead
let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName)
Queries.insertProjectBranch
description
causalHashId
Sqlite.ProjectBranch
{ projectId = localProjectId,
branchId = localBranchId,
@ -277,12 +269,8 @@ cloneInto localProjectBranch remoteProjectBranch = do
localProjectBranch.branch
)
-- Manipulate the root namespace and cd
Cli.Env {codebase} <- ask
theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead)
let path = projectBranchPath (over #project fst localProjectAndBranch)
Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch)
Cli.cd path
let newProjectAndBranch = (over #project fst localProjectAndBranch)
Cli.switchProject newProjectAndBranch
-- Return the remote project id associated with the given project branch
loadAssociatedRemoteProjectId ::

79
unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs
View File

@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate
)
where
import Control.Lens
import Control.Monad.Reader (ask)
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Data.UUID.V4 qualified as UUID
import System.Random.Shuffle qualified as RandomShuffle
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash)
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
import Unison.Cli.ProjectUtils (projectBranchPath)
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Causal qualified as Causal
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude
@ -55,14 +55,12 @@ import Witch (unsafeFrom)
--
-- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too
-- much time getting everything perfectly correct before we get there.
projectCreate :: Bool -> Maybe ProjectName -> Cli ()
projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
projectCreate tryDownloadingBase maybeProjectName = do
projectId <- liftIO (ProjectId <$> UUID.nextRandom)
branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom)
let branchName = unsafeFrom @Text "main"
(_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash
projectName <-
(project, branch) <-
case maybeProjectName of
Nothing -> do
randomProjectNames <- liftIO generateRandomProjectNames
@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do
let loop = \case
[] -> error (reportBug "E066388" "project name supply is supposed to be infinite")
projectName : projectNames ->
Queries.projectExistsByName projectName >>= \case
False -> do
Ops.insertProjectAndBranch projectId projectName branchId branchName
pure projectName
True -> loop projectNames
Queries.loadProjectByName projectName >>= \case
Nothing -> do
(project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
pure (project, branch)
Just _project -> loop projectNames
loop randomProjectNames
Just projectName -> do
Cli.runTransactionWithRollback \rollback -> do
Queries.projectExistsByName projectName >>= \case
False -> do
Ops.insertProjectAndBranch projectId projectName branchId branchName
pure projectName
Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
True -> rollback (Output.ProjectNameAlreadyExists projectName)
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
Cli.cd path
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)
maybeBaseLatestReleaseBranchObject <-
if tryDownloadingBase
@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do
pure maybeBaseLatestReleaseBranchObject
else pure Nothing
let projectBranchObject =
case maybeBaseLatestReleaseBranchObject of
Nothing -> Branch.empty0
Just baseLatestReleaseBranchObject ->
let -- lib.base
projectBranchLibBaseObject =
over
Branch.children
(Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject)
Branch.empty0
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
in over
Branch.children
(Map.insert NameSegment.libSegment projectBranchLibObject)
Branch.empty0
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do
-- lib.base
let projectBranchLibBaseObject =
Branch.empty0
& Branch.children
. at NameSegment.baseSegment
.~ Just baseLatestReleaseBranchObject
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
let branchWithBase =
Branch.empty
& Branch.history
. Causal.head_
. Branch.children
. at NameSegment.libSegment
.~ Just projectBranchLibObject
Cli.Env {codebase} <- ask
liftIO $ Codebase.putBranch codebase branchWithBase
Cli.runTransaction $ do
baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase)
Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId
Cli.respond Output.HappyCoding
where
reflogDescription =
case maybeProjectName of
Nothing -> "project.create"
Just projectName -> "project.create " <> into @Text projectName
pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}
-- An infinite list of random project names that looks like
--

11
unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectRename.hs
View File

@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename
)
where
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Prelude
import Unison.Project (ProjectName)
import Unison.Project (ProjectAndBranch (..), ProjectName)
handleProjectRename :: ProjectName -> Cli ()
handleProjectRename newName = do
project <- ProjectUtils.expectCurrentProject
let oldName = project ^. #name
ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch
let oldName = project.name
when (oldName /= newName) do
Cli.runTransactionWithRollback \rollback -> do
Queries.loadProjectByName newName >>= \case
Just _ -> rollback (Output.ProjectNameAlreadyExists newName)
Nothing -> Queries.renameProject (project ^. #projectId) newName
Nothing -> Queries.renameProject project.projectId newName
Cli.respond (Output.RenamedProject oldName newName)

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

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

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

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

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

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

60
unison-cli/src/Unison/Codebase/Editor/HandleInput/Reflogs.hs Normal file
View File

@ -0,0 +1,60 @@
-- | Helpers for working with various kinds of reflogs.
module Unison.Codebase.Editor.HandleInput.Reflogs
( showProjectBranchReflog,
showProjectReflog,
showGlobalReflog,
)
where
import Control.Monad.Reader
import Data.Time (getCurrentTime)
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Project (Project)
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Prelude
import Unison.Sqlite qualified as Sqlite
showProjectBranchReflog :: Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> Cli ()
showProjectBranchReflog mayProjectAndBranch = do
ProjectAndBranch _project branch <- case mayProjectAndBranch of
Nothing -> Cli.getCurrentProjectAndBranch
Just pab -> ProjectUtils.resolveProjectBranch (second Just pab)
reflogHelper (\n -> Codebase.getProjectBranchReflog n (branch ^. #branchId))
showProjectReflog :: Maybe ProjectName -> Cli ()
showProjectReflog mayProject = do
ProjectAndBranch project _ <- ProjectUtils.resolveProjectBranch (ProjectAndBranch mayProject Nothing)
reflogHelper (\n -> Codebase.getProjectReflog n (project ^. #projectId))
showGlobalReflog :: Cli ()
showGlobalReflog = do
reflogHelper Codebase.getGlobalReflog
reflogHelper :: (Int -> Sqlite.Transaction [ProjectReflog.Entry Project ProjectBranch CausalHash]) -> Cli ()
reflogHelper getEntries = do
let numEntriesToShow = 500
entries <-
Cli.runTransaction $ do
schLength <- Codebase.branchHashLength
entries <- getEntries numEntriesToShow
entries
& (fmap . fmap) (\ch -> (ch, SCH.fromHash schLength ch))
& pure
let moreEntriesToLoad =
if length entries == numEntriesToShow
then Output.MoreEntriesThanShown
else Output.AllEntriesShown
mayNow <-
asks Cli.isTranscriptTest >>= \case
True -> pure Nothing
False -> Just <$> liftIO getCurrentTime
Cli.respondNumbered $ Output.ShowProjectBranchReflog mayNow moreEntriesToLoad entries

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

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

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

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

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

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

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

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

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

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

71
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

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

52
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Output
TestReportStats (..),
TodoOutput (..),
todoOutputIsEmpty,
MoreEntriesThanShown (..),
UndoFailureReason (..),
ShareError (..),
UpdateOrUpgrade (..),
@ -29,6 +30,7 @@ import U.Codebase.Branch.Diff (NameChanges)
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import Unison.Auth.Types (CredentialFailure)
import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget)
import Unison.Cli.Share.Projects.Types qualified as Share
@ -43,10 +45,11 @@ import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
import Unison.Codebase.Path (Path')
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.PushBehavior (PushBehavior)
import Unison.Codebase.ProjectPath (Project, ProjectBranch, ProjectPath)
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
import Unison.CommandLine.InputPattern qualified as Input
import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
@ -99,25 +102,25 @@ type NumberedArgs = [StructuredArgument]
type HashLength = Int
data NumberedOutput
= ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
= ShowDiffNamespace (Either ShortCausalHash ProjectPath) (Either ShortCausalHash ProjectPath) PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
| ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
| ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
| ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
| ShowDiffAfterModifyBranch Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
| ShowDiffAfterMerge
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
Path.Absolute
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
ProjectPath
PPE.PrettyPrintEnv
(BranchDiffOutput Symbol Ann)
| ShowDiffAfterMergePropagate
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
Path.Absolute
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
ProjectPath
Path.Path'
PPE.PrettyPrintEnv
(BranchDiffOutput Symbol Ann)
| ShowDiffAfterMergePreview
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
Path.Absolute
(Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
ProjectPath
PPE.PrettyPrintEnv
(BranchDiffOutput Symbol Ann)
| ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
@ -150,8 +153,12 @@ data NumberedOutput
| -- | List all direct dependencies which don't have any names in the current branch
ListNamespaceDependencies
PPE.PrettyPrintEnv -- PPE containing names for everything from the root namespace.
Path.Absolute -- The namespace we're checking dependencies for.
ProjectPath -- The namespace we're checking dependencies for.
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
| ShowProjectBranchReflog
(Maybe UTCTime {- current time, omitted in transcript tests to be more deterministic -})
MoreEntriesThanShown
[ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash)]
data TodoOutput = TodoOutput
{ dependentsOfTodo :: !(Set TermReferenceId),
@ -286,7 +293,7 @@ data Output
-- and a nicer render.
BustedBuiltins (Set Reference) (Set Reference)
| ShareError ShareError
| ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
| ViewOnShare (URI, ProjectName, ProjectBranchName)
| NoConfiguredRemoteMapping PushPull Path.Absolute
| ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String
| TermMissingType Reference
@ -304,14 +311,10 @@ data Output
| AboutToMerge
| -- | Indicates a trivial merge where the destination was empty and was just replaced.
MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
| MergeAlreadyUpToDate
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
(Either Path' (ProjectAndBranch ProjectName ProjectBranchName))
| MergeAlreadyUpToDate BranchRelativePath BranchRelativePath
| -- This will replace the above once `merge.old` is deleted
MergeAlreadyUpToDate2 !MergeSourceAndTarget
| PreviewMergeAlreadyUpToDate
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
| PreviewMergeAlreadyUpToDate ProjectPath ProjectPath
| NotImplemented
| NoBranchWithHash ShortCausalHash
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
@ -323,10 +326,8 @@ data Output
| BadName Text
| CouldntLoadBranch CausalHash
| HelpMessage Input.InputPattern
| NamespaceEmpty (NonEmpty AbsBranchId)
| NamespaceEmpty (NonEmpty (Either ShortCausalHash ProjectPath))
| NoOp
| -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
RefusedToPush PushBehavior (WriteRemoteNamespace Void)
| -- | @GistCreated repo@ means a causal was just published to @repo@.
GistCreated (ReadRemoteNamespace Void)
| -- | Directs the user to URI to begin an authorization flow.
@ -409,7 +410,6 @@ data Output
| UpdateIncompleteConstructorSet UpdateOrUpgrade Name (Map ConstructorId Name) (Maybe Int)
| UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment
| UpgradeSuccess !NameSegment !NameSegment
| LooseCodePushDeprecated
| MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName
| MergeSuccess !MergeSourceAndTarget
| MergeSuccessFastForward !MergeSourceAndTarget
@ -429,6 +429,9 @@ data Output
| NoMergeInProgress
| Output'DebugSynhashTerm !TermReference !Hash !Text
data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown
deriving (Eq, Show)
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
-- | What did we create a project branch from?
@ -446,12 +449,10 @@ data CreatedProjectBranchFrom
-- | A branch was empty. But how do we refer to that branch?
data WhichBranchEmpty
= WhichBranchEmptyHash ShortCausalHash
| WhichBranchEmptyPath Path'
| WhichBranchEmptyPath ProjectPath
data ShareError
= ShareErrorCheckAndSetPush Sync.CheckAndSetPushError
| ShareErrorDownloadEntities Share.DownloadEntitiesError
| ShareErrorFastForwardPush Sync.FastForwardPushError
= ShareErrorDownloadEntities Share.DownloadEntitiesError
| ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError
| ShareErrorPull Sync.PullError
| ShareErrorTransport Sync.CodeserverTransportError
@ -584,7 +585,6 @@ isFailure o = case o of
TermMissingType {} -> True
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
NamespaceEmpty {} -> True
RefusedToPush {} -> True
GistCreated {} -> False
InitiateAuthFlow {} -> False
UnknownCodeServer {} -> True
@ -649,7 +649,6 @@ isFailure o = case o of
ProjectHasNoReleases {} -> True
UpgradeFailure {} -> True
UpgradeSuccess {} -> False
LooseCodePushDeprecated -> True
MergeFailure {} -> True
MergeSuccess {} -> False
MergeSuccessFastForward {} -> False
@ -692,3 +691,4 @@ isNumberedFailure = \case
ListNamespaceDependencies {} -> False
TestResults _ _ _ _ _ fails -> not (null fails)
Output'Todo {} -> False
ShowProjectBranchReflog {} -> False

12
unison-cli/src/Unison/Codebase/Editor/Propagate.hs
View File

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

25
unison-cli/src/Unison/Codebase/Editor/UriParser.hs
View File

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

60
unison-cli/src/Unison/Codebase/TranscriptParser.hs
View File

@ -28,11 +28,11 @@ import Data.Configurator qualified as Configurator
import Data.Configurator.Types (Config)
import Data.IORef
import Data.List (isSubsequenceOf)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Text qualified as Text
import Data.These (These (..))
import Data.UUID.V4 qualified as UUID
import Ki qualified
import Network.HTTP.Client qualified as HTTP
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
@ -41,7 +41,6 @@ import System.IO qualified as IO
import System.IO.Error (catchIOError)
import Text.Megaparsec qualified as P
import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
@ -51,15 +50,13 @@ import Unison.Auth.Tokens qualified as AuthN
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..))
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Verbosity (Verbosity, isSilent)
import Unison.Codebase.Verbosity qualified as Verbosity
@ -68,10 +65,11 @@ import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName))
import Unison.CommandLine.InputPatterns (validInputs)
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
import Unison.CommandLine.Welcome (asciiartUnison)
import Unison.Core.Project (ProjectBranchName, ProjectName (..))
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous), ProjectBranchName, ProjectName)
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndBranchNames'Unambiguous))
import Unison.Runtime.Interface qualified as RTI
import Unison.Server.Backend qualified as Backend
import Unison.Server.CodebaseServer qualified as Server
@ -110,8 +108,7 @@ data UcmLine
-- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>).
data UcmContext
= UcmContextLooseCode Path.Absolute
| UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
= UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
data APIRequest
= GetRequest Text
@ -133,9 +130,7 @@ instance Show UcmLine where
UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
UcmComment txt -> "--" ++ Text.unpack txt
where
showContext = \case
UcmContextLooseCode path -> show path
UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch)
showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
instance Show Stanza where
show s = case s of
@ -200,19 +195,20 @@ type TranscriptRunner =
withTranscriptRunner ::
forall m r.
(UnliftIO.MonadUnliftIO m) =>
Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} ->
Verbosity ->
UCMVersion ->
FilePath ->
Maybe FilePath ->
(TranscriptRunner -> m r) ->
m r
withTranscriptRunner verbosity ucmVersion nrtp configFile action = do
withTranscriptRunner isTest verbosity ucmVersion nrtp configFile action = do
withRuntimes nrtp \runtime sbRuntime nRuntime -> withConfig \config -> do
action \transcriptName transcriptSrc (codebaseDir, codebase) -> do
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase \baseUrl -> do
let parsed = parse transcriptName transcriptSrc
result <- for parsed \stanzas -> do
liftIO $ run verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl)
liftIO $ run isTest verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl)
pure $ join @(Either TranscriptError) result
where
withRuntimes ::
@ -237,6 +233,7 @@ withTranscriptRunner verbosity ucmVersion nrtp configFile action = do
(\(config, _cancelConfig) -> action (Just config))
run ::
Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} ->
Verbosity ->
FilePath ->
[Stanza] ->
@ -248,9 +245,13 @@ run ::
UCMVersion ->
Text ->
IO (Either TranscriptError Text)
run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try $ Ki.scoped \scope -> do
run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try do
httpManager <- HTTP.newManager HTTP.defaultManagerSettings
let initialPath = Path.absoluteEmpty
(initialPP, emptyCausalHashId) <- Codebase.runTransaction codebase do
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
initialPP <- Codebase.expectCurrentProjectPath
pure (initialPP, emptyCausalHashId)
unless (isSilent verbosity) . putPrettyLn $
Pretty.lines
[ asciiartUnison,
@ -258,11 +259,6 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
"Running the provided transcript file...",
""
]
initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash
rootVar <- newEmptyTMVarIO
void $ Ki.fork scope do
root <- Codebase.getRootBranch codebase
atomically $ putTMVar rootVar root
mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey
credMan <- AuthN.newCredentialManager
let tokenProvider :: AuthN.TokenProvider
@ -346,15 +342,11 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
liftIO (output ("\n" <> show p))
awaitInput
p@(UcmCommand context lineTxt) -> do
curPath <- Cli.getCurrentPath
curPath <- Cli.getCurrentProjectPath
-- We're either going to run the command now (because we're in the right context), else we'll switch to
-- the right context first, then run the command next.
maybeSwitchCommand <-
case context of
UcmContextLooseCode path ->
if curPath == path
then pure Nothing
else pure $ Just (SwitchBranchI (Path.absoluteToPath' path))
UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do
Project {projectId, name = projectName} <-
Q.loadProjectByName projectName
@ -369,12 +361,12 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
Nothing -> do
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName}
Q.insertProjectBranch projectBranch
Q.insertProjectBranch "Branch Created" emptyCausalHashId projectBranch
pure projectBranch
Just projBranch -> pure projBranch
let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId
pure
if curPath == ProjectUtils.projectBranchPath projectAndBranchIds
if (PP.toProjectAndBranch . PP.toIds $ curPath) == projectAndBranchIds
then Nothing
else Just (ProjectSwitchI (ProjectAndBranchNames'Unambiguous (These projectName branchName)))
case maybeSwitchCommand of
@ -387,7 +379,9 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
args -> do
liftIO (output ("\n" <> show p <> "\n"))
numberedArgs <- use #numberedArgs
liftIO (parseInput codebase curPath numberedArgs patternMap args) >>= \case
PP.ProjectAndBranch projId branchId <- PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack
let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId
liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args) >>= \case
-- invalid command is treated as a failure
Left msg -> do
liftIO $ writeIORef hasErrors True
@ -558,7 +552,8 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
sandboxedRuntime = sbRuntime,
nativeRuntime = nRuntime,
serverBaseUrl = Nothing,
ucmVersion
ucmVersion,
isTranscriptTest = isTest
}
let loop :: Cli.LoopState -> IO Text
@ -580,7 +575,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
texts <- readIORef out
pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
loop (Cli.loopState0 initialRootCausalHash rootVar initialPath)
loop (Cli.loopState0 (PP.toIds initialPP))
transcriptFailure :: IORef (Seq String) -> Text -> IO b
transcriptFailure out msg = do
@ -605,9 +600,8 @@ ucmLine = ucmCommand <|> ucmComment
P.try do
contextString <- P.takeWhile1P Nothing (/= '>')
context <-
case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of
(Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch))
(Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs)
case (tryFrom @Text contextString) of
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
_ -> fail "expected project/branch or absolute path"
void $ lineToken $ word ">"
pure context

25
unison-cli/src/Unison/CommandLine.hs
View File

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

135
unison-cli/src/Unison/CommandLine/BranchRelativePath.hs
View File

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

32
unison-cli/src/Unison/CommandLine/Completion.hs
View File

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

13
unison-cli/src/Unison/CommandLine/FZFResolvers.hs
View File

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

12
unison-cli/src/Unison/CommandLine/InputPattern.hs
View File

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

403
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -119,7 +119,10 @@ module Unison.CommandLine.InputPatterns
upgradeCommitInputPattern,
view,
viewGlobal,
viewReflog,
deprecatedViewRootReflog,
branchReflog,
projectReflog,
globalReflog,
-- * Misc
formatStructuredArgument,
@ -136,7 +139,6 @@ module Unison.CommandLine.InputPatterns
)
where
import Control.Lens (preview, review)
import Control.Lens.Cons qualified as Cons
import Data.Bitraversable (bitraverse)
import Data.List (intercalate)
@ -168,14 +170,13 @@ import Unison.Cli.Pretty
prettySlashProjectBranchName,
prettyURI,
)
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch.Merge qualified as Branch
import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input)
import Unison.Codebase.Editor.Input (BranchIdG (..), DeleteOutput (..), DeleteTarget (..), Input)
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.SlurpResult qualified as SR
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
@ -185,6 +186,8 @@ import Unison.Codebase.Editor.UriParser qualified as UriParser
import Unison.Codebase.Path (Path, Path')
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.PushBehavior qualified as PushBehavior
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
@ -213,7 +216,6 @@ import Unison.Project
Semver,
branchWithOptionalProjectParser,
)
import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
import Unison.Referent qualified as Referent
import Unison.Server.Backend (ShallowListEntry (..))
import Unison.Server.Backend qualified as Backend
@ -249,8 +251,14 @@ formatStructuredArgument schLength = \case
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
prefixBranchId :: Input.AbsBranchId -> Name -> Text
prefixBranchId branchId name = case branchId of
Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
Right pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
BranchAtSCH sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name)
BranchAtPath pathPrefix -> Name.toText (Path.prefixNameIfRel (Path.AbsolutePath' pathPrefix) name)
BranchAtProjectPath pp ->
pp
& PP.absPath_
%~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
& PP.toNames
& into @Text
entryToHQText :: Path' -> ShallowListEntry v Ann -> Text
entryToHQText pathArg =
@ -378,15 +386,6 @@ handleProjectArg =
SA.Project project -> pure project
otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType
handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject
handleLooseCodeOrProjectArg =
either
(\str -> maybe (Left $ expectedButActually' "a path or project branch" str) pure $ parseLooseCodeOrProject str)
\case
SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path
SA.ProjectBranch pb -> pure $ That pb
otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType
handleMaybeProjectBranchArg ::
I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
handleMaybeProjectBranchArg =
@ -481,8 +480,8 @@ handleSplit'Arg =
(first P.text . Path.parseSplit')
\case
SA.Name name -> pure $ Path.splitFromName' name
SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name
SA.NameWithBranchPrefix (Right prefix) name ->
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure $ Path.splitFromName' name
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
pure . Path.splitFromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg
@ -499,27 +498,35 @@ handleBranchIdArg =
either
(first P.text . Input.parseBranchId)
\case
SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path
SA.Name name -> pure . pure $ Path.fromName' name
SA.AbsolutePath path -> pure . BranchAtPath $ Path.absoluteToPath' path
SA.Name name -> pure . BranchAtPath $ Path.fromName' name
SA.NameWithBranchPrefix mprefix name ->
pure . pure . Path.fromName' $ foldr (Path.prefixNameIfRel . Path.AbsolutePath') name mprefix
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
pure $ case mprefix of
BranchAtSCH _sch -> BranchAtPath . Path.fromName' $ name
BranchAtPath prefix -> BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
BranchAtProjectPath pp ->
pp
& PP.absPath_
%~ (\pathPrefix -> Path.resolve pathPrefix (Path.fromName name))
& BranchAtProjectPath
SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
handleBranchIdOrProjectArg ::
-- | TODO: Maybe remove?
_handleBranchIdOrProjectArg ::
I.Argument ->
Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
handleBranchIdOrProjectArg =
_handleBranchIdOrProjectArg =
either
(\str -> maybe (Left $ expectedButActually' "a branch" str) pure $ branchIdOrProject str)
\case
SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash
SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path
SA.Name name -> pure . This . pure $ Path.fromName' name
SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name
SA.NameWithBranchPrefix (Right prefix) name ->
pure . This . pure . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.ProjectBranch pb -> pure $ pure pb
SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash
SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path
SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.ProjectBranch pb -> pure $ That pb
otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType
where
branchIdOrProject ::
@ -540,19 +547,21 @@ handleBranchIdOrProjectArg =
(Right bid, Left _) -> Just (This bid)
(Right bid, Right pr) -> Just (These bid pr)
handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) Input.BranchId2
handleBranchId2Arg =
either
Input.parseBranchId2
\case
SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash
SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path
SA.Name name -> pure . pure . LoosePath $ Path.fromName' name
SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name
SA.NameWithBranchPrefix (Right prefix) name ->
pure . pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.AbsolutePath path -> pure . pure . UnqualifiedPath $ Path.absoluteToPath' path
SA.Name name -> pure . pure . UnqualifiedPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . pure . UnqualifiedPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
pure . pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
case mproject of
Just proj -> pure . pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
Nothing -> pure . pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath
@ -560,13 +569,15 @@ handleBranchRelativePathArg =
either
parseBranchRelativePath
\case
SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path
SA.Name name -> pure . LoosePath $ Path.fromName' name
SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name
SA.NameWithBranchPrefix (Right prefix) name ->
pure . LoosePath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.AbsolutePath path -> pure . UnqualifiedPath $ Path.absoluteToPath' path
SA.Name name -> pure . UnqualifiedPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . UnqualifiedPath $ Path.fromName' name
SA.NameWithBranchPrefix (BranchAtPath prefix) name ->
pure . UnqualifiedPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.ProjectBranch (ProjectAndBranch mproject branch) ->
pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject
case mproject of
Just proj -> pure $ QualifiedBranchPath proj branch Path.absoluteEmpty
Nothing -> pure $ BranchPathInCurrentProject branch Path.absoluteEmpty
otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg
hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit'
@ -598,8 +609,8 @@ handleHashQualifiedSplit'Arg =
\case
SA.Name name -> pure $ Path.hqSplitFromName' name
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit' hqname
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
pure . hq'NameToSplit' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
SA.ShallowListEntry prefix entry ->
pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@ -621,8 +632,8 @@ handleHashQualifiedSplitArg =
pure
$ Path.hqSplitFromName' name
hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ hq'NameToSplit hqname
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
pure . hq'NameToSplit $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname
SA.ShallowListEntry _ entry -> pure . hq'NameToSplit $ shallowListEntryToHQ' entry
sr@(SA.SearchResult mpath result) ->
@ -644,8 +655,8 @@ handleShortHashOrHQSplit'Arg =
(first P.text . Path.parseShortHashOrHQSplit')
\case
SA.HashQualified name -> pure $ hqNameToSplit' name
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure . pure $ hq'NameToSplit' hqname
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
pure . pure $ hq'NameToSplit' (Path.prefixNameIfRel (Path.AbsolutePath' prefix) <$> hqname)
SA.ShallowListEntry prefix entry ->
pure . pure . hq'NameToSplit' . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@ -666,11 +677,11 @@ handleNameArg =
(first P.text . Name.parseTextEither . Text.pack)
\case
SA.Name name -> pure name
SA.NameWithBranchPrefix (Left _) name -> pure name
SA.NameWithBranchPrefix (Right prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure name
SA.NameWithBranchPrefix (BranchAtPath prefix) name -> pure $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname
SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname
SA.HashQualifiedWithBranchPrefix (Right prefix) hqname ->
SA.HashQualifiedWithBranchPrefix (BranchAtSCH _) hqname -> pure $ HQ'.toName hqname
SA.HashQualifiedWithBranchPrefix (BranchAtPath prefix) hqname ->
pure . Path.prefixNameIfRel (Path.AbsolutePath' prefix) $ HQ'.toName hqname
SA.ShallowListEntry prefix entry ->
pure . HQ'.toName . fmap (Path.prefixNameIfRel prefix) $ shallowListEntryToHQ' entry
@ -694,11 +705,11 @@ handlePullSourceArg =
otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg
handlePushTargetArg ::
I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName))
I.Argument -> Either (P.Pretty CT.ColorText) (These ProjectName ProjectBranchName)
handlePushTargetArg =
either
(\str -> maybe (Left $ expectedButActually' "a target to push to" str) pure $ parsePushTarget str)
$ fmap RemoteRepo.WriteRemoteProjectBranch . \case
$ \case
SA.Project project -> pure $ This project
SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch
otherNumArg -> Left $ wrongStructuredArgument "a target to push to" otherNumArg
@ -708,11 +719,6 @@ handlePushSourceArg =
either
(\str -> maybe (Left $ expectedButActually' "a source to push from" str) pure $ parsePushSource str)
\case
SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path
SA.Name name -> pure . Input.PathySource $ Path.fromName' name
SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name
SA.NameWithBranchPrefix (Right prefix) name ->
pure . Input.PathySource . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name
SA.Project project -> pure . Input.ProjySource $ This project
SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch
otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg
@ -1554,7 +1560,7 @@ deleteNamespaceForce =
deleteNamespaceParser :: Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input
deleteNamespaceParser insistence = \case
[Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
[p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p
[p] -> Input.DeleteI . DeleteTarget'Namespace insistence <$> (Just <$> handleSplitArg p)
args -> wrongArgsLength "exactly one argument" args
renameBranch :: InputPattern
@ -1587,7 +1593,7 @@ history =
)
\case
[src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src
[] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath)
[] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.currentPath)
args -> wrongArgsLength "no more than one argument" args
forkLocal :: InputPattern
@ -1663,8 +1669,8 @@ reset =
]
)
\case
[arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing
[arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1)
[resetTo] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> pure Nothing
[resetTo, branchToReset] -> Input.ResetI <$> handleBranchId2Arg resetTo <*> fmap pure (handleMaybeProjectBranchArg branchToReset)
args -> wrongArgsLength "one or two arguments" args
where
config =
@ -2076,10 +2082,15 @@ mergeOldSquashInputPattern =
<> "The resulting `dest` will have (at most) 1"
<> "additional history entry.",
parse = \case
[src] ->
Input.MergeLocalBranchI
<$> handleBranchRelativePathArg src
<*> pure Nothing
<*> pure Branch.SquashMerge
[src, dest] ->
Input.MergeLocalBranchI
<$> handleLooseCodeOrProjectArg src
<*> handleLooseCodeOrProjectArg dest
<$> handleBranchRelativePathArg src
<*> (Just <$> handleBranchRelativePathArg dest)
<*> pure Branch.SquashMerge
args -> wrongArgsLength "exactly two arguments" args
}
@ -2112,25 +2123,19 @@ mergeOldInputPattern =
),
( makeExample mergeOldInputPattern ["/topic", "foo/main"],
"merges the branch `topic` of the current project into the `main` branch of the project 'foo`"
),
( makeExample mergeOldInputPattern [".src"],
"merges `.src` namespace into the current namespace"
),
( makeExample mergeOldInputPattern [".src", ".dest"],
"merges `.src` namespace into the `dest` namespace"
)
]
)
( \case
[src] ->
Input.MergeLocalBranchI
<$> handleLooseCodeOrProjectArg src
<*> pure (This Path.relativeEmpty')
<$> handleBranchRelativePathArg src
<*> pure Nothing
<*> pure Branch.RegularMerge
[src, dest] ->
Input.MergeLocalBranchI
<$> handleLooseCodeOrProjectArg src
<*> handleLooseCodeOrProjectArg dest
<$> handleBranchRelativePathArg src
<*> (Just <$> handleBranchRelativePathArg dest)
<*> pure Branch.RegularMerge
args -> wrongArgsLength "one or two arguments" args
)
@ -2208,17 +2213,6 @@ mergeCommitInputPattern =
args -> wrongArgsLength "no arguments" args
}
parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject
parseLooseCodeOrProject inputString =
case (asLooseCode, asBranch) of
(Right path, Left _) -> Just (This path)
(Left _, Right branch) -> Just (That branch)
(Right path, Right branch) -> Just (These path branch)
(Left _, Left _) -> Nothing
where
asLooseCode = Path.parsePath' inputString
asBranch = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack inputString)
diffNamespace :: InputPattern
diffNamespace =
InputPattern
@ -2236,8 +2230,8 @@ diffNamespace =
]
)
( \case
[before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after
[before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath)
[before, after] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> handleBranchId2Arg after
[before] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> pure (Right . UnqualifiedPath $ Path.currentPath)
args -> wrongArgsLength "one or two arguments" args
)
where
@ -2265,9 +2259,9 @@ mergeOldPreviewInputPattern =
]
)
( \case
[src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty')
[src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing
[src, dest] ->
Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest
Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest)
args -> wrongArgsLength "one or two arguments" args
)
where
@ -2278,19 +2272,74 @@ mergeOldPreviewInputPattern =
branchInclusion = AllBranches
}
viewReflog :: InputPattern
viewReflog =
deprecatedViewRootReflog :: InputPattern
deprecatedViewRootReflog =
InputPattern
"reflog"
"deprecated.root-reflog"
[]
I.Visible
[]
"`reflog` lists the changes that have affected the root namespace"
( "`deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of "
<> makeExample branchReflog []
<> " which shows the reflog for the current project."
)
( \case
[] -> pure Input.ShowReflogI
[] -> pure Input.ShowRootReflogI
_ ->
Left . P.string $
I.patternName viewReflog ++ " doesn't take any arguments."
I.patternName deprecatedViewRootReflog ++ " doesn't take any arguments."
)
branchReflog :: InputPattern
branchReflog =
InputPattern
"branch.reflog"
["reflog.branch", "reflog"]
I.Visible
[]
( P.lines
[ "`branch.reflog` lists all the changes that have affected the current branch.",
"`branch.reflog /mybranch` lists all the changes that have affected /mybranch."
]
)
( \case
[] -> pure $ Input.ShowProjectBranchReflogI Nothing
[branchRef] -> Input.ShowProjectBranchReflogI <$> (Just <$> handleMaybeProjectBranchArg branchRef)
_ -> Left (I.help branchReflog)
)
projectReflog :: InputPattern
projectReflog =
InputPattern
"project.reflog"
["reflog.project"]
I.Visible
[]
( P.lines
[ "`project.reflog` lists all the changes that have affected any branches in the current project.",
"`project.reflog myproject` lists all the changes that have affected any branches in myproject."
]
)
( \case
[] -> pure $ Input.ShowProjectReflogI Nothing
[projectRef] -> Input.ShowProjectReflogI <$> (Just <$> handleProjectArg projectRef)
_ -> Left (I.help projectReflog)
)
globalReflog :: InputPattern
globalReflog =
InputPattern
"reflog.global"
[]
I.Visible
[]
( P.lines
[ "`reflog.global` lists all recent changes across all projects and branches."
]
)
( \case
[] -> pure $ Input.ShowGlobalReflogI
_ -> Left (I.help globalReflog)
)
edit :: InputPattern
@ -3164,13 +3213,12 @@ branchInputPattern =
help =
P.wrapColumn2
[ ("`branch foo`", "forks the current project branch to a new branch `foo`"),
("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"),
("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`")
("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`")
],
parse = \case
[source0, name] ->
Input.BranchI . Input.BranchSourceI'LooseCodeOrProject
<$> handleLooseCodeOrProjectArg source0
Input.BranchI . Input.BranchSourceI'UnresolvedProjectBranch
<$> handleMaybeProjectBranchArg source0
<*> handleMaybeProjectBranchArg name
[name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name
args -> wrongArgsLength "one or two arguments" args
@ -3471,7 +3519,10 @@ validInputs =
upgradeCommitInputPattern,
view,
viewGlobal,
viewReflog
deprecatedViewRootReflog,
branchReflog,
projectReflog,
globalReflog
]
-- | A map of all command patterns by pattern name or alias.
@ -3553,7 +3604,7 @@ namespaceOrProjectBranchArg config =
ArgumentType
{ typeName = "namespace or branch",
suggestions =
let namespaceSuggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p)
let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp)
in unionSuggestions
[ projectAndOrBranchSuggestions config,
namespaceSuggestions
@ -3579,8 +3630,8 @@ dependencyArg :: ArgumentType
dependencyArg =
ArgumentType
{ typeName = "project dependency",
suggestions = \q cb _http p -> Codebase.runTransaction cb do
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
suggestions = \q cb _http pp -> Codebase.runTransaction cb do
prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
fzfResolver = Just Resolvers.projectDependencyResolver
}
@ -3639,14 +3690,14 @@ projectAndOrBranchSuggestions ::
String ->
Codebase m v a ->
AuthenticatedHttpClient ->
Path.Absolute -> -- Current path
ProjectPath ->
m [Line.Completion]
projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do
case Text.uncons input of
-- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
-- handle "/<TAB>" and "/@<TAB>" inputs, which aren't valid branch names, but are valid branch prefixes. So,
-- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix.
Just ('/', input1) -> handleBranchesComplete input1 codebase path
Just ('/', input1) -> handleBranchesComplete input1 codebase pp
_ ->
case tryInto @ProjectAndBranchNames input of
-- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
@ -3667,12 +3718,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
Nothing -> pure []
Just project -> do
let projectId = project ^. #projectId
fmap (filterBranches config path) do
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
pure (map (projectBranchToCompletion projectName) branches)
-- This branch is probably dead due to intercepting inputs that begin with "/" above
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
handleBranchesComplete (into @Text branchName) codebase path
handleBranchesComplete (into @Text branchName) codebase pp
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
branches <-
Codebase.runTransaction codebase do
@ -3680,16 +3731,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
Nothing -> pure []
Just project -> do
let projectId = project ^. #projectId
fmap (filterBranches config path) do
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
pure (map (projectBranchToCompletion projectName) branches)
where
input = Text.strip . Text.pack $ inputStr
(mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of
LooseCodePath {} -> (Nothing, Nothing)
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
handleAmbiguousComplete ::
(MonadIO m) =>
Text ->
@ -3699,14 +3746,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
(branches, projects) <-
Codebase.runTransaction codebase do
branches <-
case mayCurrentProjectId of
Nothing -> pure []
Just currentProjectId ->
fmap (filterBranches config path) do
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
projects <- case (projectInclusion config, mayCurrentProjectId) of
(OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
(OnlyWithinCurrentProject, Nothing) -> pure []
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
projects <- case projectInclusion config of
OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
pure (branches, projects)
let branchCompletions = map currentProjectBranchToCompletion branches
@ -3780,28 +3823,28 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do
then projectCompletions
else branchCompletions ++ projectCompletions
handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion]
handleBranchesComplete branchName codebase path = do
-- Complete the text into a branch name within the provided project
handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
handleBranchesComplete branchName codebase pp = do
let projId = pp ^. #project . #projectId
branches <-
case preview ProjectUtils.projectBranchPathPrism path of
Nothing -> pure []
Just (ProjectAndBranch currentProjectId _, _) ->
Codebase.runTransaction codebase do
fmap (filterBranches config path) do
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
Codebase.runTransaction codebase do
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
pure (map currentProjectBranchToCompletion branches)
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
filterProjects projects =
case (mayCurrentProjectId, projectInclusion config) of
(_, AllProjects) -> projects
(Nothing, _) -> projects
(Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
(Just currentBranchId, OnlyWithinCurrentProject) ->
case (projectInclusion config) of
AllProjects -> projects
OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
OnlyWithinCurrentProject ->
projects
& List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
& List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
& maybeToList
PP.ProjectPath currentProjectId _currentBranchId _currentPath = PP.toIds pp
projectToCompletion :: Sqlite.Project -> Completion
projectToCompletion project =
Completion
@ -3825,28 +3868,22 @@ handleBranchesComplete ::
ProjectBranchSuggestionsConfig ->
Text ->
Codebase m v a ->
Path.Absolute ->
PP.ProjectPath ->
m [Completion]
handleBranchesComplete config branchName codebase path = do
handleBranchesComplete config branchName codebase pp = do
branches <-
case preview ProjectUtils.projectBranchPathPrism path of
Nothing -> pure []
Just (ProjectAndBranch currentProjectId _, _) ->
Codebase.runTransaction codebase do
fmap (filterBranches config path) do
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName)
Codebase.runTransaction codebase do
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith (pp ^. #project . #projectId) (Just branchName)
pure (map currentProjectBranchToCompletion branches)
filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
filterBranches config path branches =
case (mayCurrentBranchId, branchInclusion config) of
(_, AllBranches) -> branches
(Nothing, _) -> branches
(Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
filterBranches config pp branches =
case (branchInclusion config) of
AllBranches -> branches
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
where
(_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of
LooseCodePath {} -> (Nothing, Nothing)
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
currentBranchId = pp ^. #branch . #branchId
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
currentProjectBranchToCompletion (_, branchName) =
@ -3862,22 +3899,22 @@ branchRelativePathSuggestions ::
String ->
Codebase m v a ->
AuthenticatedHttpClient ->
Path.Absolute -> -- Current path
PP.ProjectPath ->
m [Line.Completion]
branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do
branchRelativePathSuggestions config inputStr codebase _httpClient pp = do
case parseIncrementalBranchRelativePath inputStr of
Left _ -> pure []
Right ibrp -> case ibrp of
BranchRelativePath.ProjectOrRelative _txt _path -> do
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
BranchRelativePath.ProjectOrPath' _txt _path -> do
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
pure (namespaceSuggestions ++ projectSuggestions)
BranchRelativePath.LooseCode _path ->
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
BranchRelativePath.OnlyPath' _path ->
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
BranchRelativePath.IncompleteProject _proj ->
projectNameSuggestions WithSlash inputStr codebase
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp
Just projectName -> do
branches <-
Codebase.runTransaction codebase do
@ -3885,44 +3922,15 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath =
Nothing -> pure []
Just project -> do
let projectId = project ^. #projectId
fmap (filterBranches config currentPath) do
fmap (filterBranches config pp) do
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
pure (map (projectBranchToCompletionWithSep projectName) branches)
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
mprojectBranch <- runMaybeT do
(projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId)
MaybeT (Queries.loadProjectBranch projectId branchId)
case mprojectBranch of
Nothing -> pure []
Just projectBranch -> do
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
map prefixPathSep
<$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath
BranchRelativePath.PathRelativeToCurrentBranch absPath -> Codebase.runTransaction codebase do
map prefixPathSep <$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.AbsolutePath' absPath) pp
BranchRelativePath.IncompletePath projStuff mpath -> do
Codebase.runTransaction codebase do
mprojectBranch <- runMaybeT do
case projStuff of
Left names@(ProjectAndBranch projectName branchName) -> do
(,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName)
Right branchName -> do
currentProjectId <- MaybeT (pure mayCurrentProjectId)
projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName)
pure (projectBranch, Right (projectBranch ^. #name))
case mprojectBranch of
Nothing -> pure []
Just (projectBranch, prefix) -> do
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
map (addBranchPrefix prefix)
<$> prefixCompleteNamespace
(maybe "" (Text.unpack . Path.toText' . Path.RelativePath') mpath)
branchPath
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" (Text.unpack . Path.toText' . Path.AbsolutePath') mpath) pp
where
(mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of
LooseCodePath {} -> (Nothing, Nothing)
ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId)
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
projectBranchToCompletionWithSep projectName (_, branchName) =
Completion
@ -4047,12 +4055,11 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do
parsePushSource :: String -> Maybe Input.PushSource
parsePushSource sourceStr =
fixup Input.ProjySource (tryFrom $ Text.pack sourceStr)
<|> fixup Input.PathySource (Path.parsePath' sourceStr)
where
fixup = either (const Nothing) . (pure .)
-- | Parse a push target.
parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName))
parsePushTarget :: String -> Maybe (These ProjectName ProjectBranchName)
parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack
parseHashQualifiedName ::

99
unison-cli/src/Unison/CommandLine/Main.hs
View File

@ -6,10 +6,13 @@ where
import Compat (withInterruptHandler)
import Control.Concurrent.Async qualified as Async
import Control.Exception (catch, displayException, finally, mask)
import Control.Lens (preview, (?~))
import Control.Lens ((?~))
import Control.Lens.Lens
import Crypto.Random qualified as Random
import Data.Configurator.Types (Config)
import Data.IORef
import Data.List.NonEmpty qualified as NEL
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Ki qualified
@ -18,24 +21,21 @@ import System.Console.Haskeline qualified as Line
import System.Console.Haskeline.History qualified as Line
import System.IO (hGetEcho, hPutStrLn, hSetEcho, stderr, stdin)
import System.IO.Error (isDoesNotExistError)
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Auth.CredentialManager (newCredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Auth.HTTPClient qualified as AuthN
import Unison.Auth.Tokens qualified as AuthN
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.Pretty (prettyProjectAndBranchName)
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
import Unison.Cli.Pretty qualified as P
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Editor.HandleInput qualified as HandleInput
import Unison.Codebase.Editor.Input (Event, Input (..))
import Unison.Codebase.Editor.Output (NumberedArgs, Output)
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Runtime
import Unison.CommandLine
import Unison.CommandLine.Completion (haskelineTabComplete)
@ -46,7 +46,6 @@ import Unison.CommandLine.Welcome qualified as Welcome
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal
import Unison.Project (ProjectAndBranch (..))
import Unison.Runtime.IOSource qualified as IOSource
import Unison.Server.CodebaseServer qualified as Server
import Unison.Symbol (Symbol)
@ -60,10 +59,11 @@ import UnliftIO.STM
getUserInput ::
Codebase IO Symbol Ann ->
AuthenticatedHttpClient ->
Path.Absolute ->
PP.ProjectPath ->
IO (Branch IO) ->
NumberedArgs ->
IO Input
getUserInput codebase authHTTPClient currentPath numberedArgs =
getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs =
Line.runInputT
settings
(haskelineCtrlCHandling go)
@ -78,23 +78,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
Just a -> pure a
go :: Line.InputT IO Input
go = do
promptString <-
case preview projectBranchPathPrism currentPath of
Nothing -> pure ((P.green . P.shown) currentPath)
Just (ProjectAndBranch projectId branchId, restPath) -> do
lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case
-- If the project branch has been deleted from sqlite, just show a borked prompt
Nothing -> P.red "???"
Just (projectName, branchName) ->
P.sep
" "
( catMaybes
[ Just (prettyProjectAndBranchName (ProjectAndBranch projectName branchName)),
case restPath of
Path.Empty -> Nothing
_ -> (Just . P.green . P.shown) restPath
]
)
let promptString = P.prettyProjectPath pp
let fullPrompt = P.toANSI 80 (promptString <> fromString prompt)
line <- Line.getInputLine fullPrompt
case line of
@ -102,7 +86,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
Just l -> case words l of
[] -> go
ws -> do
liftIO (parseInput codebase currentPath numberedArgs IP.patternMap ws) >>= \case
liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case
Left msg -> do
-- We still add history that failed to parse so the user can easily reload
-- the input and fix it.
@ -126,12 +110,20 @@ getUserInput codebase authHTTPClient currentPath numberedArgs =
historyFile = Just ".unisonHistory",
autoAddHistory = False
}
tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
tabComplete = haskelineTabComplete IP.patternMap codebase authHTTPClient pp
loopStateProjectPath ::
Codebase IO Symbol Ann ->
Cli.LoopState ->
IO PP.ProjectPath
loopStateProjectPath codebase loopState = do
let ppIds = NEL.head $ Cli.projectPathStack loopState
ppIds & PP.projectAndBranch_ %%~ \pabIds -> liftIO . Codebase.runTransaction codebase $ ProjectUtils.expectProjectAndBranchByIds pabIds
main ::
FilePath ->
Welcome.Welcome ->
Path.Absolute ->
PP.ProjectPathIds ->
Config ->
[Either Event Input] ->
Runtime.Runtime Symbol ->
@ -140,38 +132,18 @@ main ::
Codebase IO Symbol Ann ->
Maybe Server.BaseUrl ->
UCMVersion ->
(CausalHash -> STM ()) ->
(Path.Absolute -> STM ()) ->
(PP.ProjectPathIds -> IO ()) ->
ShouldWatchFiles ->
IO ()
main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do
rootVar <- newEmptyTMVarIO
initialRootCausalHash <- Codebase.runTransaction codebase Operations.expectRootCausalHash
main dir welcome ppIds config initialInputs runtime sbRuntime nRuntime codebase serverBaseUrl ucmVersion lspCheckForChanges shouldWatchFiles = Ki.scoped \scope -> do
_ <- Ki.fork scope do
root <- Codebase.getRootBranch codebase
atomically do
-- Try putting the root, but if someone else as already written over the root, don't
-- overwrite it.
void $ tryPutTMVar rootVar root
-- Pre-load the project root in the background so it'll be ready when a command needs it.
projectRoot <- Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch
-- Start forcing thunks in a background thread.
-- This might be overly aggressive, maybe we should just evaluate the top level but avoid
-- recursive "deep*" things.
UnliftIO.concurrently_
(UnliftIO.evaluate root)
(UnliftIO.evaluate projectRoot)
(UnliftIO.evaluate IOSource.typecheckedFile) -- IOSource takes a while to compile, we should start compiling it on startup
let initialState = Cli.loopState0 initialRootCausalHash rootVar initialPath
Ki.fork_ scope do
let loop lastRoot = do
-- This doesn't necessarily notify on _every_ update, but the LSP only needs the
-- most recent version at any given time, so it's fine to skip some intermediate
-- versions.
currentRoot <- atomically do
currentRoot <- readTMVar rootVar
guard $ Just currentRoot /= lastRoot
notifyBranchChange (Branch.headHash currentRoot)
pure (Just currentRoot)
loop currentRoot
loop Nothing
let initialState = Cli.loopState0 ppIds
eventQueue <- Q.newIO
initialInputsRef <- newIORef $ Welcome.run welcome ++ initialInputs
pageOutput <- newIORef True
@ -187,10 +159,14 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
getInput loopState = do
currentEcho <- hGetEcho stdin
liftIO $ restoreEcho currentEcho
let PP.ProjectAndBranch projId branchId = PP.toProjectAndBranch $ NonEmpty.head loopState.projectPathStack
let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId
pp <- loopStateProjectPath codebase loopState
getUserInput
codebase
authHTTPClient
(loopState ^. #currentPath)
pp
getProjectRoot
(loopState ^. #numberedArgs)
let loadSourceFile :: Text -> IO Cli.LoadSourceResult
loadSourceFile fname =
@ -258,7 +234,8 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
sandboxedRuntime = sbRuntime,
nativeRuntime = nRuntime,
serverBaseUrl,
ucmVersion
ucmVersion,
isTranscriptTest = False
}
(onInterrupt, waitForInterrupt) <- buildInterruptHandler
@ -267,6 +244,9 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
-- Handle inputs until @HaltRepl@, staying in the loop on Ctrl+C or synchronous exception.
let loop0 :: Cli.LoopState -> IO ()
loop0 s0 = do
-- It's always possible the previous command changed the branch head, so tell the LSP to check if the current
-- path or project has changed.
lspCheckForChanges (NEL.head $ Cli.projectPathStack s0)
let step = do
input <- awaitInput s0
(!result, resultState) <- Cli.runCli env s0 (HandleInput.loop input)
@ -284,7 +264,6 @@ main dir welcome initialPath config initialInputs runtime sbRuntime nRuntime cod
Text.hPutStrLn stderr ("Encountered exception:\n" <> Text.pack (displayException e))
loop0 s0
Right (Right (result, s1)) -> do
when ((s0 ^. #currentPath) /= (s1 ^. #currentPath :: Path.Absolute)) (atomically . notifyPathChange $ s1 ^. #currentPath)
case result of
Cli.Success () -> loop0 s1
Cli.Continue -> loop0 s1

191
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -37,14 +37,15 @@ import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Reference qualified as Reference
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import Unison.ABT qualified as ABT
import Unison.Auth.Types qualified as Auth
import Unison.Builtin.Decls qualified as DD
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
import Unison.Cli.Pretty
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
import Unison.Codebase.Editor.Input (BranchIdG (..))
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
( CreatedProjectBranchFrom (..),
@ -60,15 +61,12 @@ import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as E
import Unison.Codebase.Editor.Output.BranchDiff qualified as OBD
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..))
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
import Unison.Codebase.Editor.StructuredArgument qualified as SA
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
import Unison.Codebase.Patch qualified as Patch
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.PushBehavior qualified as PushBehavior
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.ShortCausalHash qualified as SCH
@ -90,7 +88,6 @@ import Unison.LabeledDependency as LD
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Names (Names (..))
import Unison.Names qualified as Names
import Unison.NamesWithHistory qualified as Names
@ -172,7 +169,7 @@ renderFileName dir = P.group . P.blue . fromString <$> shortenDirectory dir
notifyNumbered :: NumberedOutput -> (Pretty, NumberedArgs)
notifyNumbered = \case
ShowDiffNamespace oldPrefix newPrefix ppe diffOutput ->
showDiffNamespace ShowNumbers ppe oldPrefix newPrefix diffOutput
showDiffNamespace ShowNumbers ppe (either BranchAtSCH BranchAtProjectPath oldPrefix) (either BranchAtSCH BranchAtProjectPath newPrefix) diffOutput
ShowDiffAfterDeleteDefinitions ppe diff ->
first
( \p ->
@ -226,12 +223,12 @@ notifyNumbered = \case
<> "to run the tests."
<> "Or you can use"
<> IP.makeExample' IP.undo
<> " or"
<> IP.makeExample' IP.viewReflog
<> " or use a hash from "
<> IP.makeExample' IP.branchReflog
<> " to undo the results of this merge."
]
)
(showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
(showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput ->
first
( \p ->
@ -253,12 +250,12 @@ notifyNumbered = \case
<> "to run the tests."
<> "Or you can use"
<> IP.makeExample' IP.undo
<> " or"
<> IP.makeExample' IP.viewReflog
<> " or use a hash from "
<> IP.makeExample' IP.branchReflog
<> " to undo the results of this merge."
]
)
(showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
(showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
ShowDiffAfterMergePreview dest' destAbs ppe diffOutput ->
first
( \p ->
@ -268,7 +265,7 @@ notifyNumbered = \case
p
]
)
(showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
(showDiffNamespace ShowNumbers ppe (BranchAtProjectPath destAbs) (BranchAtProjectPath destAbs) diffOutput)
ShowDiffAfterUndo ppe diffOutput ->
first
(\p -> P.lines ["Here are the changes I undid", "", p])
@ -473,7 +470,7 @@ notifyNumbered = \case
)
where
switch = IP.makeExample IP.projectSwitch
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) ->
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) ->
( P.wrap
( openingLine
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
@ -513,10 +510,10 @@ notifyNumbered = \case
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
reset = IP.makeExample IP.reset
relPath0 = prettyPath path
absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path)
absPath0 = Path.Absolute path
ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
ListNamespaceDependencies ppe path' externalDependencies ->
( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyProjectPath path') $
List.intersperse spacer (externalDepsTable externalDependencies),
numberedArgs
)
@ -557,16 +554,17 @@ notifyNumbered = \case
& Set.toList
& fmap (\name -> formatNum (getNameNumber name) <> prettyName name)
& P.lines
ShowProjectBranchReflog now moreToShow entries -> displayProjectBranchReflogEntries now moreToShow entries
where
absPathToBranchId = Right
absPathToBranchId = BranchAtPath
undoTip :: P.Pretty P.ColorText
undoTip =
tip $
"You can use"
<> IP.makeExample' IP.undo
<> "or"
<> IP.makeExample' IP.viewReflog
<> " or use a hash from "
<> IP.makeExample' IP.branchReflog
<> "to undo this change."
notifyUser :: FilePath -> Output -> IO Pretty
@ -602,13 +600,13 @@ notifyUser dir = \case
pure
. P.warnCallout
$ "The namespace "
<> prettyBranchId p0
<> either prettySCH prettyProjectPath p0
<> " is empty. Was there a typo?"
ps ->
pure
. P.warnCallout
$ "The namespaces "
<> P.commas (prettyBranchId <$> ps)
<> P.commas (either prettySCH prettyProjectPath <$> ps)
<> " are empty. Was there a typo?"
LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
pure $
@ -801,7 +799,7 @@ notifyUser dir = \case
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
CreatedNewBranch path ->
pure $
"☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty."
"☝️ The namespace " <> prettyAbsolute path <> " is empty."
-- RenameOutput rootPath oldName newName r -> do
-- nameChange "rename" "renamed" oldName newName r
-- AliasOutput rootPath existingName newName r -> do
@ -819,9 +817,13 @@ notifyUser dir = \case
DeleteEverythingConfirmation ->
pure . P.warnCallout . P.lines $
[ "Are you sure you want to clear away everything?",
"You could use "
<> IP.makeExample' IP.projectCreate
<> " to switch to a new project instead."
P.wrap
( "You could use "
<> IP.makeExample' IP.projectCreate
<> " to switch to a new project instead,"
<> " or delete the current branch with "
<> IP.makeExample' IP.deleteBranch
)
]
DeleteBranchConfirmation _uniqueDeletions -> error "todo"
-- let
@ -1329,9 +1331,9 @@ notifyUser dir = \case
MergeAlreadyUpToDate src dest ->
pure . P.callout "😶" $
P.wrap $
either prettyPath' prettyProjectAndBranchName dest
prettyBranchRelativePath dest
<> "was already up-to-date with"
<> P.group (either prettyPath' prettyProjectAndBranchName src <> ".")
<> P.group (prettyBranchRelativePath src <> ".")
MergeAlreadyUpToDate2 aliceAndBob ->
pure . P.callout "😶" $
P.wrap $
@ -1476,9 +1478,9 @@ notifyUser dir = \case
PreviewMergeAlreadyUpToDate src dest ->
pure . P.callout "😶" $
P.wrap $
prettyNamespaceKey dest
prettyProjectPath dest
<> "is already up-to-date with"
<> P.group (prettyNamespaceKey src <> ".")
<> P.group (prettyProjectPath src)
DumpNumberedArgs schLength args ->
pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
HelpMessage pat -> pure $ IP.showPatternHelp pat
@ -1533,11 +1535,6 @@ notifyUser dir = \case
<> ( terms <&> \(n, r) ->
prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r)
)
RefusedToPush pushBehavior path ->
(pure . P.warnCallout) case pushBehavior of
PushBehavior.ForcePush -> error "impossible: refused to push due to ForcePush?"
PushBehavior.RequireEmpty -> expectedEmptyPushDest path
PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path
GistCreated remoteNamespace ->
pure $
P.lines
@ -1599,10 +1596,7 @@ notifyUser dir = \case
PrintVersion ucmVersion -> pure (P.text ucmVersion)
ShareError shareError -> pure (prettyShareError shareError)
ViewOnShare shareRef ->
pure $
"View it here: " <> case shareRef of
Left repoPath -> prettyShareLink repoPath
Right branchInfo -> prettyRemoteBranchInfo branchInfo
pure $ "View it here: " <> prettyRemoteBranchInfo shareRef
IntegrityCheck result -> pure $ case result of
NoIntegrityErrors -> "🎉 No issues detected 🎉"
IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
@ -2078,16 +2072,6 @@ notifyUser dir = \case
<> P.group (P.text (NameSegment.toEscapedText new) <> ",")
<> "and removed"
<> P.group (P.text (NameSegment.toEscapedText old) <> ".")
LooseCodePushDeprecated ->
pure . P.warnCallout $
P.lines $
[ P.wrap $ "Unison Share's projects are now the new preferred way to store code, and storing code outside of a project has been deprecated.",
"",
P.wrap $ "Learn how to convert existing code into a project using this guide: ",
"https://www.unison-lang.org/docs/tooling/projects-library-migration/",
"",
"Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`"
]
MergeFailure path aliceAndBob temp ->
pure $
P.lines $
@ -2170,39 +2154,16 @@ notifyUser dir = \case
<> "Synhash tokens: "
<> P.text filename
expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
expectedEmptyPushDest namespace =
P.lines
[ "The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is not empty.",
"",
"Did you mean to use " <> IP.makeExample' IP.push <> " instead?"
]
expectedNonEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
expectedNonEmptyPushDest namespace =
P.lines
[ P.wrap ("The remote namespace " <> prettyWriteRemoteNamespace (absurd <$> namespace) <> " is empty."),
"",
P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?")
]
prettyShareError :: ShareError -> Pretty
prettyShareError =
P.fatalCallout . \case
ShareErrorCheckAndSetPush err -> prettyCheckAndSetPushError err
ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err
ShareErrorFastForwardPush err -> prettyFastForwardPushError err
ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err
ShareErrorPull err -> prettyPullError err
ShareErrorTransport err -> prettyTransportError err
ShareErrorUploadEntities err -> prettyUploadEntitiesError err
ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team."
prettyCheckAndSetPushError :: Share.CheckAndSetPushError -> Pretty
prettyCheckAndSetPushError = \case
Share.CheckAndSetPushError'UpdatePath repoInfo err -> prettyUpdatePathError repoInfo err
Share.CheckAndSetPushError'UploadEntities err -> prettyUploadEntitiesError err
prettyDownloadEntitiesError :: Share.DownloadEntitiesError -> Pretty
prettyDownloadEntitiesError = \case
Share.DownloadEntitiesNoReadPermission repoInfo -> noReadPermissionForRepo repoInfo
@ -2211,27 +2172,6 @@ prettyDownloadEntitiesError = \case
Share.DownloadEntitiesProjectNotFound project -> shareProjectNotFound project
Share.DownloadEntitiesEntityValidationFailure err -> prettyEntityValidationFailure err
prettyFastForwardPathError :: Share.Path -> Share.FastForwardPathError -> Pretty
prettyFastForwardPathError path = \case
Share.FastForwardPathError'InvalidParentage Share.InvalidParentage {child, parent} ->
P.lines
[ "The server detected an error in the history being pushed, please report this as a bug in ucm.",
"The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent
]
Share.FastForwardPathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
Share.FastForwardPathError'MissingDependencies dependencies -> needDependencies dependencies
Share.FastForwardPathError'NoHistory -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare path)
Share.FastForwardPathError'NoWritePermission path -> noWritePermissionForPath path
Share.FastForwardPathError'NotFastForward _hashJwt -> notFastForward path
Share.FastForwardPathError'UserNotFound -> shareUserNotFound (Share.pathRepoInfo path)
prettyFastForwardPushError :: Share.FastForwardPushError -> Pretty
prettyFastForwardPushError = \case
Share.FastForwardPushError'FastForwardPath path err -> prettyFastForwardPathError path err
Share.FastForwardPushError'GetCausalHash err -> prettyGetCausalHashByPathError err
Share.FastForwardPushError'NotFastForward path -> notFastForward path
Share.FastForwardPushError'UploadEntities err -> prettyUploadEntitiesError err
prettyGetCausalHashByPathError :: Share.GetCausalHashByPathError -> Pretty
prettyGetCausalHashByPathError = \case
Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermissionForPath sharePath
@ -2245,21 +2185,6 @@ prettyPullError = \case
Share.PullError'NoHistoryAtPath sharePath ->
P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath
prettyUpdatePathError :: Share.RepoInfo -> Share.UpdatePathError -> Pretty
prettyUpdatePathError repoInfo = \case
Share.UpdatePathError'HashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash} ->
case (expectedHash, actualHash) of
(Nothing, Just _) -> expectedEmptyPushDest (sharePathToWriteRemotePathShare sharePath)
_ ->
P.wrap $
P.text "It looks like someone modified"
<> prettySharePath sharePath
<> P.text "an instant before you. Pull and try again? 🤞"
Share.UpdatePathError'InvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
Share.UpdatePathError'MissingDependencies dependencies -> needDependencies dependencies
Share.UpdatePathError'NoWritePermission path -> noWritePermissionForPath path
Share.UpdatePathError'UserNotFound -> shareUserNotFound repoInfo
prettyUploadEntitiesError :: Share.UploadEntitiesError -> Pretty
prettyUploadEntitiesError = \case
Share.UploadEntitiesError'EntityValidationFailure validationFailureErr -> prettyEntityValidationFailure validationFailureErr
@ -2457,17 +2382,6 @@ shareUserNotFound :: Share.RepoInfo -> Pretty
shareUserNotFound repoInfo =
P.wrap ("User" <> prettyRepoInfo repoInfo <> "does not exist.")
sharePathToWriteRemotePathShare :: Share.Path -> WriteRemoteNamespace void
sharePathToWriteRemotePathShare sharePath =
-- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share
-- client code that doesn't know about WriteRemotePath
WriteRemoteNamespaceShare
WriteShareRemoteNamespace
{ server = RemoteRepo.DefaultCodeserver,
repo = ShareUserHandle $ Share.unRepoInfo (Share.pathRepoInfo sharePath),
path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath))
}
formatMissingStuff ::
(Show tm, Show typ) =>
[(HQ.HashQualified Name, tm)] ->
@ -3483,3 +3397,44 @@ listDependentsOrDependencies ppe labelStart label lds types terms =
P.indentN 2 . P.numberedListFrom (length types) $ c . prettyHashQualified <$> terms
]
c = P.syntaxToColor
displayProjectBranchReflogEntries ::
Maybe UTCTime ->
E.MoreEntriesThanShown ->
[ProjectReflog.Entry Project ProjectBranch (CausalHash, ShortCausalHash)] ->
(Pretty, NumberedArgs)
displayProjectBranchReflogEntries _ _ [] =
(P.warnCallout "The reflog is empty", mempty)
displayProjectBranchReflogEntries mayNow _ entries =
let (entryRows, numberedArgs) = foldMap renderEntry entries
rendered =
P.lines
[ header,
"",
P.numberedColumnNHeader (["Branch"] <> Monoid.whenM (isJust mayNow) ["When"] <> ["Hash", "Description"]) entryRows
]
in (rendered, numberedArgs)
where
header =
P.lines
[ P.wrap $
"Below is a record of recent changes, you can use "
<> IP.makeExample IP.reset ["#abcdef"]
<> " to reset the current branch to a previous state.",
"",
tip $ "Use " <> IP.makeExample IP.diffNamespace ["1", "7"] <> " to compare between points in history."
]
renderEntry :: ProjectReflog.Entry Project ProjectBranch (CausalHash, SCH.ShortCausalHash) -> ([[Pretty]], NumberedArgs)
renderEntry ProjectReflog.Entry {time, project, branch, toRootCausalHash = (toCH, toSCH), reason} =
( [ [prettyProjectAndBranchName $ ProjectAndBranch project.name branch.name]
<> ( mayNow
& foldMap (\now -> [prettyHumanReadableTime now time])
)
<> [P.blue (prettySCH toSCH), P.text $ truncateReason reason]
],
[SA.Namespace toCH]
)
truncateReason :: Text -> Text
truncateReason txt = case Text.splitAt 60 txt of
(short, "") -> short
(short, _) -> short <> "..."

31
unison-cli/src/Unison/LSP.hs
View File

@ -27,9 +27,8 @@ import Language.LSP.VFS
import Network.Simple.TCP qualified as TCP
import System.Environment (lookupEnv)
import System.IO (hPutStrLn)
import U.Codebase.HashTags
import Unison.Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Debug qualified as Debug
import Unison.LSP.CancelRequest (cancelRequestHandler)
@ -47,6 +46,7 @@ import Unison.LSP.NotificationHandlers qualified as Notifications
import Unison.LSP.Orphans ()
import Unison.LSP.Types
import Unison.LSP.UCMWorker (ucmWorker)
import Unison.LSP.Util.Signal (Signal)
import Unison.LSP.VFS qualified as VFS
import Unison.Parser.Ann
import Unison.Prelude
@ -61,8 +61,13 @@ getLspPort :: IO String
getLspPort = fromMaybe "5757" <$> lookupEnv "UNISON_LSP_PORT"
-- | Spawn an LSP server on the configured port.
spawnLsp :: LspFormattingConfig -> Codebase IO Symbol Ann -> Runtime Symbol -> STM CausalHash -> STM (Path.Absolute) -> IO ()
spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
spawnLsp ::
LspFormattingConfig ->
Codebase IO Symbol Ann ->
Runtime Symbol ->
Signal PP.ProjectPathIds ->
IO ()
spawnLsp lspFormattingConfig codebase runtime signal =
ifEnabled . TCP.withSocketsDo $ do
lspPort <- getLspPort
UnliftIO.handleIO (handleFailure lspPort) $ do
@ -82,7 +87,7 @@ spawnLsp lspFormattingConfig codebase runtime latestRootHash latestPath =
-- different un-saved state for the same file.
initVFS $ \vfs -> do
vfsVar <- newMVar vfs
void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath)
void $ runServerWith lspServerLogger lspClientLogger clientInput clientOutput (serverDefinition lspFormattingConfig vfsVar codebase runtime scope signal)
where
handleFailure :: String -> IOException -> IO ()
handleFailure lspPort ioerr =
@ -113,16 +118,15 @@ serverDefinition ::
Codebase IO Symbol Ann ->
Runtime Symbol ->
Ki.Scope ->
STM CausalHash ->
STM (Path.Absolute) ->
Signal PP.ProjectPathIds ->
ServerDefinition Config
serverDefinition lspFormattingConfig vfsVar codebase runtime scope latestRootHash latestPath =
serverDefinition lspFormattingConfig vfsVar codebase runtime scope signal =
ServerDefinition
{ defaultConfig = defaultLSPConfig,
configSection = "unison",
parseConfig = Config.parseConfig,
onConfigChange = Config.updateConfig,
doInitialize = lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath,
doInitialize = lspDoInitialize vfsVar codebase runtime scope signal,
staticHandlers = lspStaticHandlers lspFormattingConfig,
interpretHandler = lspInterpretHandler,
options = lspOptions
@ -134,12 +138,11 @@ lspDoInitialize ::
Codebase IO Symbol Ann ->
Runtime Symbol ->
Ki.Scope ->
STM CausalHash ->
STM (Path.Absolute) ->
Signal PP.ProjectPathIds ->
LanguageContextEnv Config ->
Msg.TMessage 'Msg.Method_Initialize ->
IO (Either Msg.ResponseError Env)
lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspContext _initMsg = do
lspDoInitialize vfsVar codebase runtime scope signal lspContext _initMsg = do
checkedFilesVar <- newTVarIO mempty
dirtyFilesVar <- newTVarIO mempty
ppedCacheVar <- newEmptyTMVarIO
@ -152,13 +155,13 @@ lspDoInitialize vfsVar codebase runtime scope latestRootHash latestPath lspConte
Env
{ ppedCache = atomically $ readTMVar ppedCacheVar,
currentNamesCache = atomically $ readTMVar currentNamesCacheVar,
currentPathCache = atomically $ readTMVar currentPathCacheVar,
currentProjectPathCache = atomically $ readTMVar currentPathCacheVar,
nameSearchCache = atomically $ readTMVar nameSearchCacheVar,
..
}
let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM
Ki.fork scope (lspToIO Analysis.fileAnalysisWorker)
Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar latestRootHash latestPath)
Ki.fork scope (lspToIO $ ucmWorker ppedCacheVar currentNamesCacheVar nameSearchCacheVar currentPathCacheVar signal)
pure $ Right $ env
-- | LSP request handlers that don't register/unregister dynamically

4
unison-cli/src/Unison/LSP/FileAnalysis.hs
View File

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

5
unison-cli/src/Unison/LSP/Formatting.hs
View File

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

8
unison-cli/src/Unison/LSP/Types.hs
View File

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

82
unison-cli/src/Unison/LSP/UCMWorker.hs
View File

@ -1,19 +1,18 @@
module Unison.LSP.UCMWorker where
import Control.Monad (guard)
import Control.Monad.State (liftIO)
import Control.Monad.Reader.Class (ask)
import Data.Functor (void)
import U.Codebase.HashTags
import Control.Monad.Reader
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.Path qualified as Path
import Unison.Debug qualified as Debug
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.LSP.Completion
import Unison.LSP.Types
import Unison.LSP.Util.Signal (Signal)
import Unison.LSP.Util.Signal qualified as Signal
import Unison.LSP.VFS qualified as VFS
import Unison.Names (Names)
import Unison.Prelude
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
@ -27,42 +26,43 @@ ucmWorker ::
TMVar PrettyPrintEnvDecl ->
TMVar Names ->
TMVar (NameSearch Sqlite.Transaction) ->
TMVar Path.Absolute ->
STM CausalHash ->
STM Path.Absolute ->
TMVar ProjectPath ->
Signal PP.ProjectPathIds ->
Lsp ()
ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar getLatestRoot getLatestPath = do
Env {codebase, completionsVar} <- ask
let loop :: (CausalHash, Path.Absolute) -> Lsp a
loop (currentRoot, currentPath) = do
Debug.debugM Debug.LSP "LSP path: " currentPath
currentBranch0 <- fmap Branch.head . liftIO $ (Codebase.getBranchAtPath codebase currentPath)
let currentNames = Branch.toNames currentBranch0
hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
let pped = PPED.makePPED (PPE.hqNamer hl currentNames) (PPE.suffixifyByHash currentNames)
atomically $ do
writeTMVar currentPathVar currentPath
writeTMVar currentNamesVar currentNames
writeTMVar ppedVar pped
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl currentNames)
-- Re-check everything with the new names and ppe
VFS.markAllFilesDirty
atomically do
writeTMVar completionsVar (namesToCompletionTree currentNames)
Debug.debugLogM Debug.LSP "LSP Initialized"
latest <- atomically $ do
latestRoot <- getLatestRoot
latestPath <- getLatestPath
guard $ (currentRoot /= latestRoot || currentPath /= latestPath)
pure (latestRoot, latestPath)
Debug.debugLogM Debug.LSP "LSP Change detected"
loop latest
(rootBranch, currentPath) <- atomically $ do
rootBranch <- getLatestRoot
currentPath <- getLatestPath
pure (rootBranch, currentPath)
loop (rootBranch, currentPath)
ucmWorker ppedVar currentNamesVar nameSearchCacheVar currentPathVar changeSignal = do
signalChanges <- Signal.subscribe changeSignal
loop signalChanges Nothing
where
loop :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp a
loop signalChanges currentBranch = do
Env {codebase, completionsVar} <- ask
getChanges signalChanges currentBranch >>= \case
(_newPP, Nothing) -> loop signalChanges currentBranch
(newPP, Just newBranch) -> do
let newBranch0 = Branch.head newBranch
let newNames = Branch.toNames newBranch0
hl <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength
let pped = PPED.makePPED (PPE.hqNamer hl newNames) (PPE.suffixifyByHash newNames)
atomically $ do
writeTMVar currentPathVar newPP
writeTMVar currentNamesVar newNames
writeTMVar ppedVar pped
writeTMVar nameSearchCacheVar (NameSearch.makeNameSearch hl newNames)
-- Re-check everything with the new names and ppe
VFS.markAllFilesDirty
atomically do
writeTMVar completionsVar (namesToCompletionTree newNames)
loop signalChanges (Just newBranch)
-- Waits for a possible change, then checks if there's actually any difference to the branches we care about.
-- If so, returns the new branch, otherwise Nothing.
getChanges :: STM PP.ProjectPathIds -> Maybe (Branch.Branch IO) -> Lsp (ProjectPath, Maybe (Branch.Branch IO))
getChanges signalChanges currentBranch = do
Env {codebase} <- ask
ppIds <- atomically signalChanges
pp <- liftIO . Codebase.runTransaction codebase $ Codebase.resolveProjectPathIds ppIds
atomically $ writeTMVar currentPathVar pp
newBranch <- fmap (fromMaybe Branch.empty) . liftIO $ Codebase.getBranchAtProjectPath codebase pp
pure $ (pp, if Just newBranch == currentBranch then Nothing else Just newBranch)
-- This is added in stm-2.5.1, remove this if we upgrade.
writeTMVar :: TMVar a -> a -> STM ()
writeTMVar var a =

74
unison-cli/src/Unison/LSP/Util/Signal.hs Normal file
View File

@ -0,0 +1,74 @@
-- | A transactional signal type.
-- Similar to a broadcast channel, but with better memory characteristics when you only care about the latest value.
--
-- Allows multiple consumers to detect the latest value of a signal, and to be notified when the signal changes.
module Unison.LSP.Util.Signal
( newSignalIO,
writeSignal,
writeSignalIO,
subscribe,
Signal,
)
where
import Control.Monad.STM qualified as STM
import Unison.Prelude
import UnliftIO.STM
newtype Signal a = Signal (TVar (Maybe a, Int))
-- | Create a new signal with an optional initial value.
newSignalIO :: (MonadIO m) => Maybe a -> m (Signal a)
newSignalIO a = do
tvar <- newTVarIO (a, 0)
pure (Signal tvar)
-- | Update the value of a signal, notifying all subscribers (even if the value didn't change)
writeSignal :: Signal a -> a -> STM ()
writeSignal (Signal signalVar) a = do
(_, n) <- readTVar signalVar
writeTVar signalVar (Just a, succ n)
-- | Update the value of a signal, notifying all subscribers (even if the value didn't change)
writeSignalIO :: (MonadIO m) => Signal a -> a -> m ()
writeSignalIO signal a = liftIO $ STM.atomically (writeSignal signal a)
-- | Subscribe to a signal, returning an STM action which will read the latest NEW value,
-- after successfully reading a new value, subsequent reads will retry until there's a new value written to the signal.
--
-- Each independent reader should have its own subscription.
--
-- >>> signal <- newSignalIO (Just "initial")
-- >>> subscriber1 <- subscribe signal
-- >>> subscriber2 <- subscribe signal
-- >>> -- Should return the initial value
-- >>> atomically (optional subscriber1)
-- >>> -- Should retry, since the signal hasn't changed.
-- >>> atomically (optional subscriber1)
-- >>> writeSignalIO signal "new value"
-- >>> -- Each subscriber should return the newest value
-- >>> ("sub1",) <$> atomically (optional subscriber1)
-- >>> ("sub2",) <$> atomically (optional subscriber2)
-- >>> -- Both should now retry
-- >>> ("sub1",) <$> atomically (optional subscriber1)
-- >>> ("sub2",) <$> atomically (optional subscriber2)
-- Just "initial"
-- Nothing
-- ("sub1",Just "new value")
-- ("sub2",Just "new value")
-- ("sub1",Nothing)
-- ("sub2",Nothing)
subscribe :: (MonadIO m) => Signal a -> m (STM a)
subscribe (Signal signalVar) = do
(_, n) <- readTVarIO signalVar
-- Start with a different n, so the subscriber will trigger on its first read.
latestNVar <- newTVarIO (pred n)
pure $ do
(mayA, newN) <- readTVar signalVar
latestN <- readTVar latestNVar
guard (newN /= latestN)
writeTVar latestNVar newN
-- Retry until we have a value.
case mayA of
Nothing -> STM.retry
Just a -> pure a

100
unison-cli/src/Unison/Main.hs
View File

@ -25,7 +25,6 @@ import ArgParse
)
import Compat (defaultInterruptHandler, withInterruptHandler)
import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar)
import Control.Concurrent.STM
import Control.Exception (displayException, evaluate)
import Data.ByteString.Lazy qualified as BL
import Data.Configurator.Types (Config)
@ -48,6 +47,7 @@ import System.Directory
)
import System.Environment (getExecutablePath, getProgName, withArgs)
import System.Exit qualified as Exit
import System.Exit qualified as System
import System.FilePath
( replaceExtension,
takeDirectory,
@ -60,8 +60,8 @@ import System.IO.CodePage (withCP65001)
import System.IO.Error (catchIOError)
import System.IO.Temp qualified as Temp
import System.Path qualified as Path
import U.Codebase.HashTags (CausalHash)
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase (Codebase, CodebasePath)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.Input qualified as Input
@ -70,6 +70,7 @@ import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResul
import Unison.Codebase.Init qualified as CodebaseInit
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime qualified as Rt
import Unison.Codebase.SqliteCodebase qualified as SC
import Unison.Codebase.TranscriptParser qualified as TR
@ -80,7 +81,9 @@ import Unison.CommandLine.Main qualified as CommandLine
import Unison.CommandLine.Types qualified as CommandLine
import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
import Unison.CommandLine.Welcome qualified as Welcome
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
import Unison.LSP qualified as LSP
import Unison.LSP.Util.Signal qualified as Signal
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyTerminal qualified as PT
@ -172,10 +175,9 @@ main version = do
getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do
let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
let noOpRootNotifier _ = pure ()
let noOpPathNotifier _ = pure ()
let noOpCheckForChanges _ = pure ()
let serverUrl = Nothing
let startPath = Nothing
startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
launch
version
currentDir
@ -186,10 +188,9 @@ main version = do
theCodebase
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
serverUrl
startPath
(PP.toIds startProjectPath)
initRes
noOpRootNotifier
noOpPathNotifier
noOpCheckForChanges
CommandLine.ShouldNotWatchFiles
Run (RunFromPipe mainName) args -> do
e <- safeReadUtf8StdIn
@ -199,10 +200,9 @@ main version = do
getCodebaseOrExit mCodePathOption (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
withRuntimes nrtp RTI.OneOff \(rt, sbrt, nrt) -> do
let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
let noOpRootNotifier _ = pure ()
let noOpPathNotifier _ = pure ()
let noOpCheckForChanges _ = pure ()
let serverUrl = Nothing
let startPath = Nothing
startProjectPath <- Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
launch
version
currentDir
@ -213,10 +213,9 @@ main version = do
theCodebase
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
serverUrl
startPath
(PP.toIds startProjectPath)
initRes
noOpRootNotifier
noOpPathNotifier
noOpCheckForChanges
CommandLine.ShouldNotWatchFiles
Run (RunCompiled file) args ->
BL.readFile file >>= \bs ->
@ -287,33 +286,38 @@ main version = do
case mrtsStatsFp of
Nothing -> action
Just fp -> recordRtsStats fp action
Launch isHeadless codebaseServerOpts mayStartingPath shouldWatchFiles -> do
Launch isHeadless codebaseServerOpts mayStartingProject shouldWatchFiles -> do
getCodebaseOrExit mCodePathOption (SC.MigrateAfterPrompt SC.Backup SC.Vacuum) \(initRes, _, theCodebase) -> do
withRuntimes nrtp RTI.Persistent \(runtime, sbRuntime, nRuntime) -> do
startingPath <- case isHeadless of
WithCLI -> do
-- If the user didn't provide a starting path on the command line, put them in the most recent
-- path they cd'd to
case mayStartingPath of
Just startingPath -> pure startingPath
Nothing -> do
segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace
pure (Path.Absolute (Path.fromList segments))
Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath
rootCausalHash <- Codebase.runTransaction theCodebase (Queries.expectNamespaceRoot >>= Queries.expectCausalHash)
rootCausalHashVar <- newTVarIO rootCausalHash
pathVar <- newTVarIO startingPath
let notifyOnRootChanges :: CausalHash -> STM ()
notifyOnRootChanges b = do
writeTVar rootCausalHashVar b
let notifyOnPathChanges :: Path.Absolute -> STM ()
notifyOnPathChanges = writeTVar pathVar
startingProjectPath <- do
-- If the user didn't provide a starting path on the command line, put them in the most recent
-- path they cd'd to
case mayStartingProject of
Just startingProject -> do
Codebase.runTransaction theCodebase (ProjectUtils.getProjectAndBranchByNames startingProject) >>= \case
Nothing -> do
PT.putPrettyLn $
P.callout
"❓"
( P.lines
[ P.indentN 2 "I couldn't find the project branch: " <> P.text (into @Text startingProject)
]
)
System.exitFailure
Just pab -> do
pure $ PP.fromProjectAndBranch pab Path.absoluteEmpty
Nothing -> do
Codebase.runTransaction theCodebase Codebase.expectCurrentProjectPath
currentPP <- Codebase.runTransaction theCodebase do
PP.toIds <$> Codebase.expectCurrentProjectPath
changeSignal <- Signal.newSignalIO (Just currentPP)
let lspCheckForChanges pp = Signal.writeSignalIO changeSignal pp
-- Unfortunately, the windows IO manager on GHC 8.* is prone to just hanging forever
-- when waiting for input on handles, so if we listen for LSP connections it will
-- prevent UCM from shutting down properly. Hopefully we can re-enable LSP on
-- Windows when we move to GHC 9.*
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1224
void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime (readTVar rootCausalHashVar) (readTVar pathVar)
void . Ki.fork scope $ LSP.spawnLsp lspFormattingConfig theCodebase runtime changeSignal
Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do
case exitOption of
DoNotExit -> do
@ -324,7 +328,7 @@ main version = do
[ "I've started the Codebase API server at",
P.text $ Server.urlFor Server.Api baseUrl,
"and the Codebase UI at",
P.text $ Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl
P.text $ Server.urlFor (Server.ProjectBranchUI (ProjectAndBranch (UnsafeProjectName "scratch") (UnsafeProjectBranchName "main")) Path.absoluteEmpty Nothing) baseUrl
]
PT.putPrettyLn $
P.string "Running the codebase manager headless with "
@ -347,10 +351,9 @@ main version = do
theCodebase
[]
(Just baseUrl)
(Just startingPath)
(PP.toIds startingProjectPath)
initRes
notifyOnRootChanges
notifyOnPathChanges
lspCheckForChanges
shouldWatchFiles
Exit -> do Exit.exitSuccess
where
@ -422,7 +425,8 @@ runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles
configFilePath <- getConfigFilePath mcodepath
-- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do
TR.withTranscriptRunner Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do
let isTest = False
TR.withTranscriptRunner isTest Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do
for markdownFiles $ \(MarkdownFile fileName) -> do
transcriptSrc <- readUtf8 fileName
result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
@ -513,9 +517,6 @@ runTranscripts version verbosity renderUsageInfo shouldFork shouldSaveTempCodeba
)
when (not completed) $ Exit.exitWith (Exit.ExitFailure 1)
defaultInitialPath :: Path.Absolute
defaultInitialPath = Path.absoluteEmpty
launch ::
Version ->
FilePath ->
@ -526,13 +527,12 @@ launch ::
Codebase.Codebase IO Symbol Ann ->
[Either Input.Event Input.Input] ->
Maybe Server.BaseUrl ->
Maybe Path.Absolute ->
PP.ProjectPathIds ->
InitResult ->
(CausalHash -> STM ()) ->
(Path.Absolute -> STM ()) ->
(PP.ProjectPathIds -> IO ()) ->
CommandLine.ShouldWatchFiles ->
IO ()
launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl mayStartingPath initResult notifyRootChange notifyPathChange shouldWatchFiles = do
launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseUrl startingPath initResult lspCheckForChanges shouldWatchFiles = do
showWelcomeHint <- Codebase.runTransaction codebase Queries.doProjectsExist
let isNewCodebase = case initResult of
CreatedCodebase -> NewlyCreatedCodebase
@ -542,7 +542,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
in CommandLine.main
dir
welcome
(fromMaybe defaultInitialPath mayStartingPath)
startingPath
config
inputs
runtime
@ -551,8 +551,7 @@ launch version dir config runtime sbRuntime nRuntime codebase inputs serverBaseU
codebase
serverBaseUrl
ucmVersion
notifyRootChange
notifyPathChange
lspCheckForChanges
shouldWatchFiles
newtype MarkdownFile = MarkdownFile FilePath
@ -572,7 +571,8 @@ getConfigFilePath mcodepath = (</> ".unisonConfig") <$> Codebase.getCodebaseDir
getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
getCodebaseOrExit codebasePathOption migrationStrategy action = do
initOptions <- argsToCodebaseInitOptions codebasePathOption
result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions SC.DoLock migrationStrategy \case
let cbInit = SC.init
result <- CodebaseInit.withOpenOrCreateCodebase cbInit "main" initOptions SC.DoLock migrationStrategy \case
cbInit@(CreatedCodebase, dir, _) -> do
pDir <- prettyDir dir
PT.putPrettyLn' ""

326
unison-cli/src/Unison/Share/Sync.hs
View File

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

27
unison-cli/src/Unison/Share/Sync/Types.hs
View File

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

4
unison-cli/tests/Unison/Test/ClearCache.hs
View File

@ -23,7 +23,7 @@ test = scope "clearWatchCache" $
c
[i|
```ucm
.> alias.term ##Nat.+ +
scratch/main> alias.term ##Nat.+ +
```
```unison
> 1 + 1
@ -38,7 +38,7 @@ test = scope "clearWatchCache" $
c
[i|
```ucm
.> debug.clear-cache
scratch/main> debug.clear-cache
```
|]

9
unison-cli/tests/Unison/Test/Cli/Monad.hs
View File

@ -36,12 +36,11 @@ dummyEnv = undefined
dummyLoopState :: Cli.LoopState
dummyLoopState =
Cli.LoopState
{ currentPathStack = undefined,
lastInput = Nothing,
lastRunResult = Nothing,
lastSavedRootHash = undefined,
{ currentProjectRoot = undefined,
projectPathStack = undefined,
latestFile = Nothing,
latestTypecheckedFile = Nothing,
lastInput = Nothing,
numberedArgs = [],
root = undefined
lastRunResult = Nothing
}

23
unison-cli/tests/Unison/Test/UriParser.hs
View File

@ -8,11 +8,6 @@ import EasyTest
import Text.Megaparsec qualified as P
import Unison.Codebase.Editor.RemoteRepo
( ReadRemoteNamespace (..),
ShareCodeserver (..),
ShareUserHandle (..),
WriteRemoteNamespace (..),
WriteShareRemoteNamespace (..),
pattern ReadShareLooseCode,
)
import Unison.Codebase.Editor.UriParser qualified as UriParser
import Unison.Codebase.Path qualified as Path
@ -27,8 +22,7 @@ test =
[ parserTests
"repoPath"
(UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof)
[ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]),
("project", branchR (This "project")),
[ ("project", branchR (This "project")),
("/branch", branchR (That "branch")),
("project/branch", branchR (These "project" "branch"))
]
@ -36,8 +30,7 @@ test =
parserTests
"writeRemoteNamespace"
(UriParser.writeRemoteNamespace <* P.eof)
[ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]),
("project", branchW (This "project")),
[ ("project", branchW (This "project")),
("/branch", branchW (That "branch")),
("project/branch", branchW (These "project" "branch"))
]
@ -48,14 +41,6 @@ test =
mkPath :: [Text] -> Path.Path
mkPath = Path.fromList . fmap NameSegment
looseR :: Text -> [Text] -> ReadRemoteNamespace void
looseR user path =
ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (mkPath path))
looseW :: Text -> [Text] -> WriteRemoteNamespace void
looseW user path =
WriteRemoteNamespaceShare (WriteShareRemoteNamespace DefaultCodeserver (ShareUserHandle user) (mkPath path))
branchR :: These Text Text -> ReadRemoteNamespace (These ProjectName ProjectBranchName)
branchR =
ReadShare'ProjectBranch . \case
@ -63,9 +48,9 @@ branchR =
That branch -> That (UnsafeProjectBranchName branch)
These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch)
branchW :: These Text Text -> WriteRemoteNamespace (These ProjectName ProjectBranchName)
branchW :: These Text Text -> (These ProjectName ProjectBranchName)
branchW =
WriteRemoteProjectBranch . \case
\case
This project -> This (UnsafeProjectName project)
That branch -> That (UnsafeProjectBranchName branch)
These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch)

3
unison-cli/transcripts/Transcripts.hs
View File

@ -47,7 +47,8 @@ testBuilder ::
Test ()
testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do
outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do
withTranscriptRunner Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
let isTest = True
withTranscriptRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
for files \filePath -> do
transcriptSrc <- readUtf8 filePath
out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase)

3
unison-cli/unison-cli.cabal
View File

@ -47,7 +47,6 @@ library
Unison.Cli.Share.Projects.Types
Unison.Cli.TypeCheck
Unison.Cli.UniqueTypeGuidLookup
Unison.Cli.UnisonConfigUtils
Unison.Codebase.Editor.AuthorInfo
Unison.Codebase.Editor.HandleInput
Unison.Codebase.Editor.HandleInput.AddRun
@ -83,6 +82,7 @@ library
Unison.Codebase.Editor.HandleInput.ProjectSwitch
Unison.Codebase.Editor.HandleInput.Pull
Unison.Codebase.Editor.HandleInput.Push
Unison.Codebase.Editor.HandleInput.Reflogs
Unison.Codebase.Editor.HandleInput.ReleaseDraft
Unison.Codebase.Editor.HandleInput.Run
Unison.Codebase.Editor.HandleInput.RuntimeUtils
@ -141,6 +141,7 @@ library
Unison.LSP.Queries
Unison.LSP.Types
Unison.LSP.UCMWorker
Unison.LSP.Util.Signal
Unison.LSP.VFS
Unison.Main
Unison.Share.Codeserver

Some files were not shown because too many files have changed in this diff Show More