mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge remote-tracking branch 'origin/trunk' into merged-ghc-upgrade-try-2
This commit is contained in:
commit
6ed06f3089
2
.github/workflows/ci.md
vendored
2
.github/workflows/ci.md
vendored
@ -9,7 +9,7 @@ At a high level, the CI process is:
|
||||
Some version numbers that are used during CI:
|
||||
- `ormolu_version: "0.5.0.1"`
|
||||
- `racket_version: "8.7"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.17"`
|
||||
- `jit_version: "@unison/internal/releases/0.0.18"`
|
||||
|
||||
Some cached directories:
|
||||
- `ucm_local_bin` a temp path for caching a built `ucm`
|
||||
|
2
.github/workflows/ci.yaml
vendored
2
.github/workflows/ci.yaml
vendored
@ -14,7 +14,7 @@ on:
|
||||
env:
|
||||
ormolu_version: 0.5.2.0
|
||||
ucm_local_bin: ucm-local-bin
|
||||
jit_version: "@unison/internal/releases/0.0.17"
|
||||
jit_version: "@unison/internal/releases/0.0.18"
|
||||
jit_src_scheme: unison-jit-src/scheme-libs/racket
|
||||
jit_dist: unison-jit-dist
|
||||
jit_generator_os: ubuntu-20.04
|
||||
|
10
.gitignore
vendored
10
.gitignore
vendored
@ -1,9 +1,14 @@
|
||||
# Unison
|
||||
.unison*
|
||||
test-output
|
||||
transcript-*
|
||||
scratch.u
|
||||
unisonLocal.zip
|
||||
*.uc
|
||||
# Ignore all scratch files...
|
||||
*.u
|
||||
# Except those in unison-src
|
||||
!unison-src/**/*.u
|
||||
# And integration tests
|
||||
!unison-cli-integration/integration-tests/IntegrationTests/**/*.u
|
||||
|
||||
# Auto-generated
|
||||
jit-tests.md
|
||||
@ -19,6 +24,7 @@ dist-newstyle
|
||||
# GHC
|
||||
*.hie
|
||||
*.prof
|
||||
*.prof.html
|
||||
/.direnv/
|
||||
/.envrc
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
50
codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs
Normal 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 {..}
|
@ -66,12 +66,6 @@ module U.Codebase.Sqlite.Queries
|
||||
loadTermObject,
|
||||
expectTermObject,
|
||||
|
||||
-- * namespace_root table
|
||||
loadNamespaceRoot,
|
||||
setNamespaceRoot,
|
||||
expectNamespaceRoot,
|
||||
expectNamespaceRootBranchHashId,
|
||||
|
||||
-- * namespace_statistics table
|
||||
saveNamespaceStats,
|
||||
loadNamespaceStatsByHashId,
|
||||
@ -135,6 +129,8 @@ module U.Codebase.Sqlite.Queries
|
||||
insertProjectBranch,
|
||||
renameProjectBranch,
|
||||
deleteProjectBranch,
|
||||
setProjectBranchHead,
|
||||
expectProjectBranchHead,
|
||||
setMostRecentBranch,
|
||||
loadMostRecentBranch,
|
||||
|
||||
@ -215,8 +211,11 @@ module U.Codebase.Sqlite.Queries
|
||||
fuzzySearchTypes,
|
||||
|
||||
-- * Reflog
|
||||
appendReflog,
|
||||
getReflog,
|
||||
getDeprecatedRootReflog,
|
||||
appendProjectBranchReflog,
|
||||
getProjectReflog,
|
||||
getProjectBranchReflog,
|
||||
getGlobalReflog,
|
||||
|
||||
-- * garbage collection
|
||||
garbageCollectObjectsWithoutHashes,
|
||||
@ -237,12 +236,12 @@ module U.Codebase.Sqlite.Queries
|
||||
-- * elaborate hashes
|
||||
elaborateHashes,
|
||||
|
||||
-- * most recent namespace
|
||||
expectMostRecentNamespace,
|
||||
setMostRecentNamespace,
|
||||
-- * current project path
|
||||
expectCurrentProjectPath,
|
||||
setCurrentProjectPath,
|
||||
|
||||
-- * migrations
|
||||
createSchema,
|
||||
runCreateSql,
|
||||
addTempEntityTables,
|
||||
addReflogTable,
|
||||
addNamespaceStatsTables,
|
||||
@ -254,6 +253,9 @@ module U.Codebase.Sqlite.Queries
|
||||
addSquashResultTable,
|
||||
addSquashResultTableIfNotExists,
|
||||
cdToProjectRoot,
|
||||
addCurrentProjectPathTable,
|
||||
addProjectBranchReflogTable,
|
||||
addProjectBranchCausalHashIdColumn,
|
||||
|
||||
-- ** schema version
|
||||
currentSchemaVersion,
|
||||
@ -287,6 +289,7 @@ module U.Codebase.Sqlite.Queries
|
||||
-- * Types
|
||||
NamespaceText,
|
||||
TextPathSegments,
|
||||
JsonParseFailure(..),
|
||||
)
|
||||
where
|
||||
|
||||
@ -315,6 +318,7 @@ import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.Text.Lazy qualified as Text.Lazy
|
||||
import Data.Time qualified as Time
|
||||
import Data.Vector qualified as Vector
|
||||
import GHC.Stack (callStack)
|
||||
import Network.URI (URI)
|
||||
@ -367,7 +371,8 @@ import U.Codebase.Sqlite.Orphans ()
|
||||
import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Reference qualified as S (Reference, ReferenceH, TermReference, TermReferenceId, TextReference, TypeReference, TypeReferenceId)
|
||||
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
|
||||
import U.Codebase.Sqlite.Reference qualified as S
|
||||
import U.Codebase.Sqlite.Reference qualified as S.Reference
|
||||
import U.Codebase.Sqlite.Referent qualified as S (TextReferent)
|
||||
import U.Codebase.Sqlite.Referent qualified as S.Referent
|
||||
@ -399,6 +404,7 @@ import Unison.NameSegment.Internal (NameSegment (NameSegment))
|
||||
import Unison.NameSegment.Internal qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Util.Alternative qualified as Alternative
|
||||
import Unison.Util.Defns (Defns (..), DefnsF)
|
||||
import Unison.Util.FileEmbed (embedProjectStringFile)
|
||||
@ -414,27 +420,11 @@ type TextPathSegments = [Text]
|
||||
-- * main squeeze
|
||||
|
||||
currentSchemaVersion :: SchemaVersion
|
||||
currentSchemaVersion = 16
|
||||
currentSchemaVersion = 17
|
||||
|
||||
createSchema :: Transaction ()
|
||||
createSchema = do
|
||||
runCreateSql :: Transaction ()
|
||||
runCreateSql =
|
||||
executeStatements $(embedProjectStringFile "sql/create.sql")
|
||||
addTempEntityTables
|
||||
addNamespaceStatsTables
|
||||
addReflogTable
|
||||
fixScopedNameLookupTables
|
||||
addProjectTables
|
||||
addMostRecentBranchTable
|
||||
addNameLookupMountTables
|
||||
addMostRecentNamespaceTable
|
||||
execute insertSchemaVersionSql
|
||||
addSquashResultTable
|
||||
where
|
||||
insertSchemaVersionSql =
|
||||
[sql|
|
||||
INSERT INTO schema_version (version)
|
||||
VALUES (:currentSchemaVersion)
|
||||
|]
|
||||
|
||||
addTempEntityTables :: Transaction ()
|
||||
addTempEntityTables =
|
||||
@ -444,6 +434,7 @@ addNamespaceStatsTables :: Transaction ()
|
||||
addNamespaceStatsTables =
|
||||
executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql")
|
||||
|
||||
-- | Deprecated in favour of project-branch reflog
|
||||
addReflogTable :: Transaction ()
|
||||
addReflogTable =
|
||||
executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql")
|
||||
@ -482,6 +473,19 @@ cdToProjectRoot :: Transaction ()
|
||||
cdToProjectRoot =
|
||||
executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql")
|
||||
|
||||
addCurrentProjectPathTable :: Transaction ()
|
||||
addCurrentProjectPathTable =
|
||||
executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql")
|
||||
|
||||
-- | Deprecated in favour of project-branch reflog
|
||||
addProjectBranchReflogTable :: Transaction ()
|
||||
addProjectBranchReflogTable =
|
||||
executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql")
|
||||
|
||||
addProjectBranchCausalHashIdColumn :: Transaction ()
|
||||
addProjectBranchCausalHashIdColumn =
|
||||
executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql")
|
||||
|
||||
schemaVersion :: Transaction SchemaVersion
|
||||
schemaVersion =
|
||||
queryOneCol
|
||||
@ -1337,32 +1341,6 @@ loadCausalParentsByHash hash =
|
||||
WHERE h1.base32 = :hash COLLATE NOCASE
|
||||
|]
|
||||
|
||||
expectNamespaceRootBranchHashId :: Transaction BranchHashId
|
||||
expectNamespaceRootBranchHashId = do
|
||||
chId <- expectNamespaceRoot
|
||||
expectCausalValueHashId chId
|
||||
|
||||
expectNamespaceRoot :: Transaction CausalHashId
|
||||
expectNamespaceRoot =
|
||||
queryOneCol loadNamespaceRootSql
|
||||
|
||||
loadNamespaceRoot :: Transaction (Maybe CausalHashId)
|
||||
loadNamespaceRoot =
|
||||
queryMaybeCol loadNamespaceRootSql
|
||||
|
||||
loadNamespaceRootSql :: Sql
|
||||
loadNamespaceRootSql =
|
||||
[sql|
|
||||
SELECT causal_id
|
||||
FROM namespace_root
|
||||
|]
|
||||
|
||||
setNamespaceRoot :: CausalHashId -> Transaction ()
|
||||
setNamespaceRoot id =
|
||||
queryOneCol [sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case
|
||||
False -> execute [sql| INSERT INTO namespace_root VALUES (:id) |]
|
||||
True -> execute [sql| UPDATE namespace_root SET causal_id = :id |]
|
||||
|
||||
saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction ()
|
||||
saveWatch k r blob = do
|
||||
execute
|
||||
@ -3496,16 +3474,8 @@ loadNamespaceStatsByHashId bhId = do
|
||||
WHERE namespace_hash_id = :bhId
|
||||
|]
|
||||
|
||||
appendReflog :: Reflog.Entry CausalHashId Text -> Transaction ()
|
||||
appendReflog entry =
|
||||
execute
|
||||
[sql|
|
||||
INSERT INTO reflog (time, from_root_causal_id, to_root_causal_id, reason)
|
||||
VALUES (@entry, @, @, @)
|
||||
|]
|
||||
|
||||
getReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
|
||||
getReflog numEntries =
|
||||
getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
|
||||
getDeprecatedRootReflog numEntries =
|
||||
queryListRow
|
||||
[sql|
|
||||
SELECT time, from_root_causal_id, to_root_causal_id, reason
|
||||
@ -3514,6 +3484,49 @@ getReflog numEntries =
|
||||
LIMIT :numEntries
|
||||
|]
|
||||
|
||||
appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
|
||||
appendProjectBranchReflog entry =
|
||||
execute
|
||||
[sql|
|
||||
INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason)
|
||||
VALUES (@entry, @, @, @, @, @)
|
||||
|]
|
||||
|
||||
-- | Get x number of entries from the project reflog for the provided project
|
||||
getProjectReflog :: Int -> ProjectId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
|
||||
getProjectReflog numEntries projectId =
|
||||
queryListRow
|
||||
[sql|
|
||||
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
|
||||
FROM project_branch_reflog
|
||||
WHERE project_id = :projectId
|
||||
ORDER BY time DESC
|
||||
LIMIT :numEntries
|
||||
|]
|
||||
|
||||
-- | Get x number of entries from the project reflog for the provided branch.
|
||||
getProjectBranchReflog :: Int -> ProjectBranchId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
|
||||
getProjectBranchReflog numEntries projectBranchId =
|
||||
queryListRow
|
||||
[sql|
|
||||
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
|
||||
FROM project_branch_reflog
|
||||
WHERE project_branch_id = :projectBranchId
|
||||
ORDER BY time DESC
|
||||
LIMIT :numEntries
|
||||
|]
|
||||
|
||||
-- | Get x number of entries from the global reflog spanning all projects
|
||||
getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
|
||||
getGlobalReflog numEntries =
|
||||
queryListRow
|
||||
[sql|
|
||||
SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
|
||||
FROM project_branch_reflog
|
||||
ORDER BY time DESC
|
||||
LIMIT :numEntries
|
||||
|]
|
||||
|
||||
-- | Does a project exist with this id?
|
||||
projectExists :: ProjectId -> Transaction Bool
|
||||
projectExists projectId =
|
||||
@ -3803,12 +3816,15 @@ loadProjectAndBranchNames projectId branchId =
|
||||
|]
|
||||
|
||||
-- | Insert a project branch.
|
||||
insertProjectBranch :: ProjectBranch -> Transaction ()
|
||||
insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
||||
insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
|
||||
insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do
|
||||
-- Ensure we never point at a causal we don't have the branch for.
|
||||
_ <- expectBranchObjectIdByCausalHashId causalHashId
|
||||
|
||||
execute
|
||||
[sql|
|
||||
INSERT INTO project_branch (project_id, branch_id, name)
|
||||
VALUES (:projectId, :branchId, :branchName)
|
||||
INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
|
||||
VALUES (:projectId, :branchId, :branchName, :causalHashId)
|
||||
|]
|
||||
whenJust maybeParentBranchId \parentBranchId ->
|
||||
execute
|
||||
@ -3816,6 +3832,16 @@ insertProjectBranch (ProjectBranch projectId branchId branchName maybeParentBran
|
||||
INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id)
|
||||
VALUES (:projectId, :parentBranchId, :branchId)
|
||||
|]
|
||||
time <- Sqlite.unsafeIO $ Time.getCurrentTime
|
||||
appendProjectBranchReflog $
|
||||
ProjectReflog.Entry
|
||||
{ project = projectId,
|
||||
branch = branchId,
|
||||
time,
|
||||
fromRootCausalHash = Nothing,
|
||||
toRootCausalHash = causalHashId,
|
||||
reason = description
|
||||
}
|
||||
|
||||
-- | Rename a project branch.
|
||||
--
|
||||
@ -3864,7 +3890,7 @@ deleteProject projectId = do
|
||||
-- After deleting `topic`:
|
||||
--
|
||||
-- main <- topic2
|
||||
deleteProjectBranch :: ProjectId -> ProjectBranchId -> Transaction ()
|
||||
deleteProjectBranch :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction ()
|
||||
deleteProjectBranch projectId branchId = do
|
||||
maybeParentBranchId :: Maybe ProjectBranchId <-
|
||||
queryMaybeCol
|
||||
@ -3888,6 +3914,38 @@ deleteProjectBranch projectId branchId = do
|
||||
WHERE project_id = :projectId AND branch_id = :branchId
|
||||
|]
|
||||
|
||||
-- | Set project branch HEAD
|
||||
setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction ()
|
||||
setProjectBranchHead description projectId branchId causalHashId = do
|
||||
-- Ensure we never point at a causal we don't have the branch for.
|
||||
_ <- expectBranchObjectIdByCausalHashId causalHashId
|
||||
oldRootCausalHashId <- expectProjectBranchHead projectId branchId
|
||||
execute
|
||||
[sql|
|
||||
UPDATE project_branch
|
||||
SET causal_hash_id = :causalHashId
|
||||
WHERE project_id = :projectId AND branch_id = :branchId
|
||||
|]
|
||||
time <- Sqlite.unsafeIO $ Time.getCurrentTime
|
||||
appendProjectBranchReflog $
|
||||
ProjectReflog.Entry
|
||||
{ project = projectId,
|
||||
branch = branchId,
|
||||
time = time,
|
||||
fromRootCausalHash = Just oldRootCausalHashId,
|
||||
toRootCausalHash = causalHashId,
|
||||
reason = description
|
||||
}
|
||||
|
||||
expectProjectBranchHead :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction CausalHashId
|
||||
expectProjectBranchHead projectId branchId =
|
||||
queryOneCol
|
||||
[sql|
|
||||
SELECT causal_hash_id
|
||||
FROM project_branch
|
||||
WHERE project_id = :projectId AND branch_id = :branchId
|
||||
|]
|
||||
|
||||
data LoadRemoteBranchFlag
|
||||
= IncludeSelfRemote
|
||||
| ExcludeSelfRemote
|
||||
@ -4372,33 +4430,39 @@ data JsonParseFailure = JsonParseFailure
|
||||
deriving anyclass (SqliteExceptionReason)
|
||||
|
||||
-- | Get the most recent namespace the user has visited.
|
||||
expectMostRecentNamespace :: Transaction [NameSegment]
|
||||
expectMostRecentNamespace =
|
||||
queryOneColCheck
|
||||
expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
|
||||
expectCurrentProjectPath =
|
||||
queryOneRowCheck
|
||||
[sql|
|
||||
SELECT namespace
|
||||
FROM most_recent_namespace
|
||||
SELECT project_id, branch_id, path
|
||||
FROM current_project_path
|
||||
|]
|
||||
check
|
||||
where
|
||||
check :: Text -> Either JsonParseFailure [NameSegment]
|
||||
check bytes =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
|
||||
Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
|
||||
Right namespace -> Right (map NameSegment namespace)
|
||||
check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
|
||||
check (projId, branchId, pathText) =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 pathText) of
|
||||
Left failure -> Left JsonParseFailure {bytes = pathText, failure = Text.pack failure}
|
||||
Right namespace -> Right (projId, branchId, map NameSegment namespace)
|
||||
|
||||
-- | Set the most recent namespace the user has visited.
|
||||
setMostRecentNamespace :: [NameSegment] -> Transaction ()
|
||||
setMostRecentNamespace namespace =
|
||||
setCurrentProjectPath ::
|
||||
ProjectId ->
|
||||
ProjectBranchId ->
|
||||
[NameSegment] ->
|
||||
Transaction ()
|
||||
setCurrentProjectPath projId branchId path = do
|
||||
execute
|
||||
[sql| DELETE FROM current_project_path |]
|
||||
execute
|
||||
[sql|
|
||||
UPDATE most_recent_namespace
|
||||
SET namespace = :json
|
||||
INSERT INTO current_project_path(project_id, branch_id, path)
|
||||
VALUES (:projId, :branchId, :jsonPath)
|
||||
|]
|
||||
where
|
||||
json :: Text
|
||||
json =
|
||||
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> namespace)
|
||||
jsonPath :: Text
|
||||
jsonPath =
|
||||
Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path)
|
||||
|
||||
-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
|
||||
-- at some point in the past.
|
||||
|
@ -27,10 +27,12 @@ dependencies:
|
||||
- nonempty-containers
|
||||
- safe
|
||||
- text
|
||||
- time
|
||||
- transformers
|
||||
- unison-codebase
|
||||
- unison-codebase-sync
|
||||
- unison-core
|
||||
- unison-core1
|
||||
- unison-core-orphans-sqlite
|
||||
- unison-hash
|
||||
- unison-hash-orphans-sqlite
|
||||
@ -39,7 +41,6 @@ dependencies:
|
||||
- unison-util-base32hex
|
||||
- unison-util-cache
|
||||
- unison-util-file-embed
|
||||
- unison-util-nametree
|
||||
- unison-util-serialization
|
||||
- unison-util-term
|
||||
- unliftio
|
||||
|
@ -0,0 +1,15 @@
|
||||
-- The most recent namespace that a user cd'd to.
|
||||
-- This table should never have more than one row.
|
||||
CREATE TABLE current_project_path (
|
||||
project_id INTEGER NOT NULL,
|
||||
branch_id INTEGER NOT NULL,
|
||||
-- A json array like ["foo", "bar"]; the root namespace is represented by the empty array
|
||||
path TEXT PRIMARY KEY NOT NULL,
|
||||
|
||||
foreign key (project_id, branch_id)
|
||||
references project_branch (project_id, branch_id)
|
||||
-- Prevent deleting the project you're currently in.
|
||||
on delete no action
|
||||
) WITHOUT ROWID;
|
||||
|
||||
DROP TABLE most_recent_namespace;
|
@ -0,0 +1,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
|
||||
);
|
||||
|
||||
|
@ -0,0 +1,2 @@
|
||||
-- Add a new column to the project_branch table to store the causal_hash_id
|
||||
ALTER TABLE project_branch ADD COLUMN causal_hash_id INTEGER NOT NULL;
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -21,6 +21,9 @@ extra-source-files:
|
||||
sql/009-add-squash-cache-table.sql
|
||||
sql/010-ensure-squash-cache-table.sql
|
||||
sql/011-cd-to-project-root.sql
|
||||
sql/012-add-current-project-path-table.sql
|
||||
sql/013-add-project-branch-reflog-table.sql
|
||||
sql/014-add-project-branch-causal-hash-id.sql
|
||||
sql/create.sql
|
||||
|
||||
source-repository head
|
||||
@ -54,6 +57,7 @@ library
|
||||
U.Codebase.Sqlite.Patch.TypeEdit
|
||||
U.Codebase.Sqlite.Project
|
||||
U.Codebase.Sqlite.ProjectBranch
|
||||
U.Codebase.Sqlite.ProjectReflog
|
||||
U.Codebase.Sqlite.Queries
|
||||
U.Codebase.Sqlite.Reference
|
||||
U.Codebase.Sqlite.Referent
|
||||
@ -121,11 +125,13 @@ library
|
||||
, nonempty-containers
|
||||
, safe
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, unison-codebase
|
||||
, unison-codebase-sync
|
||||
, unison-core
|
||||
, unison-core-orphans-sqlite
|
||||
, unison-core1
|
||||
, unison-hash
|
||||
, unison-hash-orphans-sqlite
|
||||
, unison-prelude
|
||||
@ -133,7 +139,6 @@ library
|
||||
, unison-util-base32hex
|
||||
, unison-util-cache
|
||||
, unison-util-file-embed
|
||||
, unison-util-nametree
|
||||
, unison-util-serialization
|
||||
, unison-util-term
|
||||
, unliftio
|
||||
|
@ -24,7 +24,6 @@ packages:
|
||||
lib/unison-util-relation
|
||||
lib/unison-util-rope
|
||||
lib/unison-util-file-embed
|
||||
lib/unison-util-nametree
|
||||
|
||||
parser-typechecker
|
||||
unison-core
|
||||
|
@ -147,7 +147,7 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb
|
||||
debug :: (Show a) => DebugFlag -> String -> a -> a
|
||||
debug flag msg a =
|
||||
if shouldDebug flag
|
||||
then (pTrace (msg <> ":\n" <> into @String (pShow a)) a)
|
||||
then (trace (msg <> ":\n" <> into @String (pShow a)) a)
|
||||
else a
|
||||
|
||||
-- | Use for selective debug logging in monadic contexts.
|
||||
|
@ -151,7 +151,7 @@ logQuery (Sql sql params) result =
|
||||
|
||||
-- Without results
|
||||
|
||||
execute :: Connection -> Sql -> IO ()
|
||||
execute :: HasCallStack => Connection -> Sql -> IO ()
|
||||
execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
logQuery sql Nothing
|
||||
doExecute `catch` \(exception :: Sqlite.SQLError) ->
|
||||
@ -171,7 +171,7 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
-- | Execute one or more semicolon-delimited statements.
|
||||
--
|
||||
-- This function does not support parameters, and is mostly useful for executing DDL and migrations.
|
||||
executeStatements :: Connection -> Text -> IO ()
|
||||
executeStatements :: HasCallStack => Connection -> Text -> IO ()
|
||||
executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do
|
||||
logQuery (Sql sql []) Nothing
|
||||
Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) ->
|
||||
@ -184,7 +184,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCoun
|
||||
|
||||
-- With results, without checks
|
||||
|
||||
queryStreamRow :: (Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r
|
||||
queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r
|
||||
queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
|
||||
run `catch` \(exception :: Sqlite.SQLError) ->
|
||||
throwSqliteQueryException
|
||||
@ -201,7 +201,7 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
|
||||
|
||||
queryStreamCol ::
|
||||
forall a r.
|
||||
(Sqlite.FromField a) =>
|
||||
(HasCallStack, Sqlite.FromField a) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
(IO (Maybe a) -> IO r) ->
|
||||
@ -212,7 +212,7 @@ queryStreamCol =
|
||||
@(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r)
|
||||
queryStreamRow
|
||||
|
||||
queryListRow :: forall a. (Sqlite.FromRow a) => Connection -> Sql -> IO [a]
|
||||
queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a]
|
||||
queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
result <-
|
||||
doQuery
|
||||
@ -237,35 +237,35 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
|
||||
Just row -> loop (row : rows)
|
||||
loop []
|
||||
|
||||
queryListCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO [a]
|
||||
queryListCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO [a]
|
||||
queryListCol =
|
||||
coerce @(Connection -> Sql -> IO [Sqlite.Only a]) @(Connection -> Sql -> IO [a]) queryListRow
|
||||
|
||||
queryMaybeRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO (Maybe a)
|
||||
queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO (Maybe a)
|
||||
queryMaybeRow conn s =
|
||||
queryListRowCheck conn s \case
|
||||
[] -> Right Nothing
|
||||
[x] -> Right (Just x)
|
||||
xs -> Left (ExpectedAtMostOneRowException (anythingToString xs))
|
||||
|
||||
queryMaybeCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO (Maybe a)
|
||||
queryMaybeCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO (Maybe a)
|
||||
queryMaybeCol conn s =
|
||||
coerce @(IO (Maybe (Sqlite.Only a))) @(IO (Maybe a)) (queryMaybeRow conn s)
|
||||
|
||||
queryOneRow :: (Sqlite.FromRow a) => Connection -> Sql -> IO a
|
||||
queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO a
|
||||
queryOneRow conn s =
|
||||
queryListRowCheck conn s \case
|
||||
[x] -> Right x
|
||||
xs -> Left (ExpectedExactlyOneRowException (anythingToString xs))
|
||||
|
||||
queryOneCol :: forall a. (Sqlite.FromField a) => Connection -> Sql -> IO a
|
||||
queryOneCol :: forall a. (Sqlite.FromField a, HasCallStack) => Connection -> Sql -> IO a
|
||||
queryOneCol conn s = do
|
||||
coerce @(IO (Sqlite.Only a)) @(IO a) (queryOneRow conn s)
|
||||
|
||||
-- With results, with checks
|
||||
|
||||
queryListRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
([a] -> Either e r) ->
|
||||
@ -274,7 +274,7 @@ queryListRowCheck conn s check =
|
||||
gqueryListCheck conn s (mapLeft SomeSqliteExceptionReason . check)
|
||||
|
||||
gqueryListCheck ::
|
||||
(Sqlite.FromRow a) =>
|
||||
(Sqlite.FromRow a, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
([a] -> Either SomeSqliteExceptionReason r) ->
|
||||
@ -293,7 +293,7 @@ gqueryListCheck conn sql check = do
|
||||
|
||||
queryListColCheck ::
|
||||
forall a e r.
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
([a] -> Either e r) ->
|
||||
@ -302,7 +302,7 @@ queryListColCheck conn s check =
|
||||
queryListRowCheck conn s (coerce @([a] -> Either e r) @([Sqlite.Only a] -> Either e r) check)
|
||||
|
||||
queryMaybeRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
@ -315,7 +315,7 @@ queryMaybeRowCheck conn s check =
|
||||
|
||||
queryMaybeColCheck ::
|
||||
forall a e r.
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
@ -324,7 +324,7 @@ queryMaybeColCheck conn s check =
|
||||
queryMaybeRowCheck conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check)
|
||||
|
||||
queryOneRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
@ -336,7 +336,7 @@ queryOneRowCheck conn s check =
|
||||
|
||||
queryOneColCheck ::
|
||||
forall a e r.
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Connection ->
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
|
@ -24,7 +24,8 @@ where
|
||||
import Control.Concurrent (ThreadId, myThreadId)
|
||||
import Data.Typeable (cast)
|
||||
import Database.SQLite.Simple qualified as Sqlite
|
||||
import GHC.Stack (currentCallStack)
|
||||
import GHC.Stack (CallStack)
|
||||
import GHC.Stack qualified as Stack
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite.Connection.Internal (Connection)
|
||||
import Unison.Sqlite.Sql (Sql (..))
|
||||
@ -112,7 +113,7 @@ data SqliteQueryException = SqliteQueryException
|
||||
-- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally
|
||||
-- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
|
||||
exception :: SomeSqliteExceptionReason,
|
||||
callStack :: [String],
|
||||
callStack :: CallStack,
|
||||
connection :: Connection,
|
||||
threadId :: ThreadId
|
||||
}
|
||||
@ -137,16 +138,15 @@ data SqliteQueryExceptionInfo = SqliteQueryExceptionInfo
|
||||
exception :: SomeSqliteExceptionReason
|
||||
}
|
||||
|
||||
throwSqliteQueryException :: SqliteQueryExceptionInfo -> IO a
|
||||
throwSqliteQueryException :: HasCallStack => SqliteQueryExceptionInfo -> IO a
|
||||
throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = Sql sql params} = do
|
||||
threadId <- myThreadId
|
||||
callStack <- currentCallStack
|
||||
throwIO
|
||||
SqliteQueryException
|
||||
{ sql,
|
||||
params,
|
||||
exception,
|
||||
callStack,
|
||||
callStack = Stack.callStack,
|
||||
connection,
|
||||
threadId
|
||||
}
|
||||
|
@ -88,7 +88,7 @@ instance MonadIO TransactionWithMonadIO where
|
||||
coerce @(IO a -> Transaction a) unsafeIO
|
||||
|
||||
-- | Run a transaction on the given connection.
|
||||
runTransaction :: (MonadIO m) => Connection -> Transaction a -> m a
|
||||
runTransaction :: (MonadIO m, HasCallStack) => Connection -> Transaction a -> m a
|
||||
runTransaction conn (Transaction f) = liftIO do
|
||||
uninterruptibleMask \restore -> do
|
||||
Connection.begin conn
|
||||
@ -117,7 +117,7 @@ instance Show RollingBack where
|
||||
-- | Run a transaction on the given connection, providing a function that can short-circuit (and roll back) the
|
||||
-- transaction.
|
||||
runTransactionWithRollback ::
|
||||
(MonadIO m) =>
|
||||
(MonadIO m, HasCallStack) =>
|
||||
Connection ->
|
||||
((forall void. a -> Transaction void) -> Transaction a) ->
|
||||
m a
|
||||
@ -137,13 +137,13 @@ runTransactionWithRollback conn transaction = liftIO do
|
||||
--
|
||||
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does
|
||||
-- attempt a write and gets SQLITE_BUSY, it's your fault!
|
||||
runReadOnlyTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
|
||||
runReadOnlyTransaction :: (MonadUnliftIO m, HasCallStack) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
|
||||
runReadOnlyTransaction conn f =
|
||||
withRunInIO \runInIO ->
|
||||
runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||
{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
||||
|
||||
runReadOnlyTransaction_ :: Connection -> IO a -> IO a
|
||||
runReadOnlyTransaction_ :: HasCallStack => Connection -> IO a -> IO a
|
||||
runReadOnlyTransaction_ conn action = do
|
||||
bracketOnError_
|
||||
(Connection.begin conn)
|
||||
@ -160,7 +160,7 @@ runReadOnlyTransaction_ conn action = do
|
||||
-- BEGIN/COMMIT statements.
|
||||
--
|
||||
-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions.
|
||||
runWriteTransaction :: (MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
|
||||
runWriteTransaction :: (HasCallStack, MonadUnliftIO m) => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a
|
||||
runWriteTransaction conn f =
|
||||
withRunInIO \runInIO ->
|
||||
uninterruptibleMask \restore ->
|
||||
@ -170,7 +170,7 @@ runWriteTransaction conn f =
|
||||
(runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn))))
|
||||
{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-}
|
||||
|
||||
runWriteTransaction_ :: (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
|
||||
runWriteTransaction_ :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO a -> IO a
|
||||
runWriteTransaction_ restore conn transaction = do
|
||||
keepTryingToBeginImmediate restore conn
|
||||
result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn)
|
||||
@ -178,7 +178,7 @@ runWriteTransaction_ restore conn transaction = do
|
||||
pure result
|
||||
|
||||
-- @BEGIN IMMEDIATE@ until success.
|
||||
keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> IO ()
|
||||
keepTryingToBeginImmediate :: HasCallStack => (forall x. IO x -> IO x) -> Connection -> IO ()
|
||||
keepTryingToBeginImmediate restore conn =
|
||||
let loop =
|
||||
try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case
|
||||
@ -217,7 +217,7 @@ savepoint (Transaction action) = do
|
||||
-- transaction needs to retry.
|
||||
--
|
||||
-- /Warning/: attempting to run a transaction inside a transaction will cause an exception!
|
||||
unsafeIO :: IO a -> Transaction a
|
||||
unsafeIO :: HasCallStack => IO a -> Transaction a
|
||||
unsafeIO action =
|
||||
Transaction \_ -> action
|
||||
|
||||
@ -232,18 +232,18 @@ unsafeUnTransaction (Transaction action) =
|
||||
|
||||
-- Without results
|
||||
|
||||
execute :: Sql -> Transaction ()
|
||||
execute :: HasCallStack => Sql -> Transaction ()
|
||||
execute s =
|
||||
Transaction \conn -> Connection.execute conn s
|
||||
|
||||
executeStatements :: Text -> Transaction ()
|
||||
executeStatements :: HasCallStack => Text -> Transaction ()
|
||||
executeStatements s =
|
||||
Transaction \conn -> Connection.executeStatements conn s
|
||||
|
||||
-- With results, without checks
|
||||
|
||||
queryStreamRow ::
|
||||
(Sqlite.FromRow a) =>
|
||||
(Sqlite.FromRow a, HasCallStack) =>
|
||||
Sql ->
|
||||
(Transaction (Maybe a) -> Transaction r) ->
|
||||
Transaction r
|
||||
@ -254,7 +254,7 @@ queryStreamRow sql callback =
|
||||
|
||||
queryStreamCol ::
|
||||
forall a r.
|
||||
(Sqlite.FromField a) =>
|
||||
(Sqlite.FromField a, HasCallStack) =>
|
||||
Sql ->
|
||||
(Transaction (Maybe a) -> Transaction r) ->
|
||||
Transaction r
|
||||
@ -264,34 +264,34 @@ queryStreamCol =
|
||||
@(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r)
|
||||
queryStreamRow
|
||||
|
||||
queryListRow :: (Sqlite.FromRow a) => Sql -> Transaction [a]
|
||||
queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a]
|
||||
queryListRow s =
|
||||
Transaction \conn -> Connection.queryListRow conn s
|
||||
|
||||
queryListCol :: (Sqlite.FromField a) => Sql -> Transaction [a]
|
||||
queryListCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction [a]
|
||||
queryListCol s =
|
||||
Transaction \conn -> Connection.queryListCol conn s
|
||||
|
||||
queryMaybeRow :: (Sqlite.FromRow a) => Sql -> Transaction (Maybe a)
|
||||
queryMaybeRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
|
||||
queryMaybeRow s =
|
||||
Transaction \conn -> Connection.queryMaybeRow conn s
|
||||
|
||||
queryMaybeCol :: (Sqlite.FromField a) => Sql -> Transaction (Maybe a)
|
||||
queryMaybeCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction (Maybe a)
|
||||
queryMaybeCol s =
|
||||
Transaction \conn -> Connection.queryMaybeCol conn s
|
||||
|
||||
queryOneRow :: (Sqlite.FromRow a) => Sql -> Transaction a
|
||||
queryOneRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction a
|
||||
queryOneRow s =
|
||||
Transaction \conn -> Connection.queryOneRow conn s
|
||||
|
||||
queryOneCol :: (Sqlite.FromField a) => Sql -> Transaction a
|
||||
queryOneCol :: (Sqlite.FromField a, HasCallStack) => Sql -> Transaction a
|
||||
queryOneCol s =
|
||||
Transaction \conn -> Connection.queryOneCol conn s
|
||||
|
||||
-- With results, with parameters, with checks
|
||||
|
||||
queryListRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
([a] -> Either e r) ->
|
||||
Transaction r
|
||||
@ -299,7 +299,7 @@ queryListRowCheck sql check =
|
||||
Transaction \conn -> Connection.queryListRowCheck conn sql check
|
||||
|
||||
queryListColCheck ::
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
([a] -> Either e r) ->
|
||||
Transaction r
|
||||
@ -307,7 +307,7 @@ queryListColCheck sql check =
|
||||
Transaction \conn -> Connection.queryListColCheck conn sql check
|
||||
|
||||
queryMaybeRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
Transaction (Maybe r)
|
||||
@ -315,7 +315,7 @@ queryMaybeRowCheck s check =
|
||||
Transaction \conn -> Connection.queryMaybeRowCheck conn s check
|
||||
|
||||
queryMaybeColCheck ::
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
Transaction (Maybe r)
|
||||
@ -323,7 +323,7 @@ queryMaybeColCheck s check =
|
||||
Transaction \conn -> Connection.queryMaybeColCheck conn s check
|
||||
|
||||
queryOneRowCheck ::
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
Transaction r
|
||||
@ -331,7 +331,7 @@ queryOneRowCheck s check =
|
||||
Transaction \conn -> Connection.queryOneRowCheck conn s check
|
||||
|
||||
queryOneColCheck ::
|
||||
(Sqlite.FromField a, SqliteExceptionReason e) =>
|
||||
(Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) =>
|
||||
Sql ->
|
||||
(a -> Either e r) ->
|
||||
Transaction r
|
||||
|
@ -1,56 +0,0 @@
|
||||
name: unison-util-nametree
|
||||
github: unisonweb/unison
|
||||
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
- containers
|
||||
- lens
|
||||
- semialign
|
||||
- semigroups
|
||||
- these
|
||||
- unison-core
|
||||
- unison-core1
|
||||
- unison-prelude
|
||||
- unison-util-relation
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: false
|
||||
other-modules: Paths_unison_util_nametree
|
||||
|
||||
default-extensions:
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DoAndIfThenElse
|
||||
- DuplicateRecordFields
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- ImportQualifiedPost
|
||||
- InstanceSigs
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- MultiWayIf
|
||||
- NamedFieldPuns
|
||||
- NumericUnderscores
|
||||
- OverloadedLabels
|
||||
- OverloadedRecordDot
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- RankNTypes
|
||||
- ScopedTypeVariables
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- ViewPatterns
|
@ -1,68 +0,0 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: unison-util-nametree
|
||||
version: 0.0.0
|
||||
homepage: https://github.com/unisonweb/unison#readme
|
||||
bug-reports: https://github.com/unisonweb/unison/issues
|
||||
copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors
|
||||
build-type: Simple
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/unisonweb/unison
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Unison.Util.Defns
|
||||
Unison.Util.Nametree
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
NamedFieldPuns
|
||||
NumericUnderscores
|
||||
OverloadedLabels
|
||||
OverloadedRecordDot
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
TupleSections
|
||||
TypeApplications
|
||||
ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base
|
||||
, containers
|
||||
, lens
|
||||
, semialign
|
||||
, semigroups
|
||||
, these
|
||||
, unison-core
|
||||
, unison-core1
|
||||
, unison-prelude
|
||||
, unison-util-relation
|
||||
default-language: Haskell2010
|
@ -178,6 +178,7 @@ invertDomain =
|
||||
g x acc y =
|
||||
Map.insert y x acc
|
||||
|
||||
-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements.
|
||||
fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
|
||||
fromRange m =
|
||||
BiMultimap (Map.foldlWithKey' f Map.empty m) m
|
||||
|
@ -126,7 +126,6 @@ dependencies:
|
||||
- unison-util-base32hex
|
||||
- unison-util-bytes
|
||||
- unison-util-cache
|
||||
- unison-util-nametree
|
||||
- unison-util-relation
|
||||
- unison-util-rope
|
||||
- unison-util-serialization
|
||||
|
@ -776,8 +776,8 @@ tupleTerm = foldr tupleConsTerm (unitTerm mempty)
|
||||
forceTerm :: (Var v) => a -> a -> Term v a -> Term v a
|
||||
forceTerm a au e = Term.app a e (unitTerm au)
|
||||
|
||||
delayTerm :: (Var v) => a -> Term v a -> Term v a
|
||||
delayTerm a = Term.lam a $ Var.typed Var.Delay
|
||||
delayTerm :: (Var v) => a -> a -> Term v a -> Term v a
|
||||
delayTerm spanAnn argAnn = Term.lam spanAnn (argAnn, Var.typed Var.Delay)
|
||||
|
||||
unTupleTerm ::
|
||||
Term.Term2 vt at ap v a ->
|
||||
|
@ -1,6 +1,11 @@
|
||||
module Unison.Codebase
|
||||
( Codebase,
|
||||
|
||||
-- * UCM session state
|
||||
expectCurrentProjectPath,
|
||||
setCurrentProjectPath,
|
||||
resolveProjectPathIds,
|
||||
|
||||
-- * Terms
|
||||
getTerm,
|
||||
unsafeGetTerm,
|
||||
@ -43,18 +48,20 @@ module Unison.Codebase
|
||||
lca,
|
||||
SqliteCodebase.Operations.before,
|
||||
getShallowBranchAtPath,
|
||||
getMaybeShallowBranchAtPath,
|
||||
getShallowCausalAtPath,
|
||||
getBranchAtPath,
|
||||
Operations.expectCausalBranchByCausalHash,
|
||||
getShallowCausalFromRoot,
|
||||
getShallowRootBranch,
|
||||
getShallowRootCausal,
|
||||
getShallowCausalAtPathFromRootHash,
|
||||
getShallowProjectBranchRoot,
|
||||
expectShallowProjectBranchRoot,
|
||||
getShallowBranchAtProjectPath,
|
||||
getMaybeShallowBranchAtProjectPath,
|
||||
getShallowProjectRootByNames,
|
||||
expectProjectBranchRoot,
|
||||
getBranchAtProjectPath,
|
||||
preloadProjectBranch,
|
||||
|
||||
-- * Root branch
|
||||
getRootBranch,
|
||||
SqliteCodebase.Operations.getRootBranchExists,
|
||||
Operations.expectRootCausalHash,
|
||||
putRootBranch,
|
||||
SqliteCodebase.Operations.namesAtPath,
|
||||
|
||||
-- * Patches
|
||||
@ -70,7 +77,10 @@ module Unison.Codebase
|
||||
Queries.clearWatches,
|
||||
|
||||
-- * Reflog
|
||||
Operations.getReflog,
|
||||
Operations.getDeprecatedRootReflog,
|
||||
Operations.getProjectBranchReflog,
|
||||
Operations.getProjectReflog,
|
||||
Operations.getGlobalReflog,
|
||||
|
||||
-- * Unambiguous hash length
|
||||
SqliteCodebase.Operations.hashLength,
|
||||
@ -103,16 +113,19 @@ module Unison.Codebase
|
||||
toCodeLookup,
|
||||
typeLookupForDependencies,
|
||||
unsafeGetComponentLength,
|
||||
SqliteCodebase.Operations.emptyCausalHash,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import U.Codebase.Branch qualified as V2
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.DbId qualified as Db
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Builtin qualified as Builtin
|
||||
import Unison.Builtin.Terms qualified as Builtin
|
||||
@ -122,11 +135,13 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
|
||||
import Unison.Codebase.CodeLookup qualified as CL
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
|
||||
import Unison.Codebase.Type (Codebase (..))
|
||||
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.Core.Project (ProjectAndBranch)
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Hash (Hash)
|
||||
@ -134,6 +149,7 @@ import Unison.Hashing.V2.Convert qualified as Hashing
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Parser.Ann qualified as Parser
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (ProjectAndBranch), ProjectBranchName, ProjectName)
|
||||
import Unison.Reference (Reference, TermReferenceId, TypeReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent qualified as Referent
|
||||
@ -164,72 +180,105 @@ runTransactionWithRollback ::
|
||||
runTransactionWithRollback Codebase {withConnection} action =
|
||||
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
||||
|
||||
getShallowCausalFromRoot ::
|
||||
-- Optional root branch, if Nothing use the codebase's root branch.
|
||||
Maybe CausalHash ->
|
||||
getShallowCausalAtPathFromRootHash ::
|
||||
-- Causal to start at, if Nothing use the codebase's root branch.
|
||||
CausalHash ->
|
||||
Path.Path ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalFromRoot mayRootHash p = do
|
||||
rootCausal <- case mayRootHash of
|
||||
Nothing -> getShallowRootCausal
|
||||
Just ch -> Operations.expectCausalBranchByCausalHash ch
|
||||
getShallowCausalAtPath p (Just rootCausal)
|
||||
|
||||
-- | Get the shallow representation of the root branches without loading the children or
|
||||
-- history.
|
||||
getShallowRootBranch :: Sqlite.Transaction (V2.Branch Sqlite.Transaction)
|
||||
getShallowRootBranch = do
|
||||
getShallowRootCausal >>= V2Causal.value
|
||||
|
||||
-- | Get the shallow representation of the root branches without loading the children or
|
||||
-- history.
|
||||
getShallowRootCausal :: Sqlite.Transaction (V2.CausalBranch Sqlite.Transaction)
|
||||
getShallowRootCausal = do
|
||||
hash <- Operations.expectRootCausalHash
|
||||
Operations.expectCausalBranchByCausalHash hash
|
||||
getShallowCausalAtPathFromRootHash rootCausalHash p = do
|
||||
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
|
||||
getShallowCausalAtPath p rootCausal
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowCausalAtPath ::
|
||||
Path ->
|
||||
Maybe (V2Branch.CausalBranch Sqlite.Transaction) ->
|
||||
(V2Branch.CausalBranch Sqlite.Transaction) ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalAtPath path mayCausal = do
|
||||
causal <- whenNothing mayCausal getShallowRootCausal
|
||||
getShallowCausalAtPath path causal = do
|
||||
case path of
|
||||
Path.Empty -> pure causal
|
||||
ns Path.:< p -> do
|
||||
b <- V2Causal.value causal
|
||||
case V2Branch.childAt ns b of
|
||||
Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
|
||||
Just childCausal -> getShallowCausalAtPath p (Just childCausal)
|
||||
Just childCausal -> getShallowCausalAtPath p childCausal
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowBranchAtPath ::
|
||||
Path ->
|
||||
Maybe (V2Branch.Branch Sqlite.Transaction) ->
|
||||
V2Branch.Branch Sqlite.Transaction ->
|
||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowBranchAtPath path mayBranch = do
|
||||
branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
|
||||
getShallowBranchAtPath path branch = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtPath path branch
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getMaybeShallowBranchAtPath ::
|
||||
Path ->
|
||||
V2Branch.Branch Sqlite.Transaction ->
|
||||
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getMaybeShallowBranchAtPath path branch = do
|
||||
case path of
|
||||
Path.Empty -> pure branch
|
||||
Path.Empty -> pure $ Just branch
|
||||
ns Path.:< p -> do
|
||||
case V2Branch.childAt ns branch of
|
||||
Nothing -> pure V2Branch.empty
|
||||
Nothing -> pure Nothing
|
||||
Just childCausal -> do
|
||||
childBranch <- V2Causal.value childCausal
|
||||
getShallowBranchAtPath p (Just childBranch)
|
||||
getMaybeShallowBranchAtPath p childBranch
|
||||
|
||||
-- | Get a v1 branch from the root following the given path.
|
||||
getBranchAtPath ::
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowBranchAtProjectPath ::
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowBranchAtProjectPath pp = fromMaybe V2Branch.empty <$> getMaybeShallowBranchAtProjectPath pp
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getMaybeShallowBranchAtProjectPath ::
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getMaybeShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
|
||||
getShallowProjectBranchRoot projectBranch >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just projectRootBranch -> getMaybeShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
||||
|
||||
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
||||
getShallowProjectRootByNames (ProjectAndBranch projectName branchName) = runMaybeT do
|
||||
ProjectBranch {projectId, branchId} <- MaybeT $ Q.loadProjectBranchByNames projectName branchName
|
||||
causalHashId <- lift $ Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- lift $ Q.expectCausalHash causalHashId
|
||||
lift $ Operations.expectCausalBranchByCausalHash causalHash
|
||||
|
||||
expectProjectBranchRoot :: (MonadIO m) => Codebase m v a -> Db.ProjectId -> Db.ProjectBranchId -> m (Branch m)
|
||||
expectProjectBranchRoot codebase projectId branchId = do
|
||||
causalHash <- runTransaction codebase $ do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
Q.expectCausalHash causalHashId
|
||||
expectBranchForHash codebase causalHash
|
||||
|
||||
expectShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
expectShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- Q.expectCausalHash causalHashId
|
||||
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
||||
|
||||
getShallowProjectBranchRoot :: ProjectBranch -> Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
|
||||
getShallowProjectBranchRoot ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
causalHash <- Q.expectCausalHash causalHashId
|
||||
Operations.loadCausalBranchByCausalHash causalHash >>= traverse V2Causal.value
|
||||
|
||||
getBranchAtProjectPath ::
|
||||
(MonadIO m) =>
|
||||
Codebase m v a ->
|
||||
Path.Absolute ->
|
||||
m (Branch m)
|
||||
getBranchAtPath codebase path = do
|
||||
V2Causal.Causal {causalHash} <- runTransaction codebase $ getShallowCausalAtPath (Path.unabsolute path) Nothing
|
||||
expectBranchForHash codebase causalHash
|
||||
PP.ProjectPath ->
|
||||
m (Maybe (Branch m))
|
||||
getBranchAtProjectPath codebase pp = runMaybeT do
|
||||
rootBranch <- lift $ expectProjectBranchRoot codebase pp.branch.projectId pp.branch.branchId
|
||||
hoistMaybe $ Branch.getAt (pp ^. PP.path_) rootBranch
|
||||
|
||||
-- | Like 'getBranchForHash', but for when the hash is known to be in the codebase.
|
||||
expectBranchForHash :: (Monad m) => Codebase m v a -> CausalHash -> m (Branch m)
|
||||
@ -347,9 +396,12 @@ typeLookupForDependencies codebase s = do
|
||||
unseen :: TL.TypeLookup Symbol a -> Reference -> Bool
|
||||
unseen tl r =
|
||||
isNothing
|
||||
( Map.lookup r (TL.dataDecls tl) $> ()
|
||||
<|> Map.lookup r (TL.typeOfTerms tl) $> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl) $> ()
|
||||
( Map.lookup r (TL.dataDecls tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.typeOfTerms tl)
|
||||
$> ()
|
||||
<|> Map.lookup r (TL.effectDecls tl)
|
||||
$> ()
|
||||
)
|
||||
|
||||
toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
||||
@ -509,3 +561,30 @@ unsafeGetTermComponent codebase hash =
|
||||
getTermComponentWithTypes codebase hash <&> \case
|
||||
Nothing -> error (reportBug "E769004" ("term component " ++ show hash ++ " not found"))
|
||||
Just terms -> terms
|
||||
|
||||
expectCurrentProjectPath :: (HasCallStack) => Sqlite.Transaction PP.ProjectPath
|
||||
expectCurrentProjectPath = do
|
||||
(projectId, projectBranchId, path) <- Q.expectCurrentProjectPath
|
||||
proj <- Q.expectProject projectId
|
||||
projBranch <- Q.expectProjectBranch projectId projectBranchId
|
||||
let absPath = Path.Absolute (Path.fromList path)
|
||||
pure $ PP.ProjectPath proj projBranch absPath
|
||||
|
||||
setCurrentProjectPath :: PP.ProjectPathIds -> Sqlite.Transaction ()
|
||||
setCurrentProjectPath (PP.ProjectPath projectId projectBranchId path) =
|
||||
Q.setCurrentProjectPath projectId projectBranchId (Path.toList (Path.unabsolute path))
|
||||
|
||||
-- | Hydrate the project and branch from IDs.
|
||||
resolveProjectPathIds :: PP.ProjectPathIds -> Sqlite.Transaction PP.ProjectPath
|
||||
resolveProjectPathIds (PP.ProjectPath projectId projectBranchId path) = do
|
||||
proj <- Q.expectProject projectId
|
||||
projBranch <- Q.expectProjectBranch projectId projectBranchId
|
||||
pure $ PP.ProjectPath proj projBranch path
|
||||
|
||||
-- | Starts loading the given project branch into cache in a background thread without blocking.
|
||||
preloadProjectBranch :: (MonadUnliftIO m) => Codebase m v a -> ProjectAndBranch Db.ProjectId Db.ProjectBranchId -> m ()
|
||||
preloadProjectBranch codebase (ProjectAndBranch projectId branchId) = do
|
||||
ch <- runTransaction codebase $ do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
Q.expectCausalHash causalHashId
|
||||
preloadBranch codebase ch
|
||||
|
@ -139,6 +139,7 @@ import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.List qualified as List
|
||||
@ -148,7 +149,6 @@ import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Witherable (FilterableWithIndex (imapMaybe))
|
||||
import Prelude hiding (head, read, subtract)
|
||||
import qualified Unison.Reference as Reference
|
||||
|
||||
instance AsEmpty (Branch m) where
|
||||
_Empty = prism' (const empty) matchEmpty
|
||||
@ -215,7 +215,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
|
||||
deepTypeReferenceIds =
|
||||
Set.mapMaybe Reference.toId . deepTypeReferences
|
||||
|
||||
|
||||
namespaceStats :: Branch0 m -> NamespaceStats
|
||||
namespaceStats b =
|
||||
NamespaceStats
|
||||
|
@ -25,6 +25,7 @@ import Unison.Codebase.Branch (Branch, Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.HashQualifiedPrime (HashQualified (HashQualified, NameOnly))
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
@ -69,10 +70,10 @@ getBranch (p, seg) b = case Path.toList p of
|
||||
(Branch.head <$> Map.lookup h (b ^. Branch.children))
|
||||
>>= getBranch (Path.fromList p, seg)
|
||||
|
||||
makeAddTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m)
|
||||
makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
|
||||
makeAddTermName (p, name) r = (p, Branch.addTermName r name)
|
||||
|
||||
makeDeleteTermName :: Path.Split -> Referent -> (Path, Branch0 m -> Branch0 m)
|
||||
makeDeleteTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
|
||||
makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name)
|
||||
|
||||
makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
|
||||
@ -81,10 +82,10 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name)
|
||||
makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
|
||||
makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name)
|
||||
|
||||
makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
|
||||
makeAddTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
|
||||
makeAddTypeName (p, name) r = (p, Branch.addTypeName r name)
|
||||
|
||||
makeDeleteTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m)
|
||||
makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
|
||||
makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name)
|
||||
|
||||
makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)
|
||||
|
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Unison.Codebase.Causal
|
||||
( Causal (currentHash, head, tail, tails),
|
||||
( Causal (currentHash, valueHash, head, tail, tails),
|
||||
pattern One,
|
||||
pattern Cons,
|
||||
pattern Merge,
|
||||
@ -40,7 +40,8 @@ import Unison.Codebase.Causal.Type
|
||||
currentHash,
|
||||
head,
|
||||
tail,
|
||||
tails
|
||||
tails,
|
||||
valueHash
|
||||
),
|
||||
before,
|
||||
lca,
|
||||
|
@ -1,8 +1,5 @@
|
||||
module Unison.Codebase.Editor.RemoteRepo where
|
||||
|
||||
import Control.Lens (Lens')
|
||||
import Control.Lens qualified as Lens
|
||||
import Data.Void (absurd)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
@ -35,12 +32,6 @@ displayShareCodeserver cs shareUser path =
|
||||
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
|
||||
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
|
||||
|
||||
writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void
|
||||
writeNamespaceToRead = \case
|
||||
WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} ->
|
||||
ReadShare'LooseCode ReadShareLooseCode {server, repo, path}
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
-- | print remote namespace
|
||||
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
|
||||
printReadRemoteNamespace printProject = \case
|
||||
@ -48,11 +39,8 @@ printReadRemoteNamespace printProject = \case
|
||||
ReadShare'ProjectBranch project -> printProject project
|
||||
|
||||
-- | Render a 'WriteRemoteNamespace' as text.
|
||||
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||
printWriteRemoteNamespace = \case
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
|
||||
displayShareCodeserver server repo path
|
||||
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
|
||||
printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||
printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
|
||||
|
||||
maybePrintPath :: Path -> Text
|
||||
maybePrintPath path =
|
||||
@ -80,28 +68,3 @@ isPublic ReadShareLooseCode {path} =
|
||||
case path of
|
||||
(segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
|
||||
_ -> False
|
||||
|
||||
data WriteRemoteNamespace a
|
||||
= WriteRemoteNamespaceShare !WriteShareRemoteNamespace
|
||||
| WriteRemoteProjectBranch a
|
||||
deriving stock (Eq, Functor, Show)
|
||||
|
||||
-- | A lens which focuses the path of a remote namespace.
|
||||
remotePath_ :: Lens' (WriteRemoteNamespace Void) Path
|
||||
remotePath_ = Lens.lens getter setter
|
||||
where
|
||||
getter = \case
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
setter remote path =
|
||||
case remote of
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) ->
|
||||
WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
data WriteShareRemoteNamespace = WriteShareRemoteNamespace
|
||||
{ server :: !ShareCodeserver,
|
||||
repo :: !ShareUserHandle,
|
||||
path :: !Path
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
@ -6,19 +6,23 @@
|
||||
module Unison.Codebase.Execute where
|
||||
|
||||
import Control.Exception (finally)
|
||||
import Control.Monad.Except (throwError, runExceptT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Except
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.MainTerm (getMainTerm)
|
||||
import Unison.Codebase.MainTerm qualified as MainTerm
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
@ -27,15 +31,22 @@ import Unison.Util.Pretty qualified as P
|
||||
execute ::
|
||||
Codebase.Codebase IO Symbol Ann ->
|
||||
Runtime Symbol ->
|
||||
HQ.HashQualified Name ->
|
||||
PP.ProjectPathNames ->
|
||||
IO (Either Runtime.Error ())
|
||||
execute codebase runtime mainName =
|
||||
execute codebase runtime mainPath =
|
||||
(`finally` Runtime.terminate runtime) . runExceptT $ do
|
||||
root <- liftIO $ Codebase.getRootBranch codebase
|
||||
let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
|
||||
loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||
(project, branch) <- ExceptT $ (Codebase.runTransactionWithRollback codebase) \rollback -> do
|
||||
project <- Q.loadProjectByName mainPath.project `whenNothingM` rollback (Left . P.text $ ("Project not found: " <> into @Text mainPath.project))
|
||||
branch <- Q.loadProjectBranchByName project.projectId mainPath.branch `whenNothingM` rollback (Left . P.text $ ("Branch not found: " <> into @Text mainPath.branch))
|
||||
pure . Right $ (project, branch)
|
||||
projectRootNames <- fmap (Branch.toNames . Branch.head) . liftIO $ Codebase.expectProjectBranchRoot codebase project.projectId branch.branchId
|
||||
let loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||
let mainType = Runtime.mainType runtime
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
|
||||
mainName <- case Path.toName (mainPath ^. PP.path_) of
|
||||
Just n -> pure (HQ.NameOnly n)
|
||||
Nothing -> throwError ("Path must lead to an executable term: " <> P.text (Path.toText (PP.path mainPath)))
|
||||
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm projectRootNames mainName mainType
|
||||
case mt of
|
||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s))
|
||||
MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()")
|
||||
|
@ -5,7 +5,9 @@ module Unison.Codebase.Path
|
||||
Path' (..),
|
||||
Absolute (..),
|
||||
pattern AbsolutePath',
|
||||
absPath_,
|
||||
Relative (..),
|
||||
relPath_,
|
||||
pattern RelativePath',
|
||||
Resolve (..),
|
||||
pattern Empty,
|
||||
@ -30,6 +32,8 @@ module Unison.Codebase.Path
|
||||
prefixNameIfRel,
|
||||
unprefixName,
|
||||
HQSplit,
|
||||
HQSplitAbsolute,
|
||||
AbsSplit,
|
||||
Split,
|
||||
Split',
|
||||
HQSplit',
|
||||
@ -58,6 +62,8 @@ module Unison.Codebase.Path
|
||||
toName',
|
||||
toText,
|
||||
toText',
|
||||
absToText,
|
||||
relToText,
|
||||
unsplit,
|
||||
unsplit',
|
||||
unsplitAbsolute,
|
||||
@ -113,12 +119,19 @@ instance GHC.IsList Path where
|
||||
toList (Path segs) = Foldable.toList segs
|
||||
fromList = Path . Seq.fromList
|
||||
|
||||
-- | A namespace path that starts from the root.
|
||||
-- | An absolute from the current project root
|
||||
newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord)
|
||||
|
||||
absPath_ :: Lens' Absolute Path
|
||||
absPath_ = lens unabsolute (\_ new -> Absolute new)
|
||||
|
||||
-- | A namespace path that doesn’t necessarily start from the root.
|
||||
-- Typically refers to a path from the current namespace.
|
||||
newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord)
|
||||
|
||||
relPath_ :: Lens' Relative Path
|
||||
relPath_ = lens unrelative (\_ new -> Relative new)
|
||||
|
||||
-- | A namespace that may be either absolute or relative, This is the most general type that should be used.
|
||||
newtype Path' = Path' {unPath' :: Either Absolute Relative}
|
||||
deriving (Eq, Ord)
|
||||
@ -148,14 +161,14 @@ absoluteToPath' = AbsolutePath'
|
||||
|
||||
instance Show Path' where
|
||||
show = \case
|
||||
AbsolutePath' abs -> show abs
|
||||
RelativePath' rel -> show rel
|
||||
AbsolutePath' abs -> Text.unpack $ absToText abs
|
||||
RelativePath' rel -> Text.unpack $ relToText rel
|
||||
|
||||
instance Show Absolute where
|
||||
show s = "." ++ show (unabsolute s)
|
||||
show s = Text.unpack $ absToText s
|
||||
|
||||
instance Show Relative where
|
||||
show = show . unrelative
|
||||
show = Text.unpack . relToText
|
||||
|
||||
unsplit' :: Split' -> Path'
|
||||
unsplit' = \case
|
||||
@ -175,6 +188,8 @@ nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative)
|
||||
nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
|
||||
nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
|
||||
|
||||
type AbsSplit = (Absolute, NameSegment)
|
||||
|
||||
type Split = (Path, NameSegment)
|
||||
|
||||
type HQSplit = (Path, HQ'.HQSegment)
|
||||
@ -368,11 +383,29 @@ empty = Path mempty
|
||||
instance Show Path where
|
||||
show = Text.unpack . toText
|
||||
|
||||
instance From Path Text where
|
||||
from = toText
|
||||
|
||||
instance From Absolute Text where
|
||||
from = absToText
|
||||
|
||||
instance From Relative Text where
|
||||
from = relToText
|
||||
|
||||
instance From Path' Text where
|
||||
from = toText'
|
||||
|
||||
-- | Note: This treats the path as relative.
|
||||
toText :: Path -> Text
|
||||
toText =
|
||||
maybe Text.empty Name.toText . toName
|
||||
|
||||
absToText :: Absolute -> Text
|
||||
absToText abs = "." <> toText (unabsolute abs)
|
||||
|
||||
relToText :: Relative -> Text
|
||||
relToText rel = toText (unrelative rel)
|
||||
|
||||
unsafeParseText :: Text -> Path
|
||||
unsafeParseText = \case
|
||||
"" -> empty
|
||||
@ -509,6 +542,9 @@ instance Resolve Absolute Relative Absolute where
|
||||
instance Resolve Absolute Relative Path' where
|
||||
resolve l r = AbsolutePath' (resolve l r)
|
||||
|
||||
instance Resolve Absolute Path Absolute where
|
||||
resolve (Absolute l) r = Absolute (resolve l r)
|
||||
|
||||
instance Resolve Path' Path' Path' where
|
||||
resolve _ a@(AbsolutePath' {}) = a
|
||||
resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
|
||||
|
136
parser-typechecker/src/Unison/Codebase/ProjectPath.hs
Normal file
136
parser-typechecker/src/Unison/Codebase/ProjectPath.hs
Normal file
@ -0,0 +1,136 @@
|
||||
module Unison.Codebase.ProjectPath
|
||||
( ProjectPathG (..),
|
||||
ProjectPathIds,
|
||||
ProjectPathNames,
|
||||
ProjectPath,
|
||||
fromProjectAndBranch,
|
||||
projectBranchRoot,
|
||||
toRoot,
|
||||
absPath_,
|
||||
path_,
|
||||
path,
|
||||
toProjectAndBranch,
|
||||
projectAndBranch_,
|
||||
toText,
|
||||
toIds,
|
||||
toNames,
|
||||
projectPathParser,
|
||||
parseProjectPath,
|
||||
|
||||
-- * Re-exports, this also helps with using dot-notation
|
||||
ProjectAndBranch (..),
|
||||
Project (..),
|
||||
ProjectBranch (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens hiding (from)
|
||||
import Data.Bifoldable (Bifoldable (..))
|
||||
import Data.Bitraversable (Bitraversable (..))
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Text.Megaparsec.Char qualified as Megaparsec
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project qualified as Project
|
||||
|
||||
data ProjectPathG proj branch = ProjectPath
|
||||
{ project :: proj,
|
||||
branch :: branch,
|
||||
absPath :: Path.Absolute
|
||||
}
|
||||
deriving stock (Eq, Ord, Show, Generic)
|
||||
|
||||
type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId
|
||||
|
||||
type ProjectPathNames = ProjectPathG ProjectName ProjectBranchName
|
||||
|
||||
instance From ProjectPath Text where
|
||||
from = from . toNames
|
||||
|
||||
instance From ProjectPathNames Text where
|
||||
from (ProjectPath proj branch (Path.Absolute path)) =
|
||||
into @Text (ProjectAndBranch proj branch) <> ":" <> Path.toText path
|
||||
|
||||
instance From (ProjectPathG () ProjectBranchName) Text where
|
||||
from (ProjectPath () branch (Path.Absolute path)) =
|
||||
"/" <> into @Text branch <> ":" <> Path.toText path
|
||||
|
||||
type ProjectPath = ProjectPathG Project ProjectBranch
|
||||
|
||||
projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath
|
||||
projectBranchRoot (ProjectAndBranch proj branch) = ProjectPath proj branch Path.absoluteEmpty
|
||||
|
||||
-- | Discard any path within the project and get the project's root
|
||||
toRoot :: ProjectPath -> ProjectPath
|
||||
toRoot (ProjectPath proj branch _) = ProjectPath proj branch Path.absoluteEmpty
|
||||
|
||||
fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath
|
||||
fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path
|
||||
|
||||
-- | Project a project context into a project path of just IDs
|
||||
toIds :: ProjectPath -> ProjectPathIds
|
||||
toIds (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path
|
||||
|
||||
-- | Project a project context into a project path of just names
|
||||
toNames :: ProjectPath -> ProjectPathNames
|
||||
toNames (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path
|
||||
|
||||
toProjectAndBranch :: ProjectPathG p b -> ProjectAndBranch p b
|
||||
toProjectAndBranch (ProjectPath proj branch _) = ProjectAndBranch proj branch
|
||||
|
||||
instance Bifunctor ProjectPathG where
|
||||
bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path
|
||||
|
||||
instance Bifoldable ProjectPathG where
|
||||
bifoldMap f g (ProjectPath p b _) = f p <> g b
|
||||
|
||||
instance Bitraversable ProjectPathG where
|
||||
bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path
|
||||
|
||||
toText :: ProjectPathG Project ProjectBranch -> Text
|
||||
toText (ProjectPath proj branch path) =
|
||||
into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path
|
||||
|
||||
absPath_ :: Lens' (ProjectPathG p b) Path.Absolute
|
||||
absPath_ = lens absPath set
|
||||
where
|
||||
set (ProjectPath n b _) p = ProjectPath n b p
|
||||
|
||||
path :: (ProjectPathG p b) -> Path.Path
|
||||
path (ProjectPath _ _ p) = Path.unabsolute p
|
||||
|
||||
path_ :: Lens' (ProjectPathG p b) Path.Path
|
||||
path_ = absPath_ . Path.absPath_
|
||||
|
||||
projectAndBranch_ :: Lens (ProjectPathG p b) (ProjectPathG p' b') (ProjectAndBranch p b) (ProjectAndBranch p' b')
|
||||
projectAndBranch_ = lens go set
|
||||
where
|
||||
go (ProjectPath proj branch _) = ProjectAndBranch proj branch
|
||||
set (ProjectPath _ _ p) (ProjectAndBranch proj branch) = ProjectPath proj branch p
|
||||
|
||||
type Parser = Megaparsec.Parsec Void Text
|
||||
|
||||
projectPathParser :: Parser ProjectPathNames
|
||||
projectPathParser = do
|
||||
(projName, hasTrailingSlash) <- Project.projectNameParser
|
||||
projBranchName <- Project.projectBranchNameParser (not hasTrailingSlash)
|
||||
_ <- Megaparsec.char ':'
|
||||
path' >>= \case
|
||||
Path.AbsolutePath' p -> pure $ ProjectPath projName projBranchName p
|
||||
Path.RelativePath' {} -> fail "Expected an absolute path"
|
||||
where
|
||||
path' :: Parser Path.Path'
|
||||
path' = do
|
||||
pathStr <- Megaparsec.takeRest
|
||||
case Path.parsePath' (Text.unpack pathStr) of
|
||||
Left err -> fail (Text.unpack err)
|
||||
Right x -> pure x
|
||||
|
||||
parseProjectPath :: Text -> Either Text ProjectPathNames
|
||||
parseProjectPath txt = first (Text.pack . Megaparsec.errorBundlePretty) $ Megaparsec.parse projectPathParser "" txt
|
@ -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
|
@ -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
|
||||
|
@ -18,12 +18,9 @@ import Data.Either.Extra ()
|
||||
import Data.IORef
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Time (getCurrentTime)
|
||||
import System.Console.ANSI qualified as ANSI
|
||||
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
|
||||
import U.Codebase.HashTags (CausalHash, PatchHash (..))
|
||||
import U.Codebase.Reflog qualified as Reflog
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Sync22 qualified as Sync22
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
@ -37,10 +34,8 @@ import Unison.Codebase.Init qualified as Codebase
|
||||
import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1
|
||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||
import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1
|
||||
import Unison.Codebase.RootBranchCache
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
||||
import Unison.Codebase.SqliteCodebase.Paths
|
||||
@ -59,9 +54,12 @@ import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Util.Cache qualified as Cache
|
||||
import Unison.Util.Timing (time)
|
||||
import Unison.WatchKind qualified as UF
|
||||
import UnliftIO (UnliftIO (..), finally)
|
||||
import UnliftIO qualified as UnliftIO
|
||||
import UnliftIO.Concurrent qualified as UnliftIO
|
||||
import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import UnliftIO.STM
|
||||
|
||||
@ -106,8 +104,7 @@ createCodebaseOrError onCreate debugName path lockOption action = do
|
||||
withConnection (debugName ++ ".createSchema") path \conn -> do
|
||||
Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
|
||||
Sqlite.runTransaction conn do
|
||||
Q.createSchema
|
||||
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
|
||||
CodebaseOps.createSchema
|
||||
onCreate
|
||||
|
||||
sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case
|
||||
@ -136,7 +133,7 @@ initSchemaIfNotExist path = liftIO do
|
||||
createDirectoryIfMissing True (makeCodebaseDirPath path)
|
||||
unlessM (doesFileExist $ makeCodebasePath path) $
|
||||
withConnection "initSchemaIfNotExist" path \conn ->
|
||||
Sqlite.runTransaction conn Q.createSchema
|
||||
Sqlite.runTransaction conn CodebaseOps.createSchema
|
||||
|
||||
-- 1) buffer up the component
|
||||
-- 2) in the event that the component is complete, then what?
|
||||
@ -167,8 +164,17 @@ sqliteCodebase ::
|
||||
(Codebase m Symbol Ann -> m r) ->
|
||||
m (Either Codebase1.OpenCodebaseError r)
|
||||
sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do
|
||||
rootBranchCache <- newEmptyRootBranchCacheIO
|
||||
branchCache <- newBranchCache
|
||||
-- The branchLoadCache ephemerally caches branches in memory, but doesn't prevent them from being GC'd.
|
||||
-- This is very useful when loading root branches because the cache shouldn't be limited in size.
|
||||
-- But this cache will automatically clean itself up and remove entries that are no longer reachable.
|
||||
-- If you load another branch, which shares namespaces with another branch that's in memory (and therefor in the cache)
|
||||
-- then those shared namespaces will be loaded from the cache and will be shared in memory.
|
||||
branchLoadCache <- newBranchCache
|
||||
-- The rootBranchCache is a semispace cache which keeps the most recent branch roots (e.g. project roots) alive in memory.
|
||||
-- Unlike the branchLoadCache, this cache is bounded in size and will evict older branches when it reaches its limit.
|
||||
-- The two work in tandem, so the rootBranchCache keeps relevant branches alive, and the branchLoadCache
|
||||
-- stores ALL the subnamespaces of those branches, deduping them when loading from the DB.
|
||||
rootBranchCache <- Cache.semispaceCache 10
|
||||
getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
|
||||
-- The v1 codebase interface has operations to read and write individual definitions
|
||||
-- whereas the v2 codebase writes them as complete components. These two fields buffer
|
||||
@ -238,47 +244,28 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
putTypeDeclarationComponent =
|
||||
CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer
|
||||
|
||||
getRootBranch :: m (Branch m)
|
||||
getRootBranch =
|
||||
Branch.transform runTransaction
|
||||
<$> fetchRootBranch
|
||||
rootBranchCache
|
||||
(runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType))
|
||||
|
||||
putRootBranch :: Text -> Branch m -> m ()
|
||||
putRootBranch reason branch1 = do
|
||||
now <- liftIO getCurrentTime
|
||||
withRunInIO \runInIO -> do
|
||||
-- this is naughty, the type says Transaction but it
|
||||
-- won't run automatically with whatever Transaction
|
||||
-- it is composed into unless the enclosing
|
||||
-- Transaction is applied to the same db connection.
|
||||
let branch1Trans = Branch.transform (Sqlite.unsafeIO . runInIO) branch1
|
||||
putRootBranchTrans :: Sqlite.Transaction () = do
|
||||
let emptyCausalHash = Branch.headHash Branch.empty
|
||||
fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash
|
||||
let toRootCausalHash = Branch.headHash branch1
|
||||
CodebaseOps.putRootBranch branch1Trans
|
||||
Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason})
|
||||
|
||||
-- We need to update the database and the cached
|
||||
-- value. We want to keep these in sync, so we take
|
||||
-- the cache lock while updating sqlite.
|
||||
withLock
|
||||
rootBranchCache
|
||||
(\restore _ -> restore $ runInIO $ runTransaction putRootBranchTrans)
|
||||
(\_ -> Just branch1Trans)
|
||||
|
||||
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||
-- to one that returns Maybe.
|
||||
getBranchForHash :: CausalHash -> m (Maybe (Branch m))
|
||||
getBranchForHash h =
|
||||
fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h)
|
||||
getBranchForHash =
|
||||
Cache.applyDefined rootBranchCache \h -> do
|
||||
fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchLoadCache getDeclType h)
|
||||
|
||||
putBranch :: Branch m -> m ()
|
||||
putBranch branch =
|
||||
withRunInIO \runInIO ->
|
||||
runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)))
|
||||
runInIO $ do
|
||||
Cache.insert rootBranchCache (Branch.headHash branch) branch
|
||||
runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))
|
||||
|
||||
preloadBranch :: CausalHash -> m ()
|
||||
preloadBranch h = do
|
||||
void . UnliftIO.forkIO $ void $ do
|
||||
getBranchForHash h >>= \case
|
||||
Nothing -> pure ()
|
||||
Just b -> do
|
||||
UnliftIO.evaluate b
|
||||
pure ()
|
||||
|
||||
syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m ()
|
||||
syncFromDirectory srcRoot b =
|
||||
@ -334,8 +321,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
putTypeDeclaration,
|
||||
putTypeDeclarationComponent,
|
||||
getTermComponentWithTypes,
|
||||
getRootBranch,
|
||||
putRootBranch,
|
||||
getBranchForHash,
|
||||
putBranch,
|
||||
syncFromDirectory,
|
||||
@ -347,7 +332,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
filterTermsByReferentIdHavingTypeImpl,
|
||||
termReferentsByPrefix = referentsByPrefix,
|
||||
withConnection = withConn,
|
||||
withConnectionIO = withConnection debugName root
|
||||
withConnectionIO = withConnection debugName root,
|
||||
preloadBranch
|
||||
}
|
||||
Right <$> action codebase
|
||||
where
|
||||
|
@ -21,6 +21,7 @@ import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase
|
||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4)
|
||||
import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6)
|
||||
@ -30,27 +31,28 @@ import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2
|
||||
import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath)
|
||||
import Unison.Codebase.Type (LocalOrRemote (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sqlite.Connection qualified as Sqlite.Connection
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import UnliftIO qualified
|
||||
|
||||
-- | Mapping from schema version to the migration required to get there.
|
||||
-- E.g. The migration at index 2 must be run on a codebase at version 1.
|
||||
migrations ::
|
||||
(MVar Region.ConsoleRegion) ->
|
||||
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
|
||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||
TVar (Map Hash Ops2.TermBufferEntry) ->
|
||||
TVar (Map Hash Ops2.DeclBufferEntry) ->
|
||||
CodebasePath ->
|
||||
Map SchemaVersion (Sqlite.Transaction ())
|
||||
migrations getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
Map SchemaVersion (Sqlite.Connection -> IO ())
|
||||
migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
Map.fromList
|
||||
[ (2, migrateSchema1To2 getDeclType termBuffer declBuffer),
|
||||
[ (2, runT $ migrateSchema1To2 getDeclType termBuffer declBuffer),
|
||||
-- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this
|
||||
-- caused an issue:
|
||||
--
|
||||
@ -67,30 +69,34 @@ migrations getDeclType termBuffer declBuffer rootCodebasePath =
|
||||
-- This migration drops all the v1 hash objects to avoid this issue, since these hash objects
|
||||
-- weren't being used for anything anyways.
|
||||
sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)),
|
||||
(4, migrateSchema3To4),
|
||||
(4, runT (migrateSchema3To4 *> runIntegrityChecks regionVar)),
|
||||
-- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share
|
||||
sqlMigration 5 Q.addTempEntityTables,
|
||||
(6, migrateSchema5To6 rootCodebasePath),
|
||||
(7, migrateSchema6To7),
|
||||
(8, migrateSchema7To8),
|
||||
(6, runT $ migrateSchema5To6 rootCodebasePath),
|
||||
(7, runT (migrateSchema6To7 *> runIntegrityChecks regionVar)),
|
||||
(8, runT migrateSchema7To8),
|
||||
-- Recreates the name lookup tables because the primary key was missing the root hash id.
|
||||
sqlMigration 9 Q.fixScopedNameLookupTables,
|
||||
sqlMigration 10 Q.addProjectTables,
|
||||
sqlMigration 11 Q.addMostRecentBranchTable,
|
||||
(12, migrateSchema11To12),
|
||||
(12, runT migrateSchema11To12),
|
||||
sqlMigration 13 Q.addMostRecentNamespaceTable,
|
||||
sqlMigration 14 Q.addSquashResultTable,
|
||||
sqlMigration 15 Q.addSquashResultTableIfNotExists,
|
||||
sqlMigration 16 Q.cdToProjectRoot
|
||||
sqlMigration 16 Q.cdToProjectRoot,
|
||||
(17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn)
|
||||
]
|
||||
where
|
||||
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Transaction ())
|
||||
runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()
|
||||
runT t conn = Sqlite.runWriteTransaction conn (\run -> run t)
|
||||
sqlMigration :: SchemaVersion -> Sqlite.Transaction () -> (SchemaVersion, Sqlite.Connection -> IO ())
|
||||
sqlMigration ver migration =
|
||||
( ver,
|
||||
do
|
||||
Q.expectSchemaVersion (ver - 1)
|
||||
migration
|
||||
Q.setSchemaVersion ver
|
||||
\conn -> Sqlite.runWriteTransaction conn \run -> run
|
||||
do
|
||||
Q.expectSchemaVersion (ver - 1)
|
||||
migration
|
||||
Q.setSchemaVersion ver
|
||||
)
|
||||
|
||||
data CodebaseVersionStatus
|
||||
@ -140,7 +146,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
|
||||
Region.displayConsoleRegions do
|
||||
(`UnliftIO.finally` finalizeRegion) do
|
||||
let migs = migrations getDeclType termBuffer declBuffer root
|
||||
let migs = migrations regionVar getDeclType termBuffer declBuffer root
|
||||
-- The highest schema that this ucm knows how to migrate to.
|
||||
let highestKnownSchemaVersion = fst . head $ Map.toDescList migs
|
||||
currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion
|
||||
@ -149,11 +155,10 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
when shouldPrompt do
|
||||
putStrLn "Press <enter> to start the migration once all other ucm processes are shutdown..."
|
||||
void $ liftIO getLine
|
||||
ranMigrations <-
|
||||
Sqlite.runWriteTransaction conn \run -> do
|
||||
ranMigrations <- do
|
||||
currentSchemaVersion <- Sqlite.runTransaction conn $ do
|
||||
-- Get the schema version again now that we're in a transaction.
|
||||
currentSchemaVersion <- run Q.schemaVersion
|
||||
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
||||
Q.schemaVersion
|
||||
-- This is a bit of a hack, hopefully we can remove this when we have a more
|
||||
-- reliable way to freeze old migration code in time.
|
||||
-- The problem is that 'saveObject' has been changed to flush temp entity tables,
|
||||
@ -163,48 +168,29 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh
|
||||
--
|
||||
-- Hopefully we can remove this once we've got better methods of freezing migration
|
||||
-- code in time.
|
||||
when (currentSchemaVersion < 5) $ run Q.addTempEntityTables
|
||||
when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables
|
||||
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
||||
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
||||
run migration
|
||||
let ranMigrations = not (null migrationsToRun)
|
||||
when ranMigrations do
|
||||
region <-
|
||||
UnliftIO.mask_ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
result <- do
|
||||
-- Ideally we'd check everything here, but certain codebases are known to have objects
|
||||
-- with missing Hash Objects, we'll want to clean that up in a future migration.
|
||||
-- integrityCheckAllHashObjects,
|
||||
let checks =
|
||||
Monoid.whenM
|
||||
(currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked
|
||||
[ integrityCheckAllBranches,
|
||||
integrityCheckAllCausals
|
||||
]
|
||||
|
||||
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
|
||||
Region.setConsoleRegion
|
||||
region
|
||||
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
|
||||
run check
|
||||
case result of
|
||||
NoIntegrityErrors -> pure ()
|
||||
IntegrityErrorDetected errs -> do
|
||||
let msg = prettyPrintIntegrityErrors errs
|
||||
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
|
||||
Region.setConsoleRegion region (Text.pack rendered)
|
||||
run (abortMigration "Codebase integrity error detected.")
|
||||
pure ranMigrations
|
||||
when (currentSchemaVersion < 5) Q.addTempEntityTables
|
||||
when (currentSchemaVersion < 6) Q.addNamespaceStatsTables
|
||||
pure currentSchemaVersion
|
||||
let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs
|
||||
for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do
|
||||
putStrLn $ "🔨 Migrating codebase to version " <> show v <> "..."
|
||||
migration conn
|
||||
let ranMigrations = not (null migrationsToRun)
|
||||
pure ranMigrations
|
||||
Debug.debugLogM Debug.Migration "Migrations complete"
|
||||
when ranMigrations do
|
||||
region <- readMVar regionVar
|
||||
region <-
|
||||
UnliftIO.mask_ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
-- Vacuum once now that any migrations have taken place.
|
||||
Region.setConsoleRegion region ("✅ All good, cleaning up..." :: Text)
|
||||
case vacuumStrategy of
|
||||
Vacuum -> void $ Sqlite.Connection.vacuum conn
|
||||
Vacuum -> do
|
||||
Debug.debugLogM Debug.Migration "About to VACUUM"
|
||||
void $ Sqlite.Connection.vacuum conn
|
||||
Debug.debugLogM Debug.Migration "Done VACUUM"
|
||||
NoVacuum -> pure ()
|
||||
Region.setConsoleRegion region ("🏁 Migrations complete 🏁" :: Text)
|
||||
|
||||
@ -224,3 +210,34 @@ backupCodebaseIfNecessary backupStrategy localOrRemote conn currentSchemaVersion
|
||||
Sqlite.trySetJournalMode backupConn Sqlite.JournalMode'WAL
|
||||
putStrLn ("📋 I backed up your codebase to " ++ (root </> backupPath))
|
||||
putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase."
|
||||
|
||||
runIntegrityChecks ::
|
||||
(MVar Region.ConsoleRegion) ->
|
||||
Sqlite.Transaction ()
|
||||
runIntegrityChecks regionVar = do
|
||||
region <- Sqlite.unsafeIO . UnliftIO.mask_ $ do
|
||||
region <- Region.openConsoleRegion Region.Linear
|
||||
putMVar regionVar region
|
||||
pure region
|
||||
result <- do
|
||||
-- Ideally we'd check everything here, but certain codebases are known to have objects
|
||||
-- with missing Hash Objects, we'll want to clean that up in a future migration.
|
||||
-- integrityCheckAllHashObjects,
|
||||
let checks =
|
||||
[ integrityCheckAllBranches,
|
||||
integrityCheckAllCausals
|
||||
]
|
||||
|
||||
zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do
|
||||
Sqlite.unsafeIO $
|
||||
Region.setConsoleRegion
|
||||
region
|
||||
(Text.pack (printf "🕵️ Checking codebase integrity (step %d of %d)..." i (length checks)))
|
||||
check
|
||||
case result of
|
||||
NoIntegrityErrors -> pure ()
|
||||
IntegrityErrorDetected errs -> do
|
||||
let msg = prettyPrintIntegrityErrors errs
|
||||
let rendered = Pretty.toPlain 80 (Pretty.border 2 msg)
|
||||
Sqlite.unsafeIO $ Region.setConsoleRegion region (Text.pack rendered)
|
||||
(abortMigration "Codebase integrity error detected.")
|
||||
|
@ -0,0 +1,269 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSchema16To17) where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.UUID (UUID)
|
||||
import Data.UUID qualified as UUID
|
||||
import U.Codebase.Branch.Type qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId (..), ProjectId (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache qualified as BranchCache
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName))
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment.Internal (NameSegment (NameSegment))
|
||||
import Unison.NameSegment.Internal qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sqlite.Connection qualified as Connection
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import UnliftIO qualified
|
||||
import UnliftIO qualified as UnsafeIO
|
||||
|
||||
-- | This migration converts the codebase from having all projects in a single codebase root to having separate causal
|
||||
-- roots for each project branch.
|
||||
-- It:
|
||||
--
|
||||
-- * Adds the new project reflog table
|
||||
-- * Adds the project-branch head as a causal-hash-id column on the project-branch table, and populates it from all the projects in the project root.
|
||||
-- * Makes a new legacy project from the existing root branch (minus .__projects)
|
||||
-- * Adds a new scratch/main project
|
||||
-- * Adds a currentProjectPath table to replace the most-recent-path functionality.
|
||||
--
|
||||
-- It requires a Connection argument rather than working inside a Transaction because it needs to temporarily disable
|
||||
-- foreign key checking, and the foreign_key pragma cannot be set within a transaction.
|
||||
migrateSchema16To17 :: Sqlite.Connection -> IO ()
|
||||
migrateSchema16To17 conn = withDisabledForeignKeys $ do
|
||||
Q.expectSchemaVersion 16
|
||||
Q.addProjectBranchReflogTable
|
||||
Debug.debugLogM Debug.Migration "Adding causal hashes to project branches table."
|
||||
addCausalHashesToProjectBranches
|
||||
Debug.debugLogM Debug.Migration "Making legacy project from loose code."
|
||||
makeLegacyProjectFromLooseCode
|
||||
Debug.debugLogM Debug.Migration "Adding scratch project"
|
||||
scratchMain <-
|
||||
Q.loadProjectBranchByNames scratchProjectName scratchBranchName >>= \case
|
||||
Just pb -> pure pb
|
||||
Nothing -> do
|
||||
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
|
||||
(_proj, pb) <- Ops.insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
|
||||
pure pb
|
||||
|
||||
-- Try to set the recent project branch to what it was, default back to scratch if it doesn't exist or the user is in
|
||||
-- loose code.
|
||||
mayRecentProjectBranch <- runMaybeT $ do
|
||||
(projectId, branchId) <- MaybeT getMostRecentProjectBranchIds
|
||||
-- Make sure the project-branch still exists.
|
||||
_projBranch <- MaybeT $ Q.loadProjectBranch projectId branchId
|
||||
pure (projectId, branchId)
|
||||
|
||||
Debug.debugLogM Debug.Migration "Adding current project path table"
|
||||
Q.addCurrentProjectPathTable
|
||||
Debug.debugLogM Debug.Migration "Setting current project path to scratch project"
|
||||
|
||||
case mayRecentProjectBranch of
|
||||
Just (projectId, branchId) ->
|
||||
Q.setCurrentProjectPath projectId branchId []
|
||||
Nothing -> Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId []
|
||||
Debug.debugLogM Debug.Migration "Done migrating to version 17"
|
||||
Q.setSchemaVersion 17
|
||||
where
|
||||
scratchProjectName = UnsafeProjectName "scratch"
|
||||
scratchBranchName = UnsafeProjectBranchName "main"
|
||||
withDisabledForeignKeys :: Sqlite.Transaction r -> IO r
|
||||
withDisabledForeignKeys m = do
|
||||
let disable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=OFF |]
|
||||
let enable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=ON |]
|
||||
let action = Sqlite.runWriteTransaction conn \run -> run $ m
|
||||
UnsafeIO.bracket disable (const enable) (const action)
|
||||
|
||||
data ForeignKeyFailureException
|
||||
= ForeignKeyFailureException
|
||||
-- We leave the data as raw as possible to ensure we can display it properly rather than get decoding errors while
|
||||
-- trying to display some other error.
|
||||
[[Sqlite.SQLData]]
|
||||
| MissingRootBranch
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
addCausalHashesToProjectBranches :: Sqlite.Transaction ()
|
||||
addCausalHashesToProjectBranches = do
|
||||
Debug.debugLogM Debug.Migration "Creating new_project_branch"
|
||||
-- Create the new version of the project_branch table with the causal_hash_id column.
|
||||
Sqlite.execute
|
||||
[Sqlite.sql|
|
||||
CREATE TABLE new_project_branch (
|
||||
project_id uuid NOT NULL REFERENCES project (id),
|
||||
branch_id uuid NOT NULL,
|
||||
name text NOT NULL,
|
||||
causal_hash_id integer NOT NULL REFERENCES causal(self_hash_id),
|
||||
|
||||
primary key (project_id, branch_id),
|
||||
|
||||
unique (project_id, name)
|
||||
)
|
||||
without rowid;
|
||||
|]
|
||||
rootCausalHashId <- expectNamespaceRoot
|
||||
rootCh <- Q.expectCausalHash rootCausalHashId
|
||||
projectsRoot <- Codebase.getShallowCausalAtPathFromRootHash rootCh (Path.singleton $ projectsNameSegment) >>= V2Causal.value
|
||||
ifor_ (V2Branch.children projectsRoot) \projectIdNS projectsCausal -> do
|
||||
projectId <- case projectIdNS of
|
||||
UUIDNameSegment projectIdUUID -> pure $ ProjectId projectIdUUID
|
||||
_ -> error $ "Invalid Project Id NameSegment:" <> show projectIdNS
|
||||
Debug.debugM Debug.Migration "Migrating project" projectId
|
||||
projectsBranch <- V2Causal.value projectsCausal
|
||||
case (Map.lookup branchesNameSegment $ V2Branch.children projectsBranch) of
|
||||
Nothing -> pure ()
|
||||
Just branchesCausal -> do
|
||||
branchesBranch <- V2Causal.value branchesCausal
|
||||
ifor_ (V2Branch.children branchesBranch) \branchIdNS projectBranchCausal -> void . runMaybeT $ do
|
||||
projectBranchId <- case branchIdNS of
|
||||
UUIDNameSegment branchIdUUID -> pure $ ProjectBranchId branchIdUUID
|
||||
_ -> error $ "Invalid Branch Id NameSegment:" <> show branchIdNS
|
||||
Debug.debugM Debug.Migration "Migrating project branch" projectBranchId
|
||||
let branchCausalHash = V2Causal.causalHash projectBranchCausal
|
||||
causalHashId <- lift $ Q.expectCausalHashIdByCausalHash branchCausalHash
|
||||
branchName <-
|
||||
MaybeT $
|
||||
Sqlite.queryMaybeCol @ProjectBranchName
|
||||
[Sqlite.sql|
|
||||
SELECT project_branch.name
|
||||
FROM project_branch
|
||||
WHERE
|
||||
project_branch.project_id = :projectId
|
||||
AND project_branch.branch_id = :projectBranchId
|
||||
|]
|
||||
-- Insert the full project branch with HEAD into the new table
|
||||
lift $
|
||||
Sqlite.execute
|
||||
[Sqlite.sql|
|
||||
INSERT INTO new_project_branch (project_id, branch_id, name, causal_hash_id)
|
||||
VALUES (:projectId, :projectBranchId, :branchName, :causalHashId)
|
||||
|]
|
||||
|
||||
Debug.debugLogM Debug.Migration "Deleting orphaned project branch data"
|
||||
-- Delete any project branch data that don't have a matching branch in the current root.
|
||||
-- This is to make sure any old or invalid project branches get cleared out and won't cause problems when we rewrite
|
||||
-- foreign key references.
|
||||
-- We have to do this manually since we had to disable foreign key checks to add the new column.
|
||||
Sqlite.execute
|
||||
[Sqlite.sql| DELETE FROM project_branch_parent AS pbp
|
||||
WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbp.project_id AND npb.branch_id = pbp.branch_id)
|
||||
|]
|
||||
Debug.debugLogM Debug.Migration "Deleting orphaned remote mapping data"
|
||||
Sqlite.execute
|
||||
[Sqlite.sql| DELETE FROM project_branch_remote_mapping AS pbrp
|
||||
WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = pbrp.local_project_id AND npb.branch_id = pbrp.local_branch_id)
|
||||
|]
|
||||
-- Delete any project branch rows that don't have a matching branch in the current root.
|
||||
Sqlite.execute
|
||||
[Sqlite.sql|
|
||||
DELETE FROM most_recent_branch AS mrb
|
||||
WHERE NOT EXISTS(SELECT 1 FROM new_project_branch npb WHERE npb.project_id = mrb.project_id AND npb.branch_id = mrb.branch_id)
|
||||
|]
|
||||
|
||||
Debug.debugLogM Debug.Migration "Swapping old and new project branch tables"
|
||||
-- Drop the old project_branch table and rename the new one to take its place.
|
||||
Sqlite.execute [Sqlite.sql| DROP TABLE project_branch |]
|
||||
Sqlite.execute [Sqlite.sql| ALTER TABLE new_project_branch RENAME TO project_branch |]
|
||||
Debug.debugLogM Debug.Migration "Checking foreign keys"
|
||||
foreignKeyErrs <- Sqlite.queryListRow [Sqlite.sql| PRAGMA foreign_key_check |]
|
||||
when (not . null $ foreignKeyErrs) . Sqlite.unsafeIO . UnliftIO.throwIO $ ForeignKeyFailureException foreignKeyErrs
|
||||
|
||||
makeLegacyProjectFromLooseCode :: Sqlite.Transaction ()
|
||||
makeLegacyProjectFromLooseCode = do
|
||||
rootChId <-
|
||||
Sqlite.queryOneCol @CausalHashId
|
||||
[Sqlite.sql|
|
||||
SELECT causal_id
|
||||
FROM namespace_root
|
||||
|]
|
||||
rootCh <- Q.expectCausalHash rootChId
|
||||
branchCache <- Sqlite.unsafeIO BranchCache.newBranchCache
|
||||
getDeclType <- Sqlite.unsafeIO $ CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
|
||||
rootBranch <-
|
||||
CodebaseOps.getBranchForHash branchCache getDeclType rootCh `whenNothingM` do
|
||||
Sqlite.unsafeIO . UnliftIO.throwIO $ MissingRootBranch
|
||||
-- Remove the hidden projects root if one existed.
|
||||
let rootWithoutProjects = rootBranch & over (Branch.head_ . Branch.children) (Map.delete projectsNameSegment)
|
||||
CodebaseOps.putBranch rootWithoutProjects
|
||||
let legacyBranchRootHash = Branch.headHash rootWithoutProjects
|
||||
legacyBranchRootHashId <- Q.expectCausalHashIdByCausalHash legacyBranchRootHash
|
||||
|
||||
let findLegacyName :: Maybe Int -> Sqlite.Transaction ProjectName
|
||||
findLegacyName mayN = do
|
||||
let tryProjName = case mayN of
|
||||
Nothing -> UnsafeProjectName "legacy"
|
||||
Just n -> UnsafeProjectName $ "legacy" <> Text.pack (show n)
|
||||
Q.loadProjectBranchByNames tryProjName legacyBranchName >>= \case
|
||||
Nothing -> pure tryProjName
|
||||
Just _ -> findLegacyName . Just $ maybe 1 succ mayN
|
||||
legacyProjName <- findLegacyName Nothing
|
||||
void $ Ops.insertProjectAndBranch legacyProjName legacyBranchName legacyBranchRootHashId
|
||||
pure ()
|
||||
where
|
||||
legacyBranchName = UnsafeProjectBranchName "main"
|
||||
|
||||
expectNamespaceRoot :: Sqlite.Transaction CausalHashId
|
||||
expectNamespaceRoot =
|
||||
Sqlite.queryOneCol loadNamespaceRootSql
|
||||
|
||||
loadNamespaceRootSql :: Sqlite.Sql
|
||||
loadNamespaceRootSql =
|
||||
[Sqlite.sql|
|
||||
SELECT causal_id
|
||||
FROM namespace_root
|
||||
|]
|
||||
|
||||
pattern UUIDNameSegment :: UUID -> NameSegment
|
||||
pattern UUIDNameSegment uuid <-
|
||||
( NameSegment.toUnescapedText ->
|
||||
(Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid))
|
||||
)
|
||||
where
|
||||
UUIDNameSegment uuid =
|
||||
NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid)))
|
||||
|
||||
projectsNameSegment :: NameSegment
|
||||
projectsNameSegment = NameSegment.unsafeParseText "__projects"
|
||||
|
||||
branchesNameSegment :: NameSegment
|
||||
branchesNameSegment = NameSegment.unsafeParseText "branches"
|
||||
|
||||
expectMostRecentNamespace :: Sqlite.Transaction [NameSegment]
|
||||
expectMostRecentNamespace =
|
||||
Sqlite.queryOneColCheck
|
||||
[Sqlite.sql|
|
||||
SELECT namespace
|
||||
FROM most_recent_namespace
|
||||
|]
|
||||
check
|
||||
where
|
||||
check :: Text -> Either Q.JsonParseFailure [NameSegment]
|
||||
check bytes =
|
||||
case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
|
||||
Left failure -> Left (Q.JsonParseFailure {bytes, failure = Text.pack failure})
|
||||
Right namespace -> Right (map NameSegment namespace)
|
||||
|
||||
getMostRecentProjectBranchIds :: Sqlite.Transaction (Maybe (ProjectId, ProjectBranchId))
|
||||
getMostRecentProjectBranchIds = do
|
||||
nameSegments <- expectMostRecentNamespace
|
||||
case nameSegments of
|
||||
(proj : UUIDNameSegment projectId : branches : UUIDNameSegment branchId : _)
|
||||
| proj == projectsNameSegment && branches == branchesNameSegment ->
|
||||
pure . Just $ (ProjectId projectId, ProjectBranchId branchId)
|
||||
_ -> pure Nothing
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
|
||||
@ -103,7 +104,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
|
||||
log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones."
|
||||
|
||||
log "Updating Namespace Root..."
|
||||
rootCausalHashId <- Q.expectNamespaceRoot
|
||||
rootCausalHashId <- expectNamespaceRoot
|
||||
numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches]
|
||||
v2EmptyBranchHashInfo <- saveV2EmptyBranch
|
||||
watches <-
|
||||
@ -115,7 +116,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
|
||||
`execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo
|
||||
let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId
|
||||
log "Updating Namespace Root..."
|
||||
Q.setNamespaceRoot newRootCausalHashId
|
||||
setNamespaceRoot newRootCausalHashId
|
||||
log "Rewriting old object IDs..."
|
||||
ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do
|
||||
Q.recordObjectRehash oldObjId newObjId
|
||||
@ -149,6 +150,23 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do
|
||||
allDone = lift $ log $ "\nFinished migrating, initiating cleanup."
|
||||
in Sync.Progress {need, done, error = errorHandler, allDone}
|
||||
|
||||
expectNamespaceRoot :: Sqlite.Transaction CausalHashId
|
||||
expectNamespaceRoot =
|
||||
Sqlite.queryOneCol loadNamespaceRootSql
|
||||
|
||||
loadNamespaceRootSql :: Sqlite.Sql
|
||||
loadNamespaceRootSql =
|
||||
[Sqlite.sql|
|
||||
SELECT causal_id
|
||||
FROM namespace_root
|
||||
|]
|
||||
|
||||
setNamespaceRoot :: CausalHashId -> Sqlite.Transaction ()
|
||||
setNamespaceRoot id =
|
||||
Sqlite.queryOneCol [Sqlite.sql| SELECT EXISTS (SELECT 1 FROM namespace_root) |] >>= \case
|
||||
False -> Sqlite.execute [Sqlite.sql| INSERT INTO namespace_root VALUES (:id) |]
|
||||
True -> Sqlite.execute [Sqlite.sql| UPDATE namespace_root SET causal_id = :id |]
|
||||
|
||||
log :: String -> Sqlite.Transaction ()
|
||||
log =
|
||||
Sqlite.unsafeIO . putStrLn
|
||||
|
@ -81,7 +81,7 @@ numMigrated =
|
||||
migrateSchema3To4 :: Sqlite.Transaction ()
|
||||
migrateSchema3To4 = do
|
||||
Q.expectSchemaVersion 3
|
||||
rootCausalHashId <- Q.expectNamespaceRoot
|
||||
rootCausalHashId <- expectNamespaceRoot
|
||||
totalCausals <- causalCount
|
||||
migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId]
|
||||
let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState
|
||||
@ -98,6 +98,17 @@ migrateSchema3To4 = do
|
||||
SELECT count(*) FROM causal;
|
||||
|]
|
||||
|
||||
expectNamespaceRoot :: Sqlite.Transaction DB.CausalHashId
|
||||
expectNamespaceRoot =
|
||||
Sqlite.queryOneCol loadNamespaceRootSql
|
||||
|
||||
loadNamespaceRootSql :: Sqlite.Sql
|
||||
loadNamespaceRootSql =
|
||||
[Sqlite.sql|
|
||||
SELECT causal_id
|
||||
FROM namespace_root
|
||||
|]
|
||||
|
||||
migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId
|
||||
migrationProgress totalCausals =
|
||||
Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone}
|
||||
|
@ -1,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
|
||||
|
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
|
||||
-- monad.
|
||||
@ -16,6 +18,7 @@ import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
|
||||
import U.Codebase.Branch.Diff qualified as BranchDiff
|
||||
@ -30,11 +33,14 @@ import U.Codebase.Sqlite.NamedRef qualified as S
|
||||
import U.Codebase.Sqlite.ObjectType qualified as OT
|
||||
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Project qualified as Project
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import Unison.Builtin qualified as Builtins
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
@ -43,7 +49,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.Core.Project (ProjectBranchName, ProjectName)
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as Decl
|
||||
import Unison.Hash (Hash)
|
||||
@ -74,6 +80,35 @@ import Unison.Util.Set qualified as Set
|
||||
import Unison.WatchKind qualified as UF
|
||||
import UnliftIO.STM
|
||||
|
||||
createSchema :: Transaction ()
|
||||
createSchema = do
|
||||
Q.runCreateSql
|
||||
Q.addTempEntityTables
|
||||
Q.addNamespaceStatsTables
|
||||
Q.addReflogTable
|
||||
Q.fixScopedNameLookupTables
|
||||
Q.addProjectTables
|
||||
Q.addMostRecentBranchTable
|
||||
Q.addNameLookupMountTables
|
||||
Q.addMostRecentNamespaceTable
|
||||
Sqlite.execute insertSchemaVersionSql
|
||||
Q.addSquashResultTable
|
||||
Q.addCurrentProjectPathTable
|
||||
Q.addProjectBranchReflogTable
|
||||
Q.addProjectBranchCausalHashIdColumn
|
||||
(_, emptyCausalHashId) <- emptyCausalHash
|
||||
(_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
|
||||
Q.setCurrentProjectPath projectId branchId []
|
||||
where
|
||||
scratchProjectName = UnsafeProjectName "scratch"
|
||||
scratchBranchName = UnsafeProjectBranchName "main"
|
||||
currentSchemaVersion = Q.currentSchemaVersion
|
||||
insertSchemaVersionSql =
|
||||
[Sqlite.sql|
|
||||
INSERT INTO schema_version (version)
|
||||
VALUES (:currentSchemaVersion)
|
||||
|]
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Buffer entry
|
||||
|
||||
@ -382,25 +417,6 @@ tryFlushDeclBuffer termBuffer declBuffer =
|
||||
h
|
||||
in loop
|
||||
|
||||
uncachedLoadRootBranch ::
|
||||
BranchCache Sqlite.Transaction ->
|
||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||
Transaction (Branch Transaction)
|
||||
uncachedLoadRootBranch branchCache getDeclType = do
|
||||
causal2 <- Ops.expectRootCausal
|
||||
Cv.causalbranch2to1 branchCache getDeclType causal2
|
||||
|
||||
-- | Get whether the root branch exists.
|
||||
getRootBranchExists :: Transaction Bool
|
||||
getRootBranchExists =
|
||||
isJust <$> Ops.loadRootCausalHash
|
||||
|
||||
putRootBranch :: Branch Transaction -> Transaction ()
|
||||
putRootBranch branch1 = do
|
||||
-- todo: check to see if root namespace hash has been externally modified
|
||||
-- and do something (merge?) it if necessary. But for now, we just overwrite it.
|
||||
void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1))
|
||||
|
||||
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||
-- to one that returns Maybe.
|
||||
getBranchForHash ::
|
||||
@ -735,14 +751,34 @@ makeMaybeCachedTransaction size action = do
|
||||
conn <- Sqlite.unsafeGetConnection
|
||||
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||
|
||||
insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
||||
Q.insertProject projectId projectName
|
||||
-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project and branch ids. Fails if a branch by that name already exists in the project.
|
||||
insertProjectAndBranch :: ProjectName -> ProjectBranchName -> Db.CausalHashId -> Sqlite.Transaction (Project, ProjectBranch)
|
||||
insertProjectAndBranch projectName branchName chId = do
|
||||
projectId <- whenNothingM (fmap Project.projectId <$> Q.loadProjectByName projectName) do
|
||||
projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom)
|
||||
Q.insertProject projectId projectName
|
||||
pure projectId
|
||||
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
||||
let projectBranch =
|
||||
ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
Q.insertProjectBranch
|
||||
ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
"Project Created"
|
||||
chId
|
||||
projectBranch
|
||||
Q.setMostRecentBranch projectId branchId
|
||||
pure (Project {name = projectName, projectId}, ProjectBranch {projectId, name = branchName, branchId, parentBranchId = Nothing})
|
||||
|
||||
-- | Often we need to assign something to an empty causal, this ensures the empty causal
|
||||
-- exists in the codebase and returns its hash.
|
||||
emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId)
|
||||
emptyCausalHash = do
|
||||
let emptyBranch = Branch.empty
|
||||
putBranch emptyBranch
|
||||
let causalHash = Branch.headHash emptyBranch
|
||||
causalHashId <- Q.expectCausalHashIdByCausalHash causalHash
|
||||
pure (causalHash, causalHashId)
|
||||
|
@ -55,13 +55,6 @@ data Codebase m v a = Codebase
|
||||
putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
|
||||
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
|
||||
getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]),
|
||||
-- | Get the root branch.
|
||||
getRootBranch :: m (Branch m),
|
||||
-- | Like 'putBranch', but also adjusts the root branch pointer afterwards.
|
||||
putRootBranch ::
|
||||
Text -> -- Reason for the change, will be recorded in the reflog
|
||||
Branch m ->
|
||||
m (),
|
||||
getBranchForHash :: CausalHash -> m (Maybe (Branch m)),
|
||||
-- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't
|
||||
-- already exist.
|
||||
@ -87,7 +80,12 @@ data Codebase m v a = Codebase
|
||||
-- | Acquire a new connection to the same underlying database file this codebase object connects to.
|
||||
withConnection :: forall x. (Sqlite.Connection -> m x) -> m x,
|
||||
-- | Acquire a new connection to the same underlying database file this codebase object connects to.
|
||||
withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x
|
||||
withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x,
|
||||
-- | This optimization allows us to pre-fetch a branch from SQLite into the branch cache when we know we'll need it
|
||||
-- soon, but not immediately. E.g. the user has switched a branch, but hasn't run any commands on it yet.
|
||||
--
|
||||
-- This combinator returns immediately, but warms the cache in the background with the desired branch.
|
||||
preloadBranch :: CausalHash -> m ()
|
||||
}
|
||||
|
||||
-- | Whether a codebase is local or remote.
|
||||
|
@ -10,6 +10,7 @@ import U.Codebase.Branch qualified as Codebase.Branch
|
||||
import U.Codebase.Decl qualified as Codebase.Decl
|
||||
import U.Codebase.Reference qualified as Codebase.Reference
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -21,8 +22,8 @@ import Witherable (witherM)
|
||||
-- For (potential) efficiency, this function accepts an argument that loads a namespace at a path, which may be backed
|
||||
-- by a cache.
|
||||
loadUniqueTypeGuid ::
|
||||
([NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
||||
[NameSegment] ->
|
||||
(ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))) ->
|
||||
ProjectPath ->
|
||||
NameSegment ->
|
||||
Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid loadNamespaceAtPath path name =
|
||||
|
@ -1,158 +0,0 @@
|
||||
module Unison.Project.Util
|
||||
( projectPath,
|
||||
projectBranchesPath,
|
||||
projectBranchPath,
|
||||
projectBranchSegment,
|
||||
projectPathPrism,
|
||||
projectBranchPathPrism,
|
||||
projectContextFromPath,
|
||||
pattern UUIDNameSegment,
|
||||
ProjectContext (..),
|
||||
pattern ProjectsNameSegment,
|
||||
pattern BranchesNameSegment,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Text qualified as Text
|
||||
import Data.UUID (UUID)
|
||||
import Data.UUID qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.NameSegment.Internal (NameSegment (NameSegment))
|
||||
import Unison.NameSegment.Internal qualified as NameSegment
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
-- | Get the path that a project is stored at. Users aren't supposed to go here.
|
||||
--
|
||||
-- >>> projectPath "ABCD"
|
||||
-- .__projects._ABCD
|
||||
projectPath :: ProjectId -> Path.Absolute
|
||||
projectPath projectId =
|
||||
review projectPathPrism projectId
|
||||
|
||||
-- | Get the path that a project's branches are stored at. Users aren't supposed to go here.
|
||||
--
|
||||
-- >>> projectBranchesPath "ABCD"
|
||||
-- .__projects._ABCD.branches
|
||||
projectBranchesPath :: ProjectId -> Path.Absolute
|
||||
projectBranchesPath projectId =
|
||||
snoc (projectPath projectId) BranchesNameSegment
|
||||
|
||||
-- | Get the path that a branch is stored at. Users aren't supposed to go here.
|
||||
--
|
||||
-- >>> projectBranchPath ProjectAndBranch { project = "ABCD", branch = "DEFG" }
|
||||
-- .__projects._ABCD.branches._DEFG
|
||||
projectBranchPath :: ProjectAndBranch ProjectId ProjectBranchId -> Path.Absolute
|
||||
projectBranchPath projectAndBranch =
|
||||
review projectBranchPathPrism (projectAndBranch, Path.empty)
|
||||
|
||||
-- | Get the name segment that a branch is stored at.
|
||||
--
|
||||
-- >>> projectBranchSegment "DEFG"
|
||||
-- "_DEFG"
|
||||
projectBranchSegment :: ProjectBranchId -> NameSegment
|
||||
projectBranchSegment (ProjectBranchId branchId) =
|
||||
UUIDNameSegment branchId
|
||||
|
||||
pattern UUIDNameSegment :: UUID -> NameSegment
|
||||
pattern UUIDNameSegment uuid <-
|
||||
( NameSegment.toUnescapedText ->
|
||||
(Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid))
|
||||
)
|
||||
where
|
||||
UUIDNameSegment uuid =
|
||||
NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid)))
|
||||
|
||||
-- | The prism between paths like
|
||||
--
|
||||
-- @
|
||||
-- .__projects._XX_XX
|
||||
-- @
|
||||
--
|
||||
-- and the project id
|
||||
--
|
||||
-- @
|
||||
-- XX-XX
|
||||
-- @
|
||||
projectPathPrism :: Prism' Path.Absolute ProjectId
|
||||
projectPathPrism =
|
||||
prism' toPath toId
|
||||
where
|
||||
toPath :: ProjectId -> Path.Absolute
|
||||
toPath projectId =
|
||||
Path.Absolute (Path.fromList [ProjectsNameSegment, UUIDNameSegment (unProjectId projectId)])
|
||||
|
||||
toId :: Path.Absolute -> Maybe ProjectId
|
||||
toId path =
|
||||
case Path.toList (Path.unabsolute path) of
|
||||
[ProjectsNameSegment, UUIDNameSegment projectId] -> Just (ProjectId projectId)
|
||||
_ -> Nothing
|
||||
|
||||
-- | The prism between paths like
|
||||
--
|
||||
-- @
|
||||
-- .__projects._XX_XX.branches._YY_YY.foo.bar
|
||||
-- @
|
||||
--
|
||||
-- and the @(project id, branch id, path)@ triple
|
||||
--
|
||||
-- @
|
||||
-- (XX-XX, YY-YY, foo.bar)
|
||||
-- @
|
||||
projectBranchPathPrism :: Prism' Path.Absolute (ProjectAndBranch ProjectId ProjectBranchId, Path.Path)
|
||||
projectBranchPathPrism =
|
||||
prism' toPath toIds
|
||||
where
|
||||
toPath :: (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) -> Path.Absolute
|
||||
toPath (ProjectAndBranch {project = projectId, branch = branchId}, restPath) =
|
||||
Path.Absolute $
|
||||
Path.fromList
|
||||
( [ ProjectsNameSegment,
|
||||
UUIDNameSegment (unProjectId projectId),
|
||||
BranchesNameSegment,
|
||||
UUIDNameSegment (unProjectBranchId branchId)
|
||||
]
|
||||
++ Path.toList restPath
|
||||
)
|
||||
|
||||
toIds :: Path.Absolute -> Maybe (ProjectAndBranch ProjectId ProjectBranchId, Path.Path)
|
||||
toIds path =
|
||||
case Path.toList (Path.unabsolute path) of
|
||||
ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : restPath ->
|
||||
Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath)
|
||||
_ -> Nothing
|
||||
|
||||
-- | The project information about the current path.
|
||||
-- NOTE: if the user has cd'd into the project storage area but NOT into a branch, (where they shouldn't ever
|
||||
-- be), this will result in a LooseCodePath.
|
||||
data ProjectContext
|
||||
= LooseCodePath Path.Absolute
|
||||
| ProjectBranchPath ProjectId ProjectBranchId Path.Path {- path from branch root -}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
projectContextFromPath :: Path.Absolute -> ProjectContext
|
||||
projectContextFromPath path =
|
||||
case path ^? projectBranchPathPrism of
|
||||
Just (ProjectAndBranch {project = projectId, branch = branchId}, restPath) ->
|
||||
ProjectBranchPath projectId branchId restPath
|
||||
Nothing ->
|
||||
LooseCodePath path
|
||||
|
||||
pattern ProjectsNameSegment :: NameSegment
|
||||
pattern ProjectsNameSegment <-
|
||||
((== projectsNameSegment) -> True)
|
||||
where
|
||||
ProjectsNameSegment = projectsNameSegment
|
||||
|
||||
pattern BranchesNameSegment :: NameSegment
|
||||
pattern BranchesNameSegment <-
|
||||
((== branchesNameSegment) -> True)
|
||||
where
|
||||
BranchesNameSegment = branchesNameSegment
|
||||
|
||||
projectsNameSegment :: NameSegment
|
||||
projectsNameSegment = NameSegment "__projects"
|
||||
|
||||
branchesNameSegment :: NameSegment
|
||||
branchesNameSegment = NameSegment "branches"
|
@ -169,7 +169,7 @@ expandSimple keep (v, bnd) = (v, apps' (var a v) evs)
|
||||
evs = map (var a) . Set.toList $ Set.difference fvs keep
|
||||
|
||||
abstract :: (Var v) => Set v -> Term v a -> Term v a
|
||||
abstract keep bnd = lam' a evs bnd
|
||||
abstract keep bnd = lamWithoutBindingAnns a evs bnd
|
||||
where
|
||||
a = ABT.annotation bnd
|
||||
fvs = ABT.freeVars bnd
|
||||
@ -205,7 +205,7 @@ enclose keep rec (Let1NamedTop' top v b@(unAnn -> LamsNamed' vs bd) e) =
|
||||
annotate tm
|
||||
| Ann' _ ty <- b = ann a tm ty
|
||||
| otherwise = tm
|
||||
lamb = lam' a evs (annotate $ lam' a vs lbody)
|
||||
lamb = lamWithoutBindingAnns a evs (annotate $ lamWithoutBindingAnns a vs lbody)
|
||||
enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
|
||||
Just $ if null evs then lamb else apps' lamb $ map (var a) evs
|
||||
where
|
||||
@ -218,7 +218,7 @@ enclose keep rec t@(unLamsAnnot -> Just (vs0, mty, vs1, body)) =
|
||||
annotate tm
|
||||
| Just ty <- mty = ann a tm ty
|
||||
| otherwise = tm
|
||||
lamb = lam' a (evs ++ vs0) . annotate . lam' a vs1 $ lbody
|
||||
lamb = lamWithoutBindingAnns a (evs ++ vs0) . annotate . lamWithoutBindingAnns a vs1 $ lbody
|
||||
enclose keep rec t@(Handle' h body)
|
||||
| isStructured body =
|
||||
Just . handle (ABT.annotation t) (rec keep h) $ apps' lamb args
|
||||
@ -232,8 +232,8 @@ enclose keep rec t@(Handle' h body)
|
||||
| null evs = [constructor a (ConstructorReference Ty.unitRef 0)]
|
||||
| otherwise = var a <$> evs
|
||||
lamb
|
||||
| null evs = lam' a [fv] lbody
|
||||
| otherwise = lam' a evs lbody
|
||||
| null evs = lamWithoutBindingAnns a [fv] lbody
|
||||
| otherwise = lamWithoutBindingAnns a evs lbody
|
||||
enclose keep rec t@(Match' s0 cs0) = Just $ match a s cs
|
||||
where
|
||||
a = ABT.annotation t
|
||||
@ -331,7 +331,7 @@ beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
|
||||
vbs <&> \(v, b0) -> (v,ABT.annotation b0,) $ case b0 of
|
||||
LamsNamed' vs b
|
||||
| Just n <- Map.lookup v m ->
|
||||
lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
|
||||
lamWithoutBindingAnns (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
|
||||
-- shouldn't happen
|
||||
b -> dropPrefixes m b
|
||||
|
||||
@ -340,7 +340,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
|
||||
| n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
lamb = lam' al (drop n vs) (bd)
|
||||
lamb = lamWithoutBindingAnns al (drop n vs) (bd)
|
||||
al = ABT.annotation l
|
||||
-- Calculate a maximum number of arguments to drop.
|
||||
-- Enclosing doesn't create let-bound lambdas, so we
|
||||
@ -353,7 +353,7 @@ beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
|
||||
beta rec (Apps' l@(LamsNamed' vs body) as)
|
||||
| n <- matchVars 0 vs as,
|
||||
n > 0 =
|
||||
Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as)
|
||||
Just $ apps' (lamWithoutBindingAnns al (drop n vs) (rec body)) (drop n as)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
al = ABT.annotation l
|
||||
@ -422,7 +422,7 @@ groupFloater rec vbs = do
|
||||
where
|
||||
rec' b
|
||||
| Just (vs0, mty, vs1, bd) <- unLamsAnnot b =
|
||||
lam' a vs0 . maybe id (flip $ ann a) mty . lam' a vs1 <$> rec bd
|
||||
lamWithoutBindingAnns a vs0 . maybe id (flip $ ann a) mty . lamWithoutBindingAnns a vs1 <$> rec bd
|
||||
where
|
||||
a = ABT.annotation b
|
||||
rec' b = rec b
|
||||
@ -453,12 +453,12 @@ lamFloater closed tm mv a vs bd =
|
||||
let v = ABT.freshIn cvs $ fromMaybe (typed Var.Float) mv
|
||||
in ( v,
|
||||
( Set.insert v cvs,
|
||||
ctx <> [(v, lam' a vs bd)],
|
||||
ctx <> [(v, lamWithoutBindingAnns a vs bd)],
|
||||
floatDecomp closed v tm dcmp
|
||||
)
|
||||
)
|
||||
where
|
||||
tgt = unannotate (lam' a vs bd)
|
||||
tgt = unannotate (lamWithoutBindingAnns a vs bd)
|
||||
p (_, flam) = unannotate flam == tgt
|
||||
|
||||
floatDecomp ::
|
||||
@ -479,7 +479,7 @@ floater top rec tm0@(Ann' tm ty) =
|
||||
floater top rec (LetRecNamed' vbs e) =
|
||||
Just $
|
||||
letFloater rec vbs e >>= \case
|
||||
lm@(LamsNamed' vs bd) | top -> lam' a vs <$> rec bd
|
||||
lm@(LamsNamed' vs bd) | top -> lamWithoutBindingAnns a vs <$> rec bd
|
||||
where
|
||||
a = ABT.annotation lm
|
||||
tm -> rec tm
|
||||
@ -492,7 +492,7 @@ floater _ rec (Let1Named' v b e)
|
||||
where
|
||||
a = ABT.annotation b
|
||||
floater top rec tm@(LamsNamed' vs bd)
|
||||
| top = Just $ lam' a vs <$> rec bd
|
||||
| top = Just $ lamWithoutBindingAnns a vs <$> rec bd
|
||||
| otherwise = Just $ do
|
||||
bd <- rec bd
|
||||
lv <- lamFloater True tm Nothing a vs bd
|
||||
@ -627,7 +627,7 @@ saturate dat = ABT.visitPure $ \case
|
||||
| m < n,
|
||||
vs <- snd $ mapAccumL frsh fvs [1 .. n - m],
|
||||
nargs <- var mempty <$> vs ->
|
||||
Just . lam' mempty vs . apps' f $ args' ++ nargs
|
||||
Just . lamWithoutBindingAnns mempty vs . apps' f $ args' ++ nargs
|
||||
| m > n,
|
||||
(sargs, eargs) <- splitAt n args',
|
||||
sv <- Var.freshIn fvs $ typed Var.Eta ->
|
||||
|
@ -230,7 +230,11 @@ decompileForeign backref topTerms f
|
||||
| Just s <- unwrapSeq f =
|
||||
list' () <$> traverse (decompile backref topTerms) s
|
||||
decompileForeign _ _ (Wrap r _) =
|
||||
err (BadForeign r) $ bug "<Foreign>"
|
||||
err (BadForeign r) $ bug text
|
||||
where
|
||||
text
|
||||
| Builtin name <- r = "<" <> name <> ">"
|
||||
| otherwise = "<Foreign>"
|
||||
|
||||
decompileBytes :: (Var v) => By.Bytes -> Term v ()
|
||||
decompileBytes =
|
||||
|
@ -384,7 +384,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 DBTX i)
|
||||
ustk <- bump ustk
|
||||
bstk <- case tracer env False clo of
|
||||
NoTrace -> bstk <$ poke ustk 0
|
||||
MsgTrace _ tx _ -> do
|
||||
MsgTrace _ _ tx -> do
|
||||
poke ustk 1
|
||||
bstk <- bump bstk
|
||||
bstk <$ pokeBi bstk (Util.Text.pack tx)
|
||||
|
@ -38,8 +38,8 @@ import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Pattern (Pattern)
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
@ -348,7 +348,9 @@ parsePattern = label "pattern" root
|
||||
lam :: (Var v) => TermP v m -> TermP v m
|
||||
lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved "->") <*> p
|
||||
where
|
||||
mkLam vs b = Term.lam' (ann (head vs) <> ann b) (map L.payload vs) b
|
||||
mkLam vs b =
|
||||
let annotatedArgs = vs <&> \v -> (ann v, L.payload v)
|
||||
in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
|
||||
|
||||
letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
|
||||
letBlock = label "let" $ (snd <$> block "let")
|
||||
@ -383,7 +385,8 @@ lamCase = do
|
||||
es -> DD.tupleTerm es
|
||||
anns = ann start <> ann (NonEmpty.last cases)
|
||||
matchTerm = Term.match anns lamvarTerm (toList cases)
|
||||
pure $ Term.lam' anns vars matchTerm
|
||||
let annotatedVars = (Ann.GeneratedFrom $ ann start,) <$> vars
|
||||
pure $ Term.lam' anns annotatedVars matchTerm
|
||||
|
||||
ifthen = label "if" do
|
||||
start <- peekAny
|
||||
@ -412,7 +415,7 @@ hashQualifiedPrefixTerm = resolveHashQualified =<< hqPrefixId
|
||||
hashQualifiedInfixTerm :: (Monad m, Var v) => TermP v m
|
||||
hashQualifiedInfixTerm = resolveHashQualified =<< hqInfixId
|
||||
|
||||
quasikeyword :: Ord v => Text -> P v m (L.Token ())
|
||||
quasikeyword :: (Ord v) => Text -> P v m (L.Token ())
|
||||
quasikeyword kw = queryToken \case
|
||||
L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just ()
|
||||
_ -> Nothing
|
||||
@ -595,11 +598,12 @@ doc2Block = do
|
||||
"syntax.docExample" -> do
|
||||
trm <- term
|
||||
endTok <- closeBlock
|
||||
pure . (ann startTok <> ann endTok,) $ case trm of
|
||||
let spanAnn = ann startTok <> ann endTok
|
||||
pure . (spanAnn,) $ case trm of
|
||||
tm@(Term.Apps' _ xs) ->
|
||||
let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs
|
||||
n = Term.nat (ann tm) (fromIntegral (length fvs))
|
||||
lam = addDelay $ Term.lam' (ann tm) fvs tm
|
||||
lam = addDelay $ Term.lam' (ann tm) ((Ann.GeneratedFrom spanAnn,) <$> fvs) tm
|
||||
in Term.apps' f [n, lam]
|
||||
tm -> Term.apps' f [Term.nat (ann tm) 0, addDelay tm]
|
||||
"syntax.docTransclude" -> evalLike id
|
||||
@ -980,12 +984,13 @@ delayQuote :: (Monad m, Var v) => TermP v m
|
||||
delayQuote = P.label "quote" do
|
||||
start <- reserved "'"
|
||||
e <- termLeaf
|
||||
pure $ DD.delayTerm (ann start <> ann e) e
|
||||
pure $ DD.delayTerm (ann start <> ann e) (ann start) e
|
||||
|
||||
delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
|
||||
delayBlock = P.label "do" do
|
||||
(spanAnn, b) <- block "do"
|
||||
pure $ (spanAnn, DD.delayTerm (ann b) b)
|
||||
let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
|
||||
pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
|
||||
|
||||
bang :: (Monad m, Var v) => TermP v m
|
||||
bang = P.label "bang" do
|
||||
@ -993,10 +998,10 @@ bang = P.label "bang" do
|
||||
e <- termLeaf
|
||||
pure $ DD.forceTerm (ann start <> ann e) (ann start) e
|
||||
|
||||
force :: forall m v . (Monad m, Var v) => TermP v m
|
||||
force :: forall m v. (Monad m, Var v) => TermP v m
|
||||
force = P.label "force" $ P.try do
|
||||
-- `forkAt pool() blah` parses as `forkAt (pool ()) blah`
|
||||
-- That is, empty parens immediately (no space) following a symbol
|
||||
-- That is, empty parens immediately (no space) following a symbol
|
||||
-- is treated as high precedence function application of `Unit`
|
||||
fn <- hashQualifiedPrefixTerm
|
||||
tok <- ann <$> openBlockWith "("
|
||||
@ -1008,10 +1013,10 @@ seqOp :: (Ord v) => P v m Pattern.SeqOp
|
||||
seqOp =
|
||||
Pattern.Snoc
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.snocSegment)))
|
||||
<|> Pattern.Cons
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
|
||||
<|> Pattern.Concat
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
|
||||
<|> Pattern.Cons
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.consSegment)))
|
||||
<|> Pattern.Concat
|
||||
<$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment NameSegment.concatSegment)))
|
||||
|
||||
term4 :: (Monad m, Var v) => TermP v m
|
||||
term4 = f <$> some termLeaf
|
||||
@ -1134,7 +1139,8 @@ binding = label "binding" do
|
||||
mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann
|
||||
mkBinding _lhsLoc [] body = body
|
||||
mkBinding lhsLoc args body =
|
||||
(Term.lam' (lhsLoc <> ann body) (L.payload <$> args) body)
|
||||
let annotatedArgs = args <&> \arg -> (ann arg, L.payload arg)
|
||||
in Term.lam' (lhsLoc <> ann body) annotatedArgs body
|
||||
|
||||
customFailure :: (P.MonadParsec e s m) => e -> m a
|
||||
customFailure = P.customFailure
|
||||
|
@ -490,7 +490,7 @@ pretty0
|
||||
(App' x (Constructor' (ConstructorReference DD.UnitRef 0)), _) | isLeaf x -> do
|
||||
px <- pretty0 (ac (if isBlock x then 0 else 9) Normal im doc) x
|
||||
pure . paren (p >= 11 || isBlock x && p >= 3) $
|
||||
px <> fmt S.DelayForceChar (l "()")
|
||||
px <> fmt S.Unit (l "()")
|
||||
(Apps' f (unsnoc -> Just (args, lastArg)), _)
|
||||
| isSoftHangable lastArg -> do
|
||||
fun <- goNormal 9 f
|
||||
@ -1958,7 +1958,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)])
|
||||
| nameEndsWith ppe suffix r,
|
||||
ABT.freeVars l == mempty,
|
||||
ok tm =
|
||||
Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
|
||||
Just (lamWithoutBindingAnns (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
|
||||
where
|
||||
ok (Apps' f _) = ABT.freeVars f == mempty
|
||||
ok tm = ABT.freeVars tm == mempty
|
||||
|
@ -78,7 +78,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
|
||||
blockAnn
|
||||
[(annotatedVar hdv, hdb)]
|
||||
e
|
||||
| otherwise = Term.singleLet isTop blockAnn (hdv, hdb) e
|
||||
| otherwise = Term.singleLet isTop blockAnn (annotationFor hdv) (hdv, hdb) e
|
||||
mklet cycle@((_, _) : _) e =
|
||||
Term.letRec
|
||||
isTop
|
||||
@ -86,10 +86,7 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
|
||||
(first annotatedVar <$> cycle)
|
||||
e
|
||||
mklet [] e = e
|
||||
in -- The outer annotation is going to be meaningful, so we make
|
||||
-- sure to preserve it, whereas the annotations at intermediate Abs
|
||||
-- nodes aren't necessarily meaningful
|
||||
Right . Just . ABT.annotate blockAnn . foldr mklet e $ cs
|
||||
in Right . Just . foldr mklet e $ cs
|
||||
minimize _ = Right Nothing
|
||||
|
||||
minimize' ::
|
||||
|
@ -57,7 +57,7 @@ test =
|
||||
ref = R.Id h 0
|
||||
v1 = Var.unnamedRef @Symbol ref
|
||||
-- input component: `ref = \v1 -> ref`
|
||||
component = Map.singleton ref (Term.lam () v1 (Term.refId () ref))
|
||||
component = Map.singleton ref (Term.lam () ((), v1) (Term.refId () ref))
|
||||
component' = Term.unhashComponent component
|
||||
-- expected unhashed component: `v2 = \v1 -> v2`, where `v2 /= v1`,
|
||||
-- i.e. `v2` cannot be just `ref` converted to a ref-named variable,
|
||||
|
@ -60,8 +60,8 @@ library
|
||||
Unison.Codebase.Patch
|
||||
Unison.Codebase.Path
|
||||
Unison.Codebase.Path.Parse
|
||||
Unison.Codebase.ProjectPath
|
||||
Unison.Codebase.PushBehavior
|
||||
Unison.Codebase.RootBranchCache
|
||||
Unison.Codebase.Runtime
|
||||
Unison.Codebase.Serialization
|
||||
Unison.Codebase.ShortCausalHash
|
||||
@ -72,6 +72,7 @@ library
|
||||
Unison.Codebase.SqliteCodebase.Migrations
|
||||
Unison.Codebase.SqliteCodebase.Migrations.Helpers
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4
|
||||
@ -131,7 +132,6 @@ library
|
||||
Unison.PrettyPrintEnvDecl.Names
|
||||
Unison.PrettyPrintEnvDecl.Sqlite
|
||||
Unison.PrintError
|
||||
Unison.Project.Util
|
||||
Unison.Result
|
||||
Unison.Runtime.ANF
|
||||
Unison.Runtime.ANF.Rehash
|
||||
@ -332,7 +332,6 @@ library
|
||||
, unison-util-base32hex
|
||||
, unison-util-bytes
|
||||
, unison-util-cache
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unison-util-rope
|
||||
, unison-util-serialization
|
||||
@ -533,7 +532,6 @@ test-suite parser-typechecker-tests
|
||||
, unison-util-base32hex
|
||||
, unison-util-bytes
|
||||
, unison-util-cache
|
||||
, unison-util-nametree
|
||||
, unison-util-relation
|
||||
, unison-util-rope
|
||||
, unison-util-serialization
|
||||
|
@ -1,70 +1,103 @@
|
||||
#!racket/base
|
||||
|
||||
(provide
|
||||
(prefix-out
|
||||
builtin-
|
||||
(combine-out
|
||||
Nat.toFloat
|
||||
Nat.increment
|
||||
Nat.+
|
||||
Nat.drop
|
||||
Float.*
|
||||
Float.fromRepresentation
|
||||
Float.toRepresentation
|
||||
Float.ceiling
|
||||
Int.+
|
||||
Int.-
|
||||
Int./
|
||||
Int.increment
|
||||
Int.negate
|
||||
Int.fromRepresentation
|
||||
Int.toRepresentation
|
||||
Int.signum
|
||||
)))
|
||||
builtin-Nat.+
|
||||
builtin-Nat.+:termlink
|
||||
builtin-Nat.toFloat
|
||||
builtin-Nat.toFloat:termlink
|
||||
builtin-Nat.increment
|
||||
builtin-Nat.increment:termlink
|
||||
builtin-Nat.drop
|
||||
builtin-Nat.drop:termlink
|
||||
builtin-Float.*
|
||||
builtin-Float.*:termlink
|
||||
builtin-Float.fromRepresentation
|
||||
builtin-Float.fromRepresentation:termlink
|
||||
builtin-Float.toRepresentation
|
||||
builtin-Float.toRepresentation:termlink
|
||||
builtin-Float.ceiling
|
||||
builtin-Float.ceiling:termlink
|
||||
builtin-Int.+
|
||||
builtin-Int.+:termlink
|
||||
builtin-Int.-
|
||||
builtin-Int.-:termlink
|
||||
builtin-Int./
|
||||
builtin-Int./:termlink
|
||||
builtin-Int.increment
|
||||
builtin-Int.increment:termlink
|
||||
builtin-Int.negate
|
||||
builtin-Int.negate:termlink
|
||||
builtin-Int.fromRepresentation
|
||||
builtin-Int.fromRepresentation:termlink
|
||||
builtin-Int.toRepresentation
|
||||
builtin-Int.toRepresentation:termlink
|
||||
builtin-Int.signum
|
||||
builtin-Int.signum:termlink)
|
||||
|
||||
(require racket
|
||||
racket/fixnum
|
||||
racket/flonum
|
||||
racket/performance-hint
|
||||
unison/data
|
||||
unison/boot)
|
||||
|
||||
(begin-encourage-inline
|
||||
(define-unison (Nat.+ m n) (clamp-natural (+ m n)))
|
||||
(define-unison (Nat.drop m n) (max 0 (- m n)))
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.+ m n)
|
||||
(clamp-natural (+ m n)))
|
||||
|
||||
(define-unison (Nat.increment n) (clamp-natural (add1 n)))
|
||||
(define-unison (Int.increment i) (clamp-integer (add1 i)))
|
||||
(define-unison (Int.negate i) (if (> i nbit63) (- i) i))
|
||||
(define-unison (Int.+ i j) (clamp-integer (+ i j)))
|
||||
(define-unison (Int.- i j) (clamp-integer (- i j)))
|
||||
(define-unison (Int./ i j) (floor (/ i j)))
|
||||
(define-unison (Int.signum i) (sgn i))
|
||||
(define-unison (Float.* x y) (fl* x y))
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.drop m n)
|
||||
(max 0 (- m n)))
|
||||
|
||||
(define-unison (Nat.toFloat n) (->fl n))
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.increment n)
|
||||
(clamp-natural (add1 n)))
|
||||
(define-unison-builtin
|
||||
(builtin-Int.increment i) (clamp-integer (add1 i)))
|
||||
(define-unison-builtin
|
||||
(builtin-Int.negate i) (if (> i nbit63) (- i) i))
|
||||
(define-unison-builtin
|
||||
(builtin-Int.+ i j) (clamp-integer (+ i j)))
|
||||
(define-unison-builtin
|
||||
(builtin-Int.- i j) (clamp-integer (- i j)))
|
||||
(define-unison-builtin
|
||||
(builtin-Int./ i j) (floor (/ i j)))
|
||||
(define-unison-builtin
|
||||
(builtin-Int.signum i) (sgn i))
|
||||
(define-unison-builtin
|
||||
(builtin-Float.* x y) (fl* x y))
|
||||
|
||||
(define-unison (Float.ceiling f)
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.toFloat n) (->fl n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.ceiling f)
|
||||
(clamp-integer (fl->exact-integer (ceiling f))))
|
||||
|
||||
; If someone can suggest a better mechanism for these,
|
||||
; that would be appreciated.
|
||||
(define-unison (Float.toRepresentation fl)
|
||||
(define-unison-builtin
|
||||
(builtin-Float.toRepresentation fl)
|
||||
(integer-bytes->integer
|
||||
(real->floating-point-bytes fl 8 #t) ; big endian
|
||||
#f ; unsigned
|
||||
#t)) ; big endian
|
||||
|
||||
(define-unison (Float.fromRepresentation n)
|
||||
(define-unison-builtin
|
||||
(builtin-Float.fromRepresentation n)
|
||||
(floating-point-bytes->real
|
||||
(integer->integer-bytes n 8 #f #t) ; unsigned, big endian
|
||||
#t)) ; big endian
|
||||
|
||||
(define-unison (Int.toRepresentation i)
|
||||
(define-unison-builtin
|
||||
(builtin-Int.toRepresentation i)
|
||||
(integer-bytes->integer
|
||||
(integer->integer-bytes i 8 #t #t) ; signed, big endian
|
||||
#f #t)) ; unsigned, big endian
|
||||
|
||||
(define-unison (Int.fromRepresentation n)
|
||||
(define-unison-builtin
|
||||
(builtin-Int.fromRepresentation n)
|
||||
(integer-bytes->integer
|
||||
(integer->integer-bytes n 8 #f #t) ; unsigned, big endian
|
||||
#t #t)) ; signed, big endian
|
||||
|
@ -55,6 +55,7 @@
|
||||
bytes
|
||||
control
|
||||
define-unison
|
||||
define-unison-builtin
|
||||
handle
|
||||
name
|
||||
data
|
||||
@ -116,14 +117,16 @@
|
||||
(require
|
||||
(for-syntax
|
||||
racket/set
|
||||
(only-in racket partition flatten))
|
||||
(only-in racket partition flatten split-at)
|
||||
(only-in racket/string string-prefix?)
|
||||
(only-in racket/syntax format-id))
|
||||
(rename-in
|
||||
(except-in racket false true unit any)
|
||||
[make-continuation-prompt-tag make-prompt])
|
||||
; (for (only (compatibility mlist) mlist->list list->mlist) expand)
|
||||
; (for (only (racket base) quasisyntax/loc) expand)
|
||||
; (for-syntax (only-in unison/core syntax->list))
|
||||
(only-in racket/control prompt0-at control0-at)
|
||||
(only-in racket/control control0-at)
|
||||
racket/performance-hint
|
||||
unison/core
|
||||
unison/data
|
||||
@ -151,115 +154,301 @@
|
||||
(syntax-rules ()
|
||||
[(with-name name e) (let ([name e]) name)]))
|
||||
|
||||
; function definition with slow/fast path. Slow path allows for
|
||||
; under/overapplication. Fast path is exact application.
|
||||
; Our definition macro needs to generate multiple entry points for the
|
||||
; defined procedures, so this is a function for making up names for
|
||||
; those based on the original.
|
||||
(define-for-syntax (adjust-symbol name post)
|
||||
(string->symbol
|
||||
(string-append
|
||||
(symbol->string name)
|
||||
":"
|
||||
post)))
|
||||
|
||||
(define-for-syntax (adjust-name name post)
|
||||
(datum->syntax name (adjust-symbol (syntax->datum name) post) name))
|
||||
|
||||
; Helper function. Turns a list of syntax objects into a
|
||||
; list-syntax object.
|
||||
(define-for-syntax (list->syntax l) #`(#,@l))
|
||||
|
||||
; These are auxiliary functions for manipulating a unison definition
|
||||
; into a form amenable for the right runtime behavior. This involves
|
||||
; multiple separate definitions:
|
||||
;
|
||||
; The intent is for the scheme compiler to be able to recognize and
|
||||
; optimize static, fast path calls itself, while still supporting
|
||||
; unison-like automatic partial application and such.
|
||||
(define-syntax (define-unison x)
|
||||
(define (fast-path-symbol name)
|
||||
(string->symbol
|
||||
(string-append
|
||||
(symbol->string name)
|
||||
":fast-path")))
|
||||
; 1. an :impl definition is generated containing the actual code body
|
||||
; 2. a :fast definition, which takes exactly the number of arguments
|
||||
; as the original, but checks if stack information needs to be
|
||||
; stored for continuation serialization.
|
||||
; 3. a :slow path which implements under/over application to unison
|
||||
; definitions, so they act like curried functions, not scheme
|
||||
; procedures
|
||||
; 4. a macro that implements the actual occurrences, and directly
|
||||
; calls the fast path for static calls with exactly the right
|
||||
; number of arguments
|
||||
;
|
||||
; Additionally, arguments are threaded through the internal
|
||||
; definitions that indicate whether an ability handler is in place
|
||||
; that could potentially result in the continuation being serialized.
|
||||
; If so, then calls write additional information to the continuation
|
||||
; for that serialization. This isn't cheap for tight loops, so we
|
||||
; attempt to avoid this as much as possible (conditioning the
|
||||
; annotation on a flag checkseems to cause no performance loss).
|
||||
|
||||
(define (fast-path-name name)
|
||||
(datum->syntax name (fast-path-symbol (syntax->datum name))))
|
||||
|
||||
; Helper function. Turns a list of syntax objects into a
|
||||
; list-syntax object.
|
||||
(define (list->syntax l) #`(#,@l))
|
||||
; Builds partial application cases for unison functions.
|
||||
; It seems most efficient to have a case for each posible
|
||||
; under-application.
|
||||
(define (build-partials name formals)
|
||||
(let rec ([us formals] [acc '()])
|
||||
(syntax-case us ()
|
||||
[() (list->syntax (cons #`[() #,name] acc))]
|
||||
[(a ... z)
|
||||
(rec #'(a ...)
|
||||
(cons
|
||||
#`[(a ... z)
|
||||
(with-name
|
||||
#,(datum->syntax name (syntax->datum name))
|
||||
(partial-app #,name a ... z))]
|
||||
acc))])))
|
||||
; This builds the core definition for a unison definition. It is just
|
||||
; a lambda expression with the original code, but with an additional
|
||||
; keyword argument for threading purity information.
|
||||
(define-for-syntax (make-impl name:impl:stx arg:stx body:stx)
|
||||
(with-syntax ([name:impl name:impl:stx]
|
||||
[args arg:stx]
|
||||
[body body:stx])
|
||||
(syntax/loc body:stx
|
||||
(define (name:impl #:pure pure? . args) . body))))
|
||||
|
||||
; Given an overall function name, a fast path name, and a list of
|
||||
; arguments, builds the case-lambda body of a unison function that
|
||||
; enables applying to arbitrary numbers of arguments.
|
||||
(define (func-cases name name:fast args)
|
||||
(syntax-case args ()
|
||||
[() (quasisyntax/loc x
|
||||
(case-lambda
|
||||
[() (#,name:fast)]
|
||||
[r (apply (#,name:fast) r)]))]
|
||||
[(a ... z)
|
||||
(quasisyntax/loc x
|
||||
(case-lambda
|
||||
#,@(build-partials name #'(a ...))
|
||||
[(a ... z) (#,name:fast a ... z)]
|
||||
[(a ... z . r) (apply (#,name:fast a ... z) r)]))]))
|
||||
(define frame-contents (gensym))
|
||||
|
||||
(syntax-case x ()
|
||||
[(define-unison (name a ...) e ...)
|
||||
(let ([fname (fast-path-name #'name)])
|
||||
(with-syntax ([name:fast fname]
|
||||
[fast (syntax/loc x (lambda (a ...) e ...))]
|
||||
[slow (func-cases #'name fname #'(a ...))])
|
||||
(syntax/loc x
|
||||
(define-values (name:fast name) (values fast slow)))))]))
|
||||
; Builds the wrapper definition, 'fast path,' which just tests the
|
||||
; purity, writes the stack information if necessary, and calls the
|
||||
; implementation. If #:force-pure is specified, the fast path just
|
||||
; directly calls the implementation procedure. This should allow
|
||||
; tight loops to still perform well if we can detect that they
|
||||
; (hereditarily) cannot make ability requests, even in contexts
|
||||
; where a handler is present.
|
||||
(define-for-syntax
|
||||
(make-fast-path
|
||||
#:force-pure force-pure?
|
||||
loc ; original location
|
||||
name:fast:stx name:impl:stx
|
||||
arg:stx)
|
||||
|
||||
(with-syntax ([name:impl name:impl:stx]
|
||||
[name:fast name:fast:stx]
|
||||
[args arg:stx])
|
||||
(if force-pure?
|
||||
(syntax/loc loc
|
||||
(define name:fast name:impl))
|
||||
|
||||
(syntax/loc loc
|
||||
(define (name:fast #:pure pure? . args)
|
||||
(if pure?
|
||||
(name:impl #:pure pure? . args)
|
||||
(with-continuation-mark
|
||||
frame-contents
|
||||
(vector . args)
|
||||
(name:impl #:pure pure? . args))))))))
|
||||
|
||||
; Slow path -- unnecessary
|
||||
; (define-for-syntax (make-slow-path loc name argstx)
|
||||
; (with-syntax ([name:slow (adjust-symbol name "slow")]
|
||||
; [n (length (syntax->list argstx))])
|
||||
; (syntax/loc loc
|
||||
; (define (name:slow #:pure pure? . as)
|
||||
; (define k (length as))
|
||||
; (cond
|
||||
; [(< k n) (unison-closure n name:slow as)]
|
||||
; [(= k n) (apply name:fast #:pure pure? as)]
|
||||
; [(> k n)
|
||||
; (define-values (h t) (split-at as n))
|
||||
; (apply
|
||||
; (apply name:fast #:pure pure? h)
|
||||
; #:pure pure?
|
||||
; t)])))))
|
||||
|
||||
; This definition builds a macro that defines the behavior of actual
|
||||
; occurences of the definition names. It has the following behavior:
|
||||
;
|
||||
; 1. Exactly saturated occurences directly call the fast path
|
||||
; 2. Undersaturated or unapplied occurrences become closure
|
||||
; construction
|
||||
; 3. Oversaturated occurrences become an appropriate nested
|
||||
; application
|
||||
;
|
||||
; Because of point 2, all function values end up represented as
|
||||
; unison-closure objects, so a slow path procedure is no longer
|
||||
; necessary; it is handled by the prop:procedure of the closure
|
||||
; structure. This should also make various universal operations easier
|
||||
; to handle, because we can just test for unison-closures, instead of
|
||||
; having to deal with raw procedures.
|
||||
(define-for-syntax
|
||||
(make-callsite-macro
|
||||
#:internal internal?
|
||||
loc ; original location
|
||||
name:stx name:fast:stx
|
||||
arity:val)
|
||||
(with-syntax ([name name:stx]
|
||||
[name:fast name:fast:stx]
|
||||
[arity arity:val])
|
||||
(cond
|
||||
[internal?
|
||||
(syntax/loc loc
|
||||
(define-syntax (name stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:by-name _ . bs)
|
||||
(syntax/loc stx
|
||||
(unison-closure arity name:fast (list . bs)))]
|
||||
[(_ . bs)
|
||||
(let ([k (length (syntax->list #'bs))])
|
||||
(cond
|
||||
[(= arity k) ; saturated
|
||||
(syntax/loc stx
|
||||
(name:fast #:pure #t . bs))]
|
||||
[(> arity k) ; undersaturated
|
||||
(syntax/loc stx
|
||||
(unison-closure arity name:fast (list . bs)))]
|
||||
[(< arity k) ; oversaturated
|
||||
(define-values (h t)
|
||||
(split-at (syntax->list #'bs) arity))
|
||||
|
||||
(quasisyntax/loc stx
|
||||
((name:fast #:pure #t #,@h) #,@t))]))]
|
||||
[_ (syntax/loc stx
|
||||
(unison-closure arity name:fast (list)))])))]
|
||||
[else
|
||||
(syntax/loc loc
|
||||
(define-syntax (name stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:by-name _ . bs)
|
||||
(syntax/loc stx
|
||||
(unison-closure arity name:fast (list . bs)))]
|
||||
[(_ . bs)
|
||||
(let ([k (length (syntax->list #'bs))])
|
||||
|
||||
; todo: purity
|
||||
|
||||
; capture local pure?
|
||||
(with-syntax ([pure? (format-id stx "pure?")])
|
||||
(cond
|
||||
[(= arity k) ; saturated
|
||||
(syntax/loc stx
|
||||
(name:fast #:pure pure? . bs))]
|
||||
[(> arity k)
|
||||
(syntax/loc stx
|
||||
(unison-closure n name:fast (list . bs)))]
|
||||
[(< arity k) ; oversaturated
|
||||
(define-values (h t)
|
||||
(split-at (syntax->list #'bs) arity))
|
||||
|
||||
; TODO: pending argument frame
|
||||
(quasisyntax/loc stx
|
||||
((name:fast #:pure pure? #,@h)
|
||||
#:pure pure?
|
||||
#,@t))])))]
|
||||
; non-applied occurrence; partial ap immediately
|
||||
[_ (syntax/loc stx
|
||||
(unison-closure arity name:fast (list)))])))])))
|
||||
|
||||
(define-for-syntax
|
||||
(link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)
|
||||
(if no-link-decl?
|
||||
#'()
|
||||
(let ([name:link:stx (adjust-name name:stx "termlink")])
|
||||
(with-syntax
|
||||
([name:fast name:fast:stx]
|
||||
[name:impl name:impl:stx]
|
||||
[name:link name:link:stx])
|
||||
(syntax/loc loc
|
||||
((declare-function-link name:fast name:link)
|
||||
(declare-function-link name:impl name:link)))))))
|
||||
|
||||
(define-for-syntax (process-hints hs)
|
||||
(for/fold ([internal? #f]
|
||||
[force-pure? #t]
|
||||
[gen-link? #f]
|
||||
[no-link-decl? #f])
|
||||
([h hs])
|
||||
(values
|
||||
(or internal? (eq? h 'internal))
|
||||
(or force-pure? (eq? h 'force-pure) (eq? h 'internal))
|
||||
(or gen-link? (eq? h 'gen-link))
|
||||
(or no-link-decl? (eq? h 'no-link-decl)))))
|
||||
|
||||
(define-for-syntax
|
||||
(make-link-def gen-link? loc name:stx name:link:stx)
|
||||
|
||||
(define (chop s)
|
||||
(if (string-prefix? s "builtin-")
|
||||
(substring s 8)
|
||||
s))
|
||||
|
||||
(define name:txt
|
||||
(chop
|
||||
(symbol->string
|
||||
(syntax->datum name:stx))))
|
||||
|
||||
(cond
|
||||
[gen-link?
|
||||
(with-syntax ([name:link name:link:stx])
|
||||
(quasisyntax/loc loc
|
||||
((define name:link
|
||||
(unison-termlink-builtin #,name:txt)))))]
|
||||
[else #'()]))
|
||||
|
||||
(define-for-syntax
|
||||
(expand-define-unison
|
||||
#:hints hints
|
||||
loc name:stx arg:stx expr:stx)
|
||||
|
||||
(define-values
|
||||
(internal? force-pure? gen-link? no-link-decl?)
|
||||
(process-hints hints))
|
||||
|
||||
(let ([name:fast:stx (adjust-name name:stx "fast")]
|
||||
[name:impl:stx (adjust-name name:stx "impl")]
|
||||
[name:link:stx (adjust-name name:stx "termlink")]
|
||||
[arity (length (syntax->list arg:stx))])
|
||||
(with-syntax
|
||||
([(link ...) (make-link-def gen-link? loc name:stx name:link:stx)]
|
||||
[fast (make-fast-path
|
||||
#:force-pure force-pure?
|
||||
loc name:fast:stx name:impl:stx arg:stx)]
|
||||
[impl (make-impl name:impl:stx arg:stx expr:stx)]
|
||||
[call (make-callsite-macro
|
||||
#:internal internal?
|
||||
loc name:stx name:fast:stx arity)]
|
||||
[(decls ...)
|
||||
(link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)])
|
||||
(syntax/loc loc
|
||||
(begin link ... impl fast call decls ...)))))
|
||||
|
||||
; Function definition supporting various unison features, like
|
||||
; partial application and continuation serialization. See above for
|
||||
; details.
|
||||
;
|
||||
; `#:internal #t` indicates that the definition is for builtin
|
||||
; functions. These should always be built in a way that does not
|
||||
; annotate the stack, because they don't make relevant ability
|
||||
; requests. This is important for performance and some correct
|
||||
; behavior (i.e. they may occur in non-unison contexts where a
|
||||
; `pure?` indicator is not being threaded).
|
||||
(define-syntax (define-unison stx)
|
||||
(syntax-case stx ()
|
||||
[(define-unison #:hints hs (name . args) . exprs)
|
||||
(expand-define-unison
|
||||
#:hints (syntax->datum #'hs)
|
||||
stx #'name #'args #'exprs)]
|
||||
[(define-unison (name . args) . exprs)
|
||||
(expand-define-unison
|
||||
#:hints '[internal]
|
||||
stx #'name #'args #'exprs)]))
|
||||
|
||||
(define-syntax (define-unison-builtin stx)
|
||||
(syntax-case stx ()
|
||||
[(define-unison-builtin . rest)
|
||||
(syntax/loc stx
|
||||
(define-unison #:hints [internal gen-link] . rest))]))
|
||||
|
||||
; call-by-name bindings
|
||||
(define-syntax name
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((name ([v (f . args)] ...) body ...)
|
||||
(with-syntax ([(lam ...)
|
||||
(map (lambda (body)
|
||||
(quasisyntax/loc stx
|
||||
(lambda r #,body)))
|
||||
(syntax->list #'[(apply f (append (list . args) r)) ...]))])
|
||||
#`(let ([v lam] ...)
|
||||
body ...))))))
|
||||
(define-syntax (name stx)
|
||||
(syntax-case stx ()
|
||||
[(name ([v (f . args)] ...) body ...)
|
||||
(syntax/loc stx
|
||||
(let ([v (f #:by-name #t . args)] ...) body ...))]))
|
||||
|
||||
; Wrapper that more closely matches `handle` constructs
|
||||
;
|
||||
; Note: this uses the prompt _twice_ to achieve the sort of dynamic
|
||||
; scoping we want. First we push an outer delimiter, then install
|
||||
; the continuation marks corresponding to the handled abilities
|
||||
; (which tells which propt to use for that ability and which
|
||||
; functions to use for each request). Then we re-delimit by the same
|
||||
; prompt.
|
||||
;
|
||||
; If we just used one delimiter, we'd have a problem. If we pushed
|
||||
; the marks _after_ the delimiter, then the continuation captured
|
||||
; when handling would contain those marks, and would effectively
|
||||
; retain the handler for requests within the continuation. If the
|
||||
; marks were outside the prompt, we'd be in a similar situation,
|
||||
; except where the handler would be automatically handling requests
|
||||
; within its own implementation (although, in both these cases we'd
|
||||
; get control errors, because we would be using the _function_ part
|
||||
; of the handler without the necessary delimiters existing on the
|
||||
; continuation). Both of these situations are wrong for _shallow_
|
||||
; handlers.
|
||||
;
|
||||
; Instead, what we need to be able to do is capture the continuation
|
||||
; _up to_ the marks, then _discard_ the marks, and this is what the
|
||||
; multiple delimiters accomplish. There might be more efficient ways
|
||||
; to accomplish this with some specialized mark functions, but I'm
|
||||
; uncertain of what pitfalls there are with regard to that (whehter
|
||||
; they work might depend on exact frame structure of the
|
||||
; metacontinuation).
|
||||
(define-syntax handle
|
||||
(syntax-rules ()
|
||||
[(handle [r ...] h e ...)
|
||||
(let ([p (make-prompt)])
|
||||
(prompt0-at p
|
||||
(let ([v (let-marks (list r ...) (cons p h)
|
||||
(prompt0-at p e ...))])
|
||||
(h (make-pure v)))))]))
|
||||
(call-with-handler (list r ...) h (lambda () e ...))]))
|
||||
|
||||
; wrapper that more closely matches ability requests
|
||||
(define-syntax request
|
||||
|
@ -66,17 +66,17 @@
|
||||
[cas! (lambda () (unsafe-struct*-cas! promise 2 value (some new-value)))]
|
||||
[awake-readers (lambda () (semaphore-post (promise-semaphore promise)))])
|
||||
(cond
|
||||
[(some? value) false]
|
||||
[(some? value) sum-false]
|
||||
[else
|
||||
(let ([ok (parameterize-break #f (if (cas!) (awake-readers) false))])
|
||||
(if ok true (loop)))]))))
|
||||
(let ([ok (parameterize-break #f (if (cas!) (awake-readers) sum-false))])
|
||||
(if ok sum-true (loop)))]))))
|
||||
|
||||
(define (ref-cas ref ticket value)
|
||||
(if (box-cas! ref ticket value) true false))
|
||||
(if (box-cas! ref ticket value) sum-true sum-false))
|
||||
|
||||
(define (sleep n)
|
||||
(sleep-secs (/ n 1000000))
|
||||
(right unit))
|
||||
(right sum-unit))
|
||||
|
||||
;; Swallows uncaught breaks/thread kills rather than logging them to
|
||||
;; match the behaviour of the Haskell runtime
|
||||
@ -88,5 +88,5 @@
|
||||
|
||||
(define (kill threadId)
|
||||
(break-thread threadId)
|
||||
(right unit))
|
||||
(right sum-unit))
|
||||
)
|
||||
|
@ -23,6 +23,7 @@
|
||||
(struct-out exn:bug)
|
||||
|
||||
let-marks
|
||||
call-with-marks
|
||||
ref-mark
|
||||
|
||||
chunked-string-foldMap-chunks
|
||||
@ -192,7 +193,9 @@
|
||||
(string-append "{Value " (describe-value v) "}")]
|
||||
[(unison-code v)
|
||||
(string-append "{Code " (describe-value v) "}")]
|
||||
[(unison-closure code env)
|
||||
[(unison-cont-reflected fs) "{Continuation}"]
|
||||
[(unison-cont-wrapped _) "{Continuation}"]
|
||||
[(unison-closure _ code env)
|
||||
(define dc
|
||||
(termlink->string (lookup-function-link code) #t))
|
||||
(define (f v)
|
||||
@ -437,13 +440,6 @@
|
||||
; [() '()]
|
||||
; [(x . xs) (cons #'x (syntax->list #'xs))]))
|
||||
|
||||
(define (call-with-marks rs v f)
|
||||
(cond
|
||||
[(null? rs) (f)]
|
||||
[else
|
||||
(with-continuation-mark (car rs) v
|
||||
(call-with-marks (cdr rs) v f))]))
|
||||
|
||||
(define-syntax let-marks
|
||||
(syntax-rules ()
|
||||
[(let-marks ks bn e ...)
|
||||
|
@ -12,6 +12,12 @@
|
||||
have-code?
|
||||
|
||||
(struct-out unison-data)
|
||||
(struct-out unison-continuation)
|
||||
(struct-out unison-cont-wrapped)
|
||||
(struct-out unison-cont-reflected)
|
||||
(struct-out unison-frame)
|
||||
(struct-out unison-frame-push)
|
||||
(struct-out unison-frame-mark)
|
||||
(struct-out unison-sum)
|
||||
(struct-out unison-pure)
|
||||
(struct-out unison-request)
|
||||
@ -27,6 +33,9 @@
|
||||
(struct-out unison-quote)
|
||||
(struct-out unison-timespec)
|
||||
|
||||
call-with-handler
|
||||
call-with-marks
|
||||
|
||||
define-builtin-link
|
||||
declare-builtin-link
|
||||
|
||||
@ -45,9 +54,9 @@
|
||||
left?
|
||||
either-get
|
||||
either-get
|
||||
unit
|
||||
false
|
||||
true
|
||||
sum-unit
|
||||
sum-false
|
||||
sum-true
|
||||
bool
|
||||
char
|
||||
ord
|
||||
@ -100,12 +109,15 @@
|
||||
builtin-tls.version:typelink
|
||||
|
||||
unison-tuple->list
|
||||
unison-pair->cons
|
||||
|
||||
typelink->string
|
||||
termlink->string)
|
||||
|
||||
(require
|
||||
racket
|
||||
(rename-in racket
|
||||
[make-continuation-prompt-tag make-prompt])
|
||||
(only-in racket/control prompt0-at control0-at)
|
||||
racket/fixnum
|
||||
(only-in "vector-trie.rkt" ->fx/wraparound)
|
||||
unison/bytevector)
|
||||
@ -290,13 +302,10 @@
|
||||
(write-string ")" port))
|
||||
|
||||
(struct unison-closure
|
||||
(code env)
|
||||
(arity code env)
|
||||
#:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc clo port mode)
|
||||
(define code-tl
|
||||
(lookup-function-link (unison-closure-code clo)))
|
||||
|
||||
(define rec
|
||||
(case mode
|
||||
[(#t) write]
|
||||
@ -308,12 +317,31 @@
|
||||
(write-string " " port)
|
||||
(write-sequence (unison-closure-env clo) port mode)
|
||||
(write-string ")" port))]
|
||||
|
||||
; This has essentially becomes the slow path for unison function
|
||||
; application. The definition macro immediately creates a closure
|
||||
; for any statically under-saturated call or unapplied occurrence.
|
||||
; This means that there is never a bare unison function being passed
|
||||
; as a value. So, we can define the slow path here once and for all.
|
||||
#:property prop:procedure
|
||||
(case-lambda
|
||||
[(clo) clo]
|
||||
[(clo . rest)
|
||||
(apply (unison-closure-code clo)
|
||||
(append (unison-closure-env clo) rest))]))
|
||||
(lambda (clo #:pure [pure? #f] #:by-name [by-name? #f] . rest)
|
||||
(define arity (unison-closure-arity clo))
|
||||
(define old-env (unison-closure-env clo))
|
||||
(define code (unison-closure-code clo))
|
||||
|
||||
(define new-env (append old-env rest))
|
||||
(define k (length rest))
|
||||
(define l (length new-env))
|
||||
(cond
|
||||
[(or by-name? (> arity l))
|
||||
(struct-copy unison-closure clo [env new-env])]
|
||||
[(= arity l) ; saturated
|
||||
(apply code #:pure pure? new-env)]
|
||||
[(= k 0) clo] ; special case, 0-applying undersaturated
|
||||
[(< arity l)
|
||||
; TODO: pending arg annotation if no pure?
|
||||
(define-values (now pending) (split-at new-env arity))
|
||||
(apply (apply code #:pure pure? now) #:pure pure? pending)])))
|
||||
|
||||
(struct unison-timespec (sec nsec)
|
||||
#:transparent
|
||||
@ -335,6 +363,115 @@
|
||||
|
||||
(list equal-proc (hash-proc 3) (hash-proc 5))))
|
||||
|
||||
; This is the base struct for continuation representations. It has
|
||||
; two possibilities seen below.
|
||||
(struct unison-continuation () #:transparent)
|
||||
|
||||
; This is a wrapper that allows for a struct representation of all
|
||||
; continuations involved in unison. I.E. instead of just passing
|
||||
; around a raw racket continuation, we wrap it in a box for easier
|
||||
; identification.
|
||||
(struct unison-cont-wrapped unison-continuation (cont)
|
||||
; Use the wrapped continuation for procedure calls. Continuations
|
||||
; will always be called via the jumpCont wrapper which exactly
|
||||
; applies them to one argument.
|
||||
#:property prop:procedure 0)
|
||||
|
||||
; Basic mechanism for installing handlers, defined here so that it
|
||||
; can be used in the implementation of reflected continuations.
|
||||
;
|
||||
; Note: this uses the prompt _twice_ to achieve the sort of dynamic
|
||||
; scoping we want. First we push an outer delimiter, then install
|
||||
; the continuation marks corresponding to the handled abilities
|
||||
; (which tells which propt to use for that ability and which
|
||||
; functions to use for each request). Then we re-delimit by the same
|
||||
; prompt.
|
||||
;
|
||||
; If we just used one delimiter, we'd have a problem. If we pushed
|
||||
; the marks _after_ the delimiter, then the continuation captured
|
||||
; when handling would contain those marks, and would effectively
|
||||
; retain the handler for requests within the continuation. If the
|
||||
; marks were outside the prompt, we'd be in a similar situation,
|
||||
; except where the handler would be automatically handling requests
|
||||
; within its own implementation (although, in both these cases we'd
|
||||
; get control errors, because we would be using the _function_ part
|
||||
; of the handler without the necessary delimiters existing on the
|
||||
; continuation). Both of these situations are wrong for _shallow_
|
||||
; handlers.
|
||||
;
|
||||
; Instead, what we need to be able to do is capture the continuation
|
||||
; _up to_ the marks, then _discard_ the marks, and this is what the
|
||||
; multiple delimiters accomplish. There might be more efficient ways
|
||||
; to accomplish this with some specialized mark functions, but I'm
|
||||
; uncertain of what pitfalls there are with regard to that (whehter
|
||||
; they work might depend on exact frame structure of the
|
||||
; metacontinuation).
|
||||
(define (call-with-handler rs h f)
|
||||
(let ([p (make-prompt)])
|
||||
(prompt0-at p
|
||||
(let ([v (call-with-marks rs (cons p h)
|
||||
(lambda () (prompt0-at p (f))))])
|
||||
(h (make-pure v))))))
|
||||
|
||||
(define (call-with-marks rs v f)
|
||||
(cond
|
||||
[(null? rs) (f)]
|
||||
[else
|
||||
(with-continuation-mark (car rs) v
|
||||
(call-with-marks (cdr rs) v f))]))
|
||||
|
||||
; Version of the above for re-installing a handlers in the serialized
|
||||
; format. In that case, there is an association list of links and
|
||||
; handlers, rather than a single handler (although the separate
|
||||
; handlers are likely duplicates).
|
||||
(define (call-with-assoc-marks p hs f)
|
||||
(match hs
|
||||
['() (f)]
|
||||
[(cons (cons r h) rest)
|
||||
(with-continuation-mark r (cons p h)
|
||||
(call-with-assoc-marks rest f))]))
|
||||
|
||||
(define (call-with-handler-assocs hs f)
|
||||
(let ([p (make-prompt)])
|
||||
(prompt0-at p
|
||||
(call-with-assoc-marks p hs
|
||||
(lambda () (prompt0-at p (f)))))))
|
||||
|
||||
(define (repush frames v)
|
||||
(match frames
|
||||
['() v]
|
||||
[(cons (unison-frame-mark as tls hs) frames)
|
||||
; handler frame; as are pending arguments, tls are typelinks
|
||||
; for handled abilities; hs are associations from links to
|
||||
; handler values.
|
||||
;
|
||||
; todo: args
|
||||
(call-with-handler-assocs hs
|
||||
(lambda () (repush frames v)))]
|
||||
[(cons (unison-frame-push ls as rt) rest)
|
||||
(displayln (list ls as rt))
|
||||
(raise "repush push: not implemented yet")]))
|
||||
|
||||
; This is a *reflected* representation of continuations amenable
|
||||
; to serialization. Most continuations won't be in this format,
|
||||
; because it's foolish to eagerly parse the racket continuation if
|
||||
; it's just going to be applied. But, a continuation that we've
|
||||
; gotten from serialization will be in this format.
|
||||
;
|
||||
; `frames` should be a list of the below `unison-frame` structs.
|
||||
(struct unison-cont-reflected unison-continuation (frames)
|
||||
#:property prop:procedure
|
||||
(lambda (cont v) (repush (unison-cont-reflected-frames cont) v)))
|
||||
|
||||
; Stack frames for reflected continuations
|
||||
(struct unison-frame () #:transparent)
|
||||
|
||||
(struct unison-frame-push unison-frame
|
||||
(locals args return-to))
|
||||
|
||||
(struct unison-frame-mark unison-frame
|
||||
(args abilities handlers))
|
||||
|
||||
(define-syntax (define-builtin-link stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
@ -344,9 +481,11 @@
|
||||
[dname (datum->syntax stx
|
||||
(string->symbol
|
||||
(string-append
|
||||
"builtin-" txt ":termlink")))])
|
||||
#`(define #,dname
|
||||
(unison-termlink-builtin #,(datum->syntax stx txt))))]))
|
||||
"builtin-" txt ":termlink"))
|
||||
#'name)])
|
||||
(quasisyntax/loc stx
|
||||
(define #,dname
|
||||
(unison-termlink-builtin #,(datum->syntax stx txt)))))]))
|
||||
|
||||
(define-syntax (declare-builtin-link stx)
|
||||
(syntax-case stx ()
|
||||
@ -357,7 +496,8 @@
|
||||
[dname (datum->syntax stx
|
||||
(string->symbol
|
||||
(string-append txt ":termlink")))])
|
||||
#`(declare-function-link name #,dname))]))
|
||||
(quasisyntax/loc stx
|
||||
(declare-function-link name #,dname)))]))
|
||||
|
||||
(define (partial-app f . args) (unison-closure f args))
|
||||
|
||||
@ -382,11 +522,11 @@
|
||||
|
||||
; #<void> works as well
|
||||
; Unit
|
||||
(define unit (sum 0))
|
||||
(define sum-unit (sum 0))
|
||||
|
||||
; Booleans are represented as numbers
|
||||
(define false 0)
|
||||
(define true 1)
|
||||
(define sum-false 0)
|
||||
(define sum-true 1)
|
||||
|
||||
(define (bool b) (if b 1 0))
|
||||
|
||||
@ -542,6 +682,13 @@
|
||||
[else
|
||||
(raise "unison-tuple->list: unexpected value")])))
|
||||
|
||||
(define (unison-pair->cons t)
|
||||
(match t
|
||||
[(unison-data _ _ (list x (unison-data _ _ (list y _))))
|
||||
(cons x y)]
|
||||
[else
|
||||
(raise "unison-pair->cons: unexpected value")]))
|
||||
|
||||
(define (hash-string hs)
|
||||
(string-append
|
||||
"#"
|
||||
|
@ -3,7 +3,7 @@
|
||||
rnrs/io/ports-6
|
||||
(only-in rnrs standard-error-port standard-input-port standard-output-port vector-map)
|
||||
(only-in racket empty? with-output-to-string system/exit-code system false?)
|
||||
(only-in unison/boot data-case define-unison)
|
||||
(only-in unison/boot data-case define-unison-builtin)
|
||||
unison/data
|
||||
unison/chunked-seq
|
||||
unison/data
|
||||
@ -15,26 +15,39 @@
|
||||
(provide
|
||||
unison-FOp-IO.stdHandle
|
||||
unison-FOp-IO.openFile.impl.v3
|
||||
(prefix-out
|
||||
builtin-IO.
|
||||
(combine-out
|
||||
seekHandle.impl.v3
|
||||
getLine.impl.v1
|
||||
getSomeBytes.impl.v1
|
||||
getBuffering.impl.v3
|
||||
setBuffering.impl.v3
|
||||
getEcho.impl.v1
|
||||
setEcho.impl.v1
|
||||
getArgs.impl.v1
|
||||
getEnv.impl.v1
|
||||
getChar.impl.v1
|
||||
isFileOpen.impl.v3
|
||||
isSeekable.impl.v3
|
||||
handlePosition.impl.v3
|
||||
process.call
|
||||
getCurrentDirectory.impl.v3
|
||||
ready.impl.v1
|
||||
))
|
||||
|
||||
builtin-IO.seekHandle.impl.v3
|
||||
builtin-IO.seekHandle.impl.v3:termlink
|
||||
builtin-IO.getLine.impl.v1
|
||||
builtin-IO.getLine.impl.v1:termlink
|
||||
builtin-IO.getSomeBytes.impl.v1
|
||||
builtin-IO.getSomeBytes.impl.v1:termlink
|
||||
builtin-IO.getBuffering.impl.v3
|
||||
builtin-IO.getBuffering.impl.v3:termlink
|
||||
builtin-IO.setBuffering.impl.v3
|
||||
builtin-IO.setBuffering.impl.v3:termlink
|
||||
builtin-IO.getEcho.impl.v1
|
||||
builtin-IO.getEcho.impl.v1:termlink
|
||||
builtin-IO.setEcho.impl.v1
|
||||
builtin-IO.setEcho.impl.v1:termlink
|
||||
builtin-IO.getArgs.impl.v1
|
||||
builtin-IO.getArgs.impl.v1:termlink
|
||||
builtin-IO.getEnv.impl.v1
|
||||
builtin-IO.getEnv.impl.v1:termlink
|
||||
builtin-IO.getChar.impl.v1
|
||||
builtin-IO.getChar.impl.v1:termlink
|
||||
builtin-IO.isFileOpen.impl.v3
|
||||
builtin-IO.isFileOpen.impl.v3:termlink
|
||||
builtin-IO.isSeekable.impl.v3
|
||||
builtin-IO.isSeekable.impl.v3:termlink
|
||||
builtin-IO.handlePosition.impl.v3
|
||||
builtin-IO.handlePosition.impl.v3:termlink
|
||||
builtin-IO.process.call
|
||||
builtin-IO.process.call:termlink
|
||||
builtin-IO.getCurrentDirectory.impl.v3
|
||||
builtin-IO.getCurrentDirectory.impl.v3:termlink
|
||||
builtin-IO.ready.impl.v1
|
||||
builtin-IO.ready.impl.v1:termlink
|
||||
|
||||
; Still to implement:
|
||||
; handlePosition.impl.v3
|
||||
@ -49,28 +62,34 @@
|
||||
[f (ref-failure-failure typeLink msg a)])
|
||||
(ref-either-left f)))
|
||||
|
||||
(define-unison (isFileOpen.impl.v3 port)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.isFileOpen.impl.v3 port)
|
||||
(ref-either-right (not (port-closed? port))))
|
||||
|
||||
(define-unison (ready.impl.v1 port)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.ready.impl.v1 port)
|
||||
(if (byte-ready? port)
|
||||
(ref-either-right #t)
|
||||
(if (port-eof? port)
|
||||
(Exception ref-iofailure:typelink "EOF" port)
|
||||
(ref-either-right #f))))
|
||||
|
||||
(define-unison (getCurrentDirectory.impl.v3 unit)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getCurrentDirectory.impl.v3 unit)
|
||||
(ref-either-right
|
||||
(string->chunked-string (path->string (current-directory)))))
|
||||
|
||||
(define-unison (isSeekable.impl.v3 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.isSeekable.impl.v3 handle)
|
||||
(ref-either-right
|
||||
(port-has-set-port-position!? handle)))
|
||||
|
||||
(define-unison (handlePosition.impl.v3 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.handlePosition.impl.v3 handle)
|
||||
(ref-either-right (port-position handle)))
|
||||
|
||||
(define-unison (seekHandle.impl.v3 handle mode amount)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.seekHandle.impl.v3 handle mode amount)
|
||||
(data-case mode
|
||||
(0 ()
|
||||
(set-port-position! handle amount)
|
||||
@ -85,14 +104,16 @@
|
||||
"SeekFromEnd not supported"
|
||||
0))))
|
||||
|
||||
(define-unison (getLine.impl.v1 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getLine.impl.v1 handle)
|
||||
(let* ([line (read-line handle)])
|
||||
(if (eof-object? line)
|
||||
(ref-either-right (string->chunked-string ""))
|
||||
(ref-either-right (string->chunked-string line))
|
||||
)))
|
||||
|
||||
(define-unison (getChar.impl.v1 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getChar.impl.v1 handle)
|
||||
(let* ([char (read-char handle)])
|
||||
(if (eof-object? char)
|
||||
(Exception
|
||||
@ -101,7 +122,8 @@
|
||||
ref-unit-unit)
|
||||
(ref-either-right char))))
|
||||
|
||||
(define-unison (getSomeBytes.impl.v1 handle nbytes)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getSomeBytes.impl.v1 handle nbytes)
|
||||
(let* ([buffer (make-bytes nbytes)]
|
||||
[line (read-bytes-avail! buffer handle)])
|
||||
(cond
|
||||
@ -119,7 +141,8 @@
|
||||
(subbytes buffer 0 line)
|
||||
buffer)))])))
|
||||
|
||||
(define-unison (getBuffering.impl.v3 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getBuffering.impl.v3 handle)
|
||||
(case (file-stream-buffer-mode handle)
|
||||
[(none) (ref-either-right ref-buffermode-no-buffering)]
|
||||
[(line) (ref-either-right
|
||||
@ -135,7 +158,8 @@
|
||||
"Unexpected response from file-stream-buffer-mode"
|
||||
ref-unit-unit)]))
|
||||
|
||||
(define-unison (setBuffering.impl.v3 handle mode)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.setBuffering.impl.v3 handle mode)
|
||||
(data-case mode
|
||||
(0 ()
|
||||
(file-stream-buffer-mode handle 'none)
|
||||
@ -166,7 +190,8 @@
|
||||
[(1) stdout]
|
||||
[(2) stderr]))
|
||||
|
||||
(define-unison (getEcho.impl.v1 handle)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getEcho.impl.v1 handle)
|
||||
(if (eq? handle stdin)
|
||||
(ref-either-right (get-stdin-echo))
|
||||
(Exception
|
||||
@ -174,7 +199,8 @@
|
||||
"getEcho only supported on stdin"
|
||||
ref-unit-unit)))
|
||||
|
||||
(define-unison (setEcho.impl.v1 handle echo)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.setEcho.impl.v1 handle echo)
|
||||
(if (eq? handle stdin)
|
||||
(begin
|
||||
(if echo
|
||||
@ -190,12 +216,14 @@
|
||||
(let ([current (with-output-to-string (lambda () (system "stty -a")))])
|
||||
(string-contains? current " echo ")))
|
||||
|
||||
(define-unison (getArgs.impl.v1 unit)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getArgs.impl.v1 unit)
|
||||
(ref-either-right
|
||||
(vector->chunked-list
|
||||
(vector-map string->chunked-string (current-command-line-arguments)))))
|
||||
|
||||
(define-unison (getEnv.impl.v1 key)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.getEnv.impl.v1 key)
|
||||
(let ([value (environment-variables-ref (current-environment-variables) (string->bytes/utf-8 (chunked-string->string key)))])
|
||||
(if (false? value)
|
||||
(Exception
|
||||
@ -224,7 +252,8 @@
|
||||
s)
|
||||
"''"))
|
||||
|
||||
(define-unison (process.call command arguments)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.process.call command arguments)
|
||||
(system/exit-code
|
||||
(string-join (cons
|
||||
(chunked-string->string command)
|
||||
|
@ -9,7 +9,7 @@
|
||||
date-dst?
|
||||
date-time-zone-offset
|
||||
date*-time-zone-name)
|
||||
(only-in unison/boot data-case define-unison)
|
||||
(only-in unison/boot data-case define-unison-builtin)
|
||||
(only-in
|
||||
rnrs/arithmetic/flonums-6
|
||||
flmod))
|
||||
@ -33,20 +33,29 @@
|
||||
getTempDirectory.impl.v3
|
||||
removeFile.impl.v3
|
||||
getFileSize.impl.v3))
|
||||
(prefix-out
|
||||
builtin-IO.
|
||||
(combine-out
|
||||
fileExists.impl.v3
|
||||
renameFile.impl.v3
|
||||
createDirectory.impl.v3
|
||||
removeDirectory.impl.v3
|
||||
directoryContents.impl.v3
|
||||
setCurrentDirectory.impl.v3
|
||||
renameDirectory.impl.v3
|
||||
isDirectory.impl.v3
|
||||
systemTime.impl.v3
|
||||
systemTimeMicroseconds.impl.v3
|
||||
createTempDirectory.impl.v3)))
|
||||
|
||||
builtin-IO.fileExists.impl.v3
|
||||
builtin-IO.fileExists.impl.v3:termlink
|
||||
builtin-IO.renameFile.impl.v3
|
||||
builtin-IO.renameFile.impl.v3:termlink
|
||||
builtin-IO.createDirectory.impl.v3
|
||||
builtin-IO.createDirectory.impl.v3:termlink
|
||||
builtin-IO.removeDirectory.impl.v3
|
||||
builtin-IO.removeDirectory.impl.v3:termlink
|
||||
builtin-IO.directoryContents.impl.v3
|
||||
builtin-IO.directoryContents.impl.v3:termlink
|
||||
builtin-IO.setCurrentDirectory.impl.v3
|
||||
builtin-IO.setCurrentDirectory.impl.v3:termlink
|
||||
builtin-IO.renameDirectory.impl.v3
|
||||
builtin-IO.renameDirectory.impl.v3:termlink
|
||||
builtin-IO.isDirectory.impl.v3
|
||||
builtin-IO.isDirectory.impl.v3:termlink
|
||||
builtin-IO.systemTime.impl.v3
|
||||
builtin-IO.systemTime.impl.v3:termlink
|
||||
builtin-IO.systemTimeMicroseconds.impl.v3
|
||||
builtin-IO.systemTimeMicroseconds.impl.v3:termlink
|
||||
builtin-IO.createTempDirectory.impl.v3
|
||||
builtin-IO.createTempDirectory.impl.v3:termlink)
|
||||
|
||||
(define (failure-result ty msg vl)
|
||||
(ref-either-left
|
||||
@ -76,7 +85,8 @@
|
||||
(right (file-or-directory-modify-seconds (chunked-string->string path)))))
|
||||
|
||||
; in haskell, it's not just file but also directory
|
||||
(define-unison (fileExists.impl.v3 path)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.fileExists.impl.v3 path)
|
||||
(let ([path-string (chunked-string->string path)])
|
||||
(ref-either-right
|
||||
(or
|
||||
@ -90,11 +100,13 @@
|
||||
(define (getTempDirectory.impl.v3)
|
||||
(right (string->chunked-string (path->string (find-system-path 'temp-dir)))))
|
||||
|
||||
(define-unison (setCurrentDirectory.impl.v3 path)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.setCurrentDirectory.impl.v3 path)
|
||||
(current-directory (chunked-string->string path))
|
||||
(ref-either-right none))
|
||||
|
||||
(define-unison (directoryContents.impl.v3 path)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.directoryContents.impl.v3 path)
|
||||
(with-handlers
|
||||
[[exn:fail:filesystem?
|
||||
(lambda (e)
|
||||
@ -112,7 +124,8 @@
|
||||
(list* "." ".." dirss))))))))
|
||||
|
||||
|
||||
(define-unison (createTempDirectory.impl.v3 prefix)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.createTempDirectory.impl.v3 prefix)
|
||||
(ref-either-right
|
||||
(string->chunked-string
|
||||
(path->string
|
||||
@ -120,35 +133,43 @@
|
||||
(string->bytes/utf-8
|
||||
(chunked-string->string prefix)) #"")))))
|
||||
|
||||
(define-unison (createDirectory.impl.v3 file)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.createDirectory.impl.v3 file)
|
||||
(make-directory (chunked-string->string file))
|
||||
(ref-either-right none))
|
||||
|
||||
(define-unison (removeDirectory.impl.v3 file)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.removeDirectory.impl.v3 file)
|
||||
(delete-directory/files (chunked-string->string file))
|
||||
(ref-either-right none))
|
||||
|
||||
(define-unison (isDirectory.impl.v3 path)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.isDirectory.impl.v3 path)
|
||||
(ref-either-right
|
||||
(directory-exists? (chunked-string->string path))))
|
||||
|
||||
(define-unison (renameDirectory.impl.v3 old new)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.renameDirectory.impl.v3 old new)
|
||||
(rename-file-or-directory (chunked-string->string old)
|
||||
(chunked-string->string new))
|
||||
(ref-either-right none))
|
||||
|
||||
(define-unison (renameFile.impl.v3 old new)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.renameFile.impl.v3 old new)
|
||||
(rename-file-or-directory (chunked-string->string old)
|
||||
(chunked-string->string new))
|
||||
(ref-either-right none))
|
||||
|
||||
(define-unison (systemTime.impl.v3 unit)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.systemTime.impl.v3 unit)
|
||||
(ref-either-right (current-seconds)))
|
||||
|
||||
(define-unison (systemTimeMicroseconds.impl.v3 unit)
|
||||
(define-unison-builtin
|
||||
(builtin-IO.systemTimeMicroseconds.impl.v3 unit)
|
||||
(ref-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
|
||||
|
||||
(define-unison (builtin-Clock.internals.systemTimeZone.v1 secs)
|
||||
(define-unison-builtin
|
||||
(builtin-Clock.internals.systemTimeZone.v1 secs)
|
||||
(let* ([d (seconds->date secs)])
|
||||
(list->unison-tuple
|
||||
(list
|
||||
|
@ -7,24 +7,39 @@
|
||||
clamp-integer
|
||||
clamp-natural
|
||||
data-case
|
||||
define-unison
|
||||
define-unison-builtin
|
||||
nbit63))
|
||||
|
||||
(provide
|
||||
builtin-Float.exp
|
||||
builtin-Float.log
|
||||
builtin-Float.max
|
||||
builtin-Float.min
|
||||
builtin-Float.tan
|
||||
builtin-Float.tanh
|
||||
builtin-Float.logBase
|
||||
builtin-Int.*
|
||||
builtin-Int.pow
|
||||
builtin-Int.trailingZeros
|
||||
builtin-Nat.trailingZeros
|
||||
builtin-Int.popCount
|
||||
builtin-Nat.popCount
|
||||
builtin-Float.pow
|
||||
builtin-Float.exp
|
||||
builtin-Float.exp:termlink
|
||||
builtin-Float.log
|
||||
builtin-Float.log:termlink
|
||||
builtin-Float.max
|
||||
builtin-Float.max:termlink
|
||||
builtin-Float.min
|
||||
builtin-Float.min:termlink
|
||||
builtin-Float.tan
|
||||
builtin-Float.tan:termlink
|
||||
builtin-Float.tanh
|
||||
builtin-Float.tanh:termlink
|
||||
builtin-Float.logBase
|
||||
builtin-Float.logBase:termlink
|
||||
builtin-Int.*
|
||||
builtin-Int.*:termlink
|
||||
builtin-Int.pow
|
||||
builtin-Int.pow:termlink
|
||||
builtin-Int.trailingZeros
|
||||
builtin-Int.trailingZeros:termlink
|
||||
builtin-Nat.trailingZeros
|
||||
builtin-Nat.trailingZeros:termlink
|
||||
builtin-Int.popCount
|
||||
builtin-Int.popCount:termlink
|
||||
builtin-Nat.popCount
|
||||
builtin-Nat.popCount:termlink
|
||||
builtin-Float.pow
|
||||
builtin-Float.pow:termlink
|
||||
|
||||
(prefix-out unison-POp-
|
||||
(combine-out
|
||||
ABSF
|
||||
@ -71,21 +86,50 @@
|
||||
SINF
|
||||
ITOF)))
|
||||
|
||||
(define-unison (builtin-Float.logBase base num) (log num base))
|
||||
(define-unison-builtin
|
||||
(builtin-Float.logBase base num)
|
||||
(log num base))
|
||||
(define (LOGB base num) (log num base))
|
||||
(define-unison (builtin-Float.exp n) (exp n))
|
||||
(define-unison (builtin-Float.log n) (log n))
|
||||
(define-unison (builtin-Float.max n m) (max n m))
|
||||
(define-unison (builtin-Float.min n m) (min n m))
|
||||
(define-unison (builtin-Float.tan n) (tan n))
|
||||
(define-unison (builtin-Float.tanh n) (tanh n))
|
||||
(define-unison (builtin-Int.* n m) (clamp-integer (* n m)))
|
||||
(define-unison (builtin-Int.pow n m) (clamp-integer (expt n m)))
|
||||
(define-unison (builtin-Int.trailingZeros n) (TZRO n))
|
||||
(define-unison (builtin-Nat.trailingZeros n) (TZRO n))
|
||||
(define-unison (builtin-Nat.popCount n) (POPC n))
|
||||
(define-unison (builtin-Int.popCount n) (POPC n))
|
||||
(define-unison (builtin-Float.pow n m) (expt n m))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.exp n) (exp n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.log n) (log n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.max n m) (max n m))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.min n m) (min n m))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.tan n) (tan n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.tanh n) (tanh n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Int.* n m) (clamp-integer (* n m)))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Int.pow n m) (clamp-integer (expt n m)))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Int.trailingZeros n) (TZRO n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.trailingZeros n) (TZRO n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Nat.popCount n) (POPC n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Int.popCount n) (POPC n))
|
||||
|
||||
(define-unison-builtin
|
||||
(builtin-Float.pow n m) (expt n m))
|
||||
|
||||
(define (EXPF n) (exp n))
|
||||
(define ABSF abs)
|
||||
(define ACOS acos)
|
||||
|
@ -31,9 +31,11 @@
|
||||
builtin-sandboxLinks
|
||||
builtin-sandboxLinks:termlink
|
||||
|
||||
builtin-Code.dependencies:termlink
|
||||
builtin-Code.deserialize:termlink
|
||||
builtin-Code.serialize:termlink
|
||||
builtin-Code.validateLinks:termlink
|
||||
builtin-Value.dependencies:termlink
|
||||
builtin-Value.deserialize:termlink
|
||||
builtin-Value.serialize:termlink
|
||||
builtin-crypto.hash:termlink
|
||||
@ -54,21 +56,15 @@
|
||||
build-runtime-module
|
||||
termlink->proc)
|
||||
|
||||
(define-builtin-link Value.value)
|
||||
(define-builtin-link Value.reflect)
|
||||
(define-builtin-link Code.isMissing)
|
||||
(define-builtin-link Code.lookup)
|
||||
|
||||
(define-builtin-link Code.dependencies)
|
||||
(define-builtin-link Code.deserialize)
|
||||
(define-builtin-link Code.serialize)
|
||||
(define-builtin-link Code.validateLinks)
|
||||
(define-builtin-link Value.dependencies)
|
||||
(define-builtin-link Value.deserialize)
|
||||
(define-builtin-link Value.serialize)
|
||||
(define-builtin-link crypto.hash)
|
||||
(define-builtin-link crypto.hmac)
|
||||
(define-builtin-link validateSandboxed)
|
||||
(define-builtin-link Value.validateSandboxed)
|
||||
(define-builtin-link sandboxLinks)
|
||||
|
||||
(define (chunked-list->list cl)
|
||||
(vector->list (chunked-list->vector cl)))
|
||||
@ -129,14 +125,33 @@
|
||||
(raise
|
||||
(format "decode-binding: unimplemented case: ~a" bn))]))
|
||||
|
||||
(define (decode-hints hs)
|
||||
(define (hint->sym t)
|
||||
(cond
|
||||
[(= t ref-defnhint-internal:tag) 'internal]
|
||||
[(= t ref-defnhint-genlink:tag) 'gen-link]
|
||||
[(= t ref-defnhint-nolinkdecl:tag) 'no-link-decl]))
|
||||
|
||||
(for/fold ([def 'define-unison] [out '()]) ([h hs])
|
||||
(match h
|
||||
[(unison-data _ t (list))
|
||||
#:when (= t ref-defnhint-builtin:tag)
|
||||
(values 'define-unison-builtin out)]
|
||||
[(unison-data _ t (list))
|
||||
(values def (cons (hint->sym t) out))])))
|
||||
|
||||
(define (decode-syntax dfn)
|
||||
(match dfn
|
||||
[(unison-data _ t (list nm vs bd))
|
||||
[(unison-data _ t (list nm hs vs bd))
|
||||
#:when (= t ref-schemedefn-define:tag)
|
||||
(let ([head (map text->ident
|
||||
(cons nm (chunked-list->list vs)))]
|
||||
[body (decode-term bd)])
|
||||
(list 'define-unison head body))]
|
||||
(let-values
|
||||
([(head) (map text->ident
|
||||
(cons nm (chunked-list->list vs)))]
|
||||
[(def hints) (decode-hints (chunked-list->list hs))]
|
||||
[(body) (decode-term bd)])
|
||||
(if (null? hints)
|
||||
(list def head body)
|
||||
(list def '#:hints hints head body)))]
|
||||
[(unison-data _ t (list nm bd))
|
||||
#:when (= t ref-schemedefn-alias:tag)
|
||||
(list 'define (text->ident nm) (decode-term bd))]
|
||||
@ -195,20 +210,17 @@
|
||||
(describe-value tl)))]
|
||||
[1 (rf) rf]))
|
||||
|
||||
(define-syntax make-group-ref-decoder
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
#`(lambda (gr)
|
||||
(data-case (group-ref-ident gr)
|
||||
[#,ref-schemeterm-ident:tag (name) name]
|
||||
[else
|
||||
(raise
|
||||
(format
|
||||
"decode-group-ref: unimplemented data case: ~a"
|
||||
(describe-value gr)))]))])))
|
||||
(define (decode-group-ref gr0)
|
||||
(match (group-ref-ident gr0)
|
||||
[(unison-data _ t (list name))
|
||||
#:when (= t ref-schemeterm-ident:tag)
|
||||
name]
|
||||
[else
|
||||
(raise
|
||||
(format
|
||||
"decode-group-ref: unimplemented data case: ~a"
|
||||
(describe-value gr0)))]))
|
||||
|
||||
(define decode-group-ref (make-group-ref-decoder))
|
||||
(define (group-ref-sym gr)
|
||||
(string->symbol
|
||||
(chunked-string->string
|
||||
@ -301,6 +313,70 @@
|
||||
[else
|
||||
(raise (format "decode-vlit: unimplemented case: !a" vl))])]))
|
||||
|
||||
(define (reify-handlers hs)
|
||||
(for/list ([h (chunked-list->list hs)])
|
||||
(match (unison-pair->cons h)
|
||||
[(cons r h)
|
||||
(cons (reference->typelink r)
|
||||
(reify-value h))])))
|
||||
|
||||
(define (reflect-handlers hs)
|
||||
(list->chunked-list
|
||||
(for/list ([h hs])
|
||||
(match h
|
||||
[(cons r h)
|
||||
(unison-tuple
|
||||
(typelink->reference r)
|
||||
(reflect-value h))]))))
|
||||
|
||||
(define (reify-groupref gr0)
|
||||
(match gr0
|
||||
[(unison-data _ t (list r i))
|
||||
#:when (= t ref-groupref-group:tag)
|
||||
(cons (reference->typelink r) i)]))
|
||||
|
||||
(define (reflect-groupref rt)
|
||||
(match rt
|
||||
[(cons l i)
|
||||
(ref-groupref-group (typelink->reference l) i)]))
|
||||
|
||||
(define (parse-continuation orig k0 vs0)
|
||||
(let rec ([k k0] [vs vs0] [frames '()])
|
||||
(match k
|
||||
[(unison-data _ t (list))
|
||||
#:when (= t ref-cont-empty:tag)
|
||||
(unison-cont-reflected (reverse frames))]
|
||||
[(unison-data _ t (list l a gr0 k))
|
||||
#:when (= t ref-cont-push:tag)
|
||||
(cond
|
||||
[(>= (length vs) (+ l a))
|
||||
(let*-values
|
||||
([(locals int) (split-at vs l)]
|
||||
[(args rest) (split-at int a)]
|
||||
[(gr) (reify-groupref gr0)]
|
||||
[(fm) (unison-frame-push locals args gr)])
|
||||
(rec k rest (cons fm frames)))]
|
||||
[else
|
||||
(raise
|
||||
(make-exn:bug
|
||||
"reify-value: malformed continuation"
|
||||
orig))])]
|
||||
[(unison-data _ t (list a rs0 de0 k))
|
||||
#:when (= t ref-cont-mark:tag)
|
||||
(cond
|
||||
[(>= (length vs) a)
|
||||
(let*-values
|
||||
([(args rest) (split-at vs a)]
|
||||
[(rs) (map reference->termlink (chunked-list->list rs0))]
|
||||
[(hs) (reify-handlers de0)]
|
||||
[(fm) (unison-frame-mark args rs hs)])
|
||||
(rec k rest (cons fm frames)))]
|
||||
[else
|
||||
(raise
|
||||
(make-exn:bug
|
||||
"reify-value: malformed continuation"
|
||||
orig))])])))
|
||||
|
||||
(define (reify-value v)
|
||||
(match v
|
||||
[(unison-data _ t (list rf rt bs0))
|
||||
@ -327,16 +403,14 @@
|
||||
#:when (= t ref-value-partial:tag)
|
||||
(let ([bs (map reify-value (chunked-list->list bs0))]
|
||||
[proc (resolve-proc gr)])
|
||||
(apply proc bs))]
|
||||
(struct-copy unison-closure proc [env bs]))]
|
||||
[(unison-data _ t (list vl))
|
||||
#:when (= t ref-value-vlit:tag)
|
||||
(reify-vlit vl)]
|
||||
[(unison-data _ t (list bs0 k))
|
||||
[(unison-data _ t (list vs0 k))
|
||||
#:when (= t ref-value-cont:tag)
|
||||
(raise
|
||||
(make-exn:bug
|
||||
"reify-value: unimplemented cont case"
|
||||
ref-unit-unit))]
|
||||
(parse-continuation v k
|
||||
(map reify-value (chunked-list->list vs0)))]
|
||||
[(unison-data r t fs)
|
||||
(raise
|
||||
(make-exn:bug
|
||||
@ -413,14 +487,34 @@
|
||||
(ref-value-vlit (ref-vlit-typelink (reflect-typelink v)))]
|
||||
[(unison-code sg) (ref-value-vlit (ref-vlit-code sg))]
|
||||
[(unison-quote q) (ref-value-vlit (ref-vlit-quote q))]
|
||||
[(unison-closure f as)
|
||||
[(unison-cont-reflected frames0)
|
||||
(for/foldr ([k ref-cont-empty]
|
||||
[vs '()]
|
||||
#:result
|
||||
(ref-value-cont
|
||||
(list->chunked-list (map reflect-value vs))
|
||||
k))
|
||||
([frame frames0])
|
||||
(match frame
|
||||
[(unison-frame-push locals args return-to)
|
||||
(values
|
||||
(ref-cont-push
|
||||
(length locals)
|
||||
(length args)
|
||||
(reflect-groupref return-to)
|
||||
k)
|
||||
(append locals args vs))]
|
||||
[(unison-frame-mark args refs hs)
|
||||
(values
|
||||
(ref-cont-mark
|
||||
(length args)
|
||||
(map typelink->reference refs)
|
||||
(reflect-handlers hs))
|
||||
(append args vs))]))]
|
||||
[(unison-closure arity f as)
|
||||
(ref-value-partial
|
||||
(function->groupref f)
|
||||
(list->chunked-list (map reflect-value as)))]
|
||||
[(? procedure?)
|
||||
(ref-value-partial
|
||||
(function->groupref v)
|
||||
empty-chunked-list)]
|
||||
[(unison-data rf t fs)
|
||||
(ref-value-data
|
||||
(reflect-typelink rf)
|
||||
@ -438,7 +532,7 @@
|
||||
[(? chunked-list?)
|
||||
(for/fold ([acc '()]) ([e (in-chunked-list v)])
|
||||
(append (sandbox-value ok e) acc))]
|
||||
[(unison-closure f as)
|
||||
[(unison-closure arity f as)
|
||||
(for/fold ([acc (sandbox-proc ok f)]) ([a (in-list as)])
|
||||
(append (sandbox-scheme-value ok a) acc))]
|
||||
[(? procedure?) (sandbox-proc ok v)]
|
||||
@ -474,11 +568,11 @@
|
||||
[(unison-quote v) (sandbox-value ok v)]))
|
||||
|
||||
; replacment for Value.unsafeValue : a -> Value
|
||||
(define-unison
|
||||
(define-unison-builtin
|
||||
(builtin-Value.reflect v)
|
||||
(reflect-value v))
|
||||
|
||||
(define-unison
|
||||
(define-unison-builtin
|
||||
(builtin-Value.value v)
|
||||
(let ([rv (reflect-value v)])
|
||||
(unison-quote rv)))
|
||||
@ -706,23 +800,23 @@
|
||||
|
||||
(define (unison-POp-LKUP tl) (lookup-code tl))
|
||||
|
||||
(define-unison (builtin-Code.lookup tl)
|
||||
(define-unison-builtin (builtin-Code.lookup tl)
|
||||
(match (lookup-code tl)
|
||||
[(unison-sum 0 (list)) ref-optional-none]
|
||||
[(unison-sum 1 (list co)) (ref-optional-some co)]))
|
||||
|
||||
(define-unison (builtin-validateSandboxed ok v)
|
||||
(define-unison-builtin (builtin-validateSandboxed ok v)
|
||||
(let ([l (sandbox-scheme-value (chunked-list->list ok) v)])
|
||||
(null? l)))
|
||||
|
||||
(define-unison (builtin-sandboxLinks tl) (check-sandbox tl))
|
||||
(define-unison-builtin (builtin-sandboxLinks tl) (check-sandbox tl))
|
||||
|
||||
(define-unison (builtin-Code.isMissing tl)
|
||||
(define-unison-builtin (builtin-Code.isMissing tl)
|
||||
(cond
|
||||
[(unison-termlink-builtin? tl) #f]
|
||||
[(unison-termlink-con? tl) #f]
|
||||
[(have-code? tl) #t]
|
||||
[else #f]))
|
||||
|
||||
(define-unison (builtin-Value.validateSandboxed ok v)
|
||||
(define-unison-builtin (builtin-Value.validateSandboxed ok v)
|
||||
(sandbox-quoted (chunked-list->list ok) v))
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -4,7 +4,7 @@
|
||||
(provide expand-sandbox check-sandbox set-sandbox)
|
||||
|
||||
(require racket racket/hash)
|
||||
(require (except-in unison/data true false unit))
|
||||
(require unison/data)
|
||||
|
||||
; sandboxing information
|
||||
(define sandbox-links (make-hash))
|
||||
|
@ -2,7 +2,7 @@
|
||||
#lang racket/base
|
||||
(require racket/udp
|
||||
racket/format
|
||||
(only-in unison/boot define-unison)
|
||||
(only-in unison/boot define-unison-builtin)
|
||||
unison/data
|
||||
unison/data-info
|
||||
unison/chunked-seq
|
||||
@ -11,32 +11,29 @@
|
||||
unison/core)
|
||||
|
||||
(provide
|
||||
(prefix-out
|
||||
builtin-IO.UDP.
|
||||
(combine-out
|
||||
clientSocket.impl.v1
|
||||
clientSocket.impl.v1:termlink
|
||||
UDPSocket.recv.impl.v1
|
||||
UDPSocket.recv.impl.v1:termlink
|
||||
UDPSocket.send.impl.v1
|
||||
UDPSocket.send.impl.v1:termlink
|
||||
UDPSocket.close.impl.v1
|
||||
UDPSocket.close.impl.v1:termlink
|
||||
ListenSocket.close.impl.v1
|
||||
ListenSocket.close.impl.v1:termlink
|
||||
UDPSocket.toText.impl.v1
|
||||
UDPSocket.toText.impl.v1:termlink
|
||||
serverSocket.impl.v1
|
||||
serverSocket.impl.v1:termlink
|
||||
ListenSocket.toText.impl.v1
|
||||
ListenSocket.toText.impl.v1:termlink
|
||||
ListenSocket.recvFrom.impl.v1
|
||||
ListenSocket.recvFrom.impl.v1:termlink
|
||||
ClientSockAddr.toText.v1
|
||||
ClientSockAddr.toText.v1:termlink
|
||||
ListenSocket.sendTo.impl.v1
|
||||
ListenSocket.sendTo.impl.v1:termlink)))
|
||||
|
||||
builtin-IO.UDP.clientSocket.impl.v1
|
||||
builtin-IO.UDP.clientSocket.impl.v1:termlink
|
||||
builtin-IO.UDP.UDPSocket.recv.impl.v1
|
||||
builtin-IO.UDP.UDPSocket.recv.impl.v1:termlink
|
||||
builtin-IO.UDP.UDPSocket.send.impl.v1
|
||||
builtin-IO.UDP.UDPSocket.send.impl.v1:termlink
|
||||
builtin-IO.UDP.UDPSocket.close.impl.v1
|
||||
builtin-IO.UDP.UDPSocket.close.impl.v1:termlink
|
||||
builtin-IO.UDP.ListenSocket.close.impl.v1
|
||||
builtin-IO.UDP.ListenSocket.close.impl.v1:termlink
|
||||
builtin-IO.UDP.UDPSocket.toText.impl.v1
|
||||
builtin-IO.UDP.UDPSocket.toText.impl.v1:termlink
|
||||
builtin-IO.UDP.serverSocket.impl.v1
|
||||
builtin-IO.UDP.serverSocket.impl.v1:termlink
|
||||
builtin-IO.UDP.ListenSocket.toText.impl.v1
|
||||
builtin-IO.UDP.ListenSocket.toText.impl.v1:termlink
|
||||
builtin-IO.UDP.ListenSocket.recvFrom.impl.v1
|
||||
builtin-IO.UDP.ListenSocket.recvFrom.impl.v1:termlink
|
||||
builtin-IO.UDP.ClientSockAddr.toText.v1
|
||||
builtin-IO.UDP.ClientSockAddr.toText.v1:termlink
|
||||
builtin-IO.UDP.ListenSocket.sendTo.impl.v1
|
||||
builtin-IO.UDP.ListenSocket.sendTo.impl.v1:termlink)
|
||||
|
||||
|
||||
(struct client-sock-addr (host port))
|
||||
|
||||
@ -48,10 +45,10 @@
|
||||
(sum-case a
|
||||
(0 (type msg meta)
|
||||
(ref-either-left (ref-failure-failure type msg (unison-any-any meta))))
|
||||
(1 (data)
|
||||
(1 (data)
|
||||
(ref-either-right data))))
|
||||
|
||||
(define
|
||||
(define
|
||||
(format-socket socket)
|
||||
(let*-values ([(local-hn local-port remote-hn remote-port) (udp-addresses socket #t)]
|
||||
[(rv) (~a "<socket local=" local-hn ":" local-port " remote=" remote-hn ":" remote-port ">")])
|
||||
@ -64,7 +61,7 @@
|
||||
(wrap-in-either rv)))
|
||||
|
||||
;; define termlink builtins
|
||||
(define clientSocket.impl.v1:termlink
|
||||
(define clientSocket.impl.v1:termlink
|
||||
(unison-termlink-builtin "IO.UDP.clientSocket.impl.v1"))
|
||||
(define UDPSocket.recv.impl.v1:termlink
|
||||
(unison-termlink-builtin "IO.UDP.UDPSocket.recv.impl.v1"))
|
||||
@ -72,7 +69,7 @@
|
||||
(unison-termlink-builtin "IO.UDP.UDPSocket.send.impl.v1"))
|
||||
(define UDPSocket.close.impl.v1:termlink
|
||||
(unison-termlink-builtin "IO.UDP.UDPSocket.close.impl.v1"))
|
||||
(define ListenSocket.close.impl.v1:termlink
|
||||
(define ListenSocket.close.impl.v1:termlink
|
||||
(unison-termlink-builtin "IO.UDP.ListenSocket.close.impl.v1"))
|
||||
(define UDPSocket.toText.impl.v1:termlink
|
||||
(unison-termlink-builtin "IO.UDP.UDPSocket.toText.impl.v1"))
|
||||
@ -89,22 +86,25 @@
|
||||
|
||||
;; define builtins
|
||||
|
||||
(define-unison
|
||||
(UDPSocket.recv.impl.v1 socket) ; socket -> Either Failure Bytes
|
||||
(let
|
||||
([rv (handle-errors (lambda()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.UDPSocket.recv.impl.v1 socket)
|
||||
; socket -> Either Failure Bytes
|
||||
(let
|
||||
([rv (handle-errors (lambda()
|
||||
(let*-values
|
||||
([(buffer) (make-bytes buffer-size)]
|
||||
[(len a b) (udp-receive! socket buffer)])
|
||||
(right (bytes->chunked-bytes (subbytes buffer 0 len))))))])
|
||||
(wrap-in-either rv)))
|
||||
|
||||
(define-unison
|
||||
(ListenSocket.close.impl.v1 socket) ; socket -> Either Failure ()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.ListenSocket.close.impl.v1 socket)
|
||||
; socket -> Either Failure ()
|
||||
(close-socket socket))
|
||||
|
||||
(define-unison
|
||||
(serverSocket.impl.v1 ip port) ; string string -> Either Failure socket
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.serverSocket.impl.v1 ip port)
|
||||
; string string -> Either Failure socket
|
||||
(let
|
||||
([result (handle-errors (lambda()
|
||||
(let* ([iip (chunked-string->string ip)]
|
||||
@ -115,12 +115,13 @@
|
||||
(right sock)))))])
|
||||
(wrap-in-either result)))
|
||||
|
||||
(define-unison
|
||||
(ListenSocket.recvFrom.impl.v1 socket) ; socket -> Either Failure (Bytes, ClientSockAddr)
|
||||
(let ([result (handle-errors (lambda()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.ListenSocket.recvFrom.impl.v1 socket)
|
||||
; socket -> Either Failure (Bytes, ClientSockAddr)
|
||||
(let ([result (handle-errors (lambda()
|
||||
(if (not (udp? socket))
|
||||
(raise-argument-error 'socket "a UDP socket" socket)
|
||||
(let*-values
|
||||
(let*-values
|
||||
([(buffer) (make-bytes buffer-size)]
|
||||
[(len host port) (udp-receive! socket buffer)]
|
||||
[(csa) (client-sock-addr host port)]
|
||||
@ -129,18 +130,20 @@
|
||||
(right (ref-tuple-pair chunked (ref-tuple-pair csa ref-unit-unit)))))))])
|
||||
(wrap-in-either result)))
|
||||
|
||||
(define-unison
|
||||
(UDPSocket.send.impl.v1 socket data) ; socket -> Bytes -> Either Failure ()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.UDPSocket.send.impl.v1 socket data)
|
||||
; socket -> Bytes -> Either Failure ()
|
||||
(let
|
||||
([result (handle-errors (lambda () (begin
|
||||
(udp-send socket (chunked-bytes->bytes data))
|
||||
(udp-send socket (chunked-bytes->bytes data))
|
||||
(right ref-unit-unit))))])
|
||||
(wrap-in-either result)))
|
||||
|
||||
(define-unison
|
||||
(ListenSocket.sendTo.impl.v1 sock bytes addr) ; socket -> Bytes -> ClientSockAddr -> Either Failure ()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.ListenSocket.sendTo.impl.v1 sock bytes addr)
|
||||
; socket -> Bytes -> ClientSockAddr -> Either Failure ()
|
||||
(let
|
||||
([result (handle-errors (lambda()
|
||||
([result (handle-errors (lambda()
|
||||
(let* ([host (client-sock-addr-host addr)]
|
||||
[port (client-sock-addr-port addr)]
|
||||
[bytes (chunked-bytes->bytes bytes)])
|
||||
@ -149,28 +152,32 @@
|
||||
(right ref-unit-unit)))))])
|
||||
(wrap-in-either result)))
|
||||
|
||||
(define-unison
|
||||
(UDPSocket.toText.impl.v1 socket) ; socket -> string
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.UDPSocket.toText.impl.v1 socket) ; socket -> string
|
||||
(format-socket socket))
|
||||
|
||||
(define-unison
|
||||
(ClientSockAddr.toText.v1 addr) ; ClientSocketAddr -> string
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.ClientSockAddr.toText.v1 addr)
|
||||
; ClientSocketAddr -> string
|
||||
(string->chunked-string (format "<client-sock-addr ~a ~a>" (client-sock-addr-host addr) (client-sock-addr-port addr))))
|
||||
|
||||
(define-unison
|
||||
(ListenSocket.toText.impl.v1 socket) ; socket -> string
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.ListenSocket.toText.impl.v1 socket)
|
||||
; socket -> string
|
||||
(format-socket socket))
|
||||
|
||||
(define-unison
|
||||
(UDPSocket.close.impl.v1 socket) ; socket -> Either Failure ()
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.UDPSocket.close.impl.v1 socket)
|
||||
; socket -> Either Failure ()
|
||||
(let
|
||||
([rv (handle-errors (lambda() (begin
|
||||
(udp-close socket)
|
||||
(right ref-unit-unit))))])
|
||||
(wrap-in-either rv)))
|
||||
|
||||
(define-unison
|
||||
(clientSocket.impl.v1 host port) ; string string -> Either Failure socket
|
||||
(define-unison-builtin
|
||||
(builtin-IO.UDP.clientSocket.impl.v1 host port)
|
||||
; string string -> Either Failure socket
|
||||
(let ([rv (handle-errors (lambda() (let* ([pport (string->number (chunked-string->string port))]
|
||||
[hhost (chunked-string->string host)]
|
||||
[sock (udp-open-socket hhost pport)]
|
||||
|
@ -29,7 +29,6 @@ packages:
|
||||
- lib/unison-util-bytes
|
||||
- lib/unison-util-cache
|
||||
- lib/unison-util-file-embed
|
||||
- lib/unison-util-nametree
|
||||
- lib/unison-util-relation
|
||||
- lib/unison-util-rope
|
||||
- parser-typechecker
|
||||
@ -63,9 +62,14 @@ extra-deps:
|
||||
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484
|
||||
- monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605
|
||||
- recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672
|
||||
- numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
|
||||
- row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
|
||||
- network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075
|
||||
|
||||
allow-newer: true
|
||||
allow-newer-deps:
|
||||
- numerals
|
||||
|
||||
ghc-options:
|
||||
# All packages
|
||||
"$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors
|
||||
|
@ -61,6 +61,13 @@ packages:
|
||||
size: 2489
|
||||
original:
|
||||
hackage: recover-rtti-0.4.3@sha256:01adcbab70a6542914df28ac120a23a923d8566236f2c0295998e9419f53dd62,4672
|
||||
- completed:
|
||||
hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
|
||||
pantry-tree:
|
||||
sha256: c616791b08f1792fd1d4ca03c6d2c773dedb25b24b66454c97864aefd85a5d0a
|
||||
size: 13751
|
||||
original:
|
||||
hackage: numerals-0.4.1@sha256:f138b4a0efbde3b3c6cbccb788eff683cb8a5d046f449729712fd174c5ee8a78,11430
|
||||
- completed:
|
||||
hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
|
||||
pantry-tree:
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -1,7 +1,7 @@
|
||||
# Integration test: transcript
|
||||
|
||||
```unison
|
||||
use .builtin
|
||||
``` unison
|
||||
use lib.builtins
|
||||
|
||||
unique type MyBool = MyTrue | MyFalse
|
||||
|
||||
@ -27,7 +27,7 @@ main = do
|
||||
_ -> ()
|
||||
```
|
||||
|
||||
```ucm
|
||||
``` ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
@ -43,8 +43,8 @@ main = do
|
||||
resume : Request {g, Break} x -> x
|
||||
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
``` ucm
|
||||
scratch/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
@ -53,6 +53,6 @@ main = do
|
||||
main : '{IO, Exception} ()
|
||||
resume : Request {g, Break} x -> x
|
||||
|
||||
.> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
|
||||
scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
|
||||
|
||||
```
|
||||
|
@ -19,6 +19,7 @@ dependencies:
|
||||
- base
|
||||
- bytes
|
||||
- bytestring
|
||||
- cmark
|
||||
- co-log-core
|
||||
- code-page
|
||||
- concurrent-output
|
||||
@ -54,6 +55,7 @@ dependencies:
|
||||
- network-udp
|
||||
- network-uri
|
||||
- nonempty-containers
|
||||
- numerals
|
||||
- open-browser
|
||||
- optparse-applicative >= 0.16.1.0
|
||||
- pretty-simple
|
||||
@ -93,7 +95,6 @@ dependencies:
|
||||
- unison-sqlite
|
||||
- unison-syntax
|
||||
- unison-util-base32hex
|
||||
- unison-util-nametree
|
||||
- unison-util-relation
|
||||
- unliftio
|
||||
- unordered-containers
|
||||
|
@ -52,14 +52,19 @@ import Options.Applicative.Help (bold, (<+>))
|
||||
import Options.Applicative.Help.Pretty qualified as P
|
||||
import Stats
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathNames)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import Unison.Core.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import Unison.LSP (LspFormattingConfig (..))
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyTerminal qualified as PT
|
||||
import Unison.Project qualified as Project
|
||||
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Syntax.HashQualified qualified as HQ
|
||||
@ -68,7 +73,7 @@ import Unison.Util.Pretty (Width (..))
|
||||
-- | Valid ways to provide source code to the run command
|
||||
data RunSource
|
||||
= RunFromPipe (HashQualified Name)
|
||||
| RunFromSymbol (HashQualified Name)
|
||||
| RunFromSymbol ProjectPathNames
|
||||
| RunFromFile FilePath (HashQualified Name)
|
||||
| RunCompiled FilePath
|
||||
deriving (Show, Eq)
|
||||
@ -102,8 +107,8 @@ data Command
|
||||
= Launch
|
||||
IsHeadless
|
||||
CodebaseServerOpts
|
||||
-- Starting path
|
||||
(Maybe Path.Absolute)
|
||||
-- Starting project
|
||||
(Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
ShouldWatchFiles
|
||||
| PrintVersion
|
||||
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
|
||||
@ -357,9 +362,9 @@ launchParser :: CodebaseServerOpts -> IsHeadless -> Parser Command
|
||||
launchParser envOpts isHeadless = do
|
||||
-- ApplicativeDo
|
||||
codebaseServerOpts <- codebaseServerOptsParser envOpts
|
||||
startingPath <- startingPathOption
|
||||
startingProject <- startingProjectOption
|
||||
shouldWatchFiles <- noFileWatchFlag
|
||||
pure (Launch isHeadless codebaseServerOpts startingPath shouldWatchFiles)
|
||||
pure (Launch isHeadless codebaseServerOpts startingProject shouldWatchFiles)
|
||||
|
||||
initParser :: Parser Command
|
||||
initParser = pure Init
|
||||
@ -374,9 +379,13 @@ runHQParser :: Parser (HashQualified Name)
|
||||
runHQParser =
|
||||
argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL")
|
||||
|
||||
runProjectPathParser :: Parser PP.ProjectPathNames
|
||||
runProjectPathParser =
|
||||
argument (maybeReader (eitherToMaybe . PP.parseProjectPath . Text.pack)) (metavar "@myproject/mybranch:.path.in.project")
|
||||
|
||||
runSymbolParser :: Parser Command
|
||||
runSymbolParser =
|
||||
Run . RunFromSymbol <$> runHQParser <*> runArgumentParser
|
||||
Run . RunFromSymbol <$> runProjectPathParser <*> runArgumentParser
|
||||
|
||||
runFileParser :: Parser Command
|
||||
runFileParser =
|
||||
@ -422,15 +431,15 @@ saveCodebaseToFlag = do
|
||||
_ -> DontSaveCodebase
|
||||
)
|
||||
|
||||
startingPathOption :: Parser (Maybe Path.Absolute)
|
||||
startingPathOption =
|
||||
startingProjectOption :: Parser (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
|
||||
startingProjectOption =
|
||||
let meta =
|
||||
metavar ".path.in.codebase"
|
||||
<> long "path"
|
||||
metavar "project/branch"
|
||||
<> long "project"
|
||||
<> short 'p'
|
||||
<> help "Launch the UCM session at the provided path location."
|
||||
<> help "Launch the UCM session at the provided project and branch."
|
||||
<> noGlobal
|
||||
in optional $ option readAbsolutePath meta
|
||||
in optional (option readProjectAndBranchNames meta)
|
||||
|
||||
noFileWatchFlag :: Parser ShouldWatchFiles
|
||||
noFileWatchFlag =
|
||||
@ -469,6 +478,13 @@ readPath' = do
|
||||
Left err -> OptParse.readerError (Text.unpack err)
|
||||
Right path' -> pure path'
|
||||
|
||||
readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName)
|
||||
readProjectAndBranchNames = do
|
||||
str <- OptParse.str
|
||||
case Megaparsec.parse Project.fullyQualifiedProjectAndBranchNamesParser "arg" str of
|
||||
Left errBundle -> OptParse.readerError $ Megaparsec.errorBundlePretty errBundle
|
||||
Right projectAndBranch -> pure projectAndBranch
|
||||
|
||||
fileArgument :: String -> Parser FilePath
|
||||
fileArgument varName =
|
||||
strArgument
|
||||
|
@ -14,6 +14,7 @@ module Unison.Cli.Monad
|
||||
-- * Immutable state
|
||||
LoopState (..),
|
||||
loopState0,
|
||||
getProjectPathIds,
|
||||
|
||||
-- * Lifting IO actions
|
||||
ioE,
|
||||
@ -33,6 +34,7 @@ module Unison.Cli.Monad
|
||||
-- * Changing the current directory
|
||||
cd,
|
||||
popd,
|
||||
switchProject,
|
||||
|
||||
-- * Communicating output to the user
|
||||
respond,
|
||||
@ -46,38 +48,42 @@ module Unison.Cli.Monad
|
||||
runTransaction,
|
||||
runTransactionWithRollback,
|
||||
|
||||
-- * Internal
|
||||
setMostRecentProjectPath,
|
||||
|
||||
-- * Misc types
|
||||
LoadSourceResult (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Lens (lens, (.=))
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader (MonadReader (..))
|
||||
import Control.Monad.State.Strict (MonadState)
|
||||
import Control.Monad.State.Strict qualified as State
|
||||
import Data.Configurator.Types qualified as Configurator
|
||||
import Data.List.NonEmpty qualified as List (NonEmpty)
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
|
||||
import Data.Time.Clock.System (getSystemTime, systemToTAITime)
|
||||
import Data.Time.Clock.TAI (diffAbsoluteTime)
|
||||
import Data.Unique (Unique, newUnique)
|
||||
import GHC.OverloadedLabels (IsLabel (..))
|
||||
import System.CPUTime (getCPUTime)
|
||||
import Text.Printf (printf)
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Auth.CredentialManager (CredentialManager)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Editor.Input (Input)
|
||||
import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
|
||||
import Unison.Codebase.Editor.UCMVersion (UCMVersion)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.Core.Project (ProjectAndBranch (..))
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
@ -88,7 +94,6 @@ import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import UnliftIO.STM
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
-- | The main command-line app monad.
|
||||
@ -170,7 +175,10 @@ data Env = Env
|
||||
sandboxedRuntime :: Runtime Symbol,
|
||||
nativeRuntime :: Runtime Symbol,
|
||||
serverBaseUrl :: Maybe Server.BaseUrl,
|
||||
ucmVersion :: UCMVersion
|
||||
ucmVersion :: UCMVersion,
|
||||
-- | Whether we're running in a transcript test or not.
|
||||
-- Avoid using this except when absolutely necessary.
|
||||
isTranscriptTest :: Bool
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
@ -178,10 +186,8 @@ data Env = Env
|
||||
--
|
||||
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
|
||||
data LoopState = LoopState
|
||||
{ root :: TMVar (Branch IO),
|
||||
lastSavedRootHash :: CausalHash,
|
||||
-- the current position in the namespace
|
||||
currentPathStack :: List.NonEmpty Path.Absolute,
|
||||
{ -- the current position in the codebase, with the head being the most recent lcoation.
|
||||
projectPathStack :: List.NonEmpty PP.ProjectPathIds,
|
||||
-- TBD
|
||||
-- , _activeEdits :: Set Branch.EditGuid
|
||||
|
||||
@ -206,26 +212,11 @@ data LoopState = LoopState
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance
|
||||
{-# OVERLAPS #-}
|
||||
(Functor f) =>
|
||||
IsLabel "currentPath" ((Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState))
|
||||
where
|
||||
fromLabel :: (Path.Absolute -> f Path.Absolute) -> (LoopState -> f LoopState)
|
||||
fromLabel =
|
||||
lens
|
||||
(\LoopState {currentPathStack} -> List.NonEmpty.head currentPathStack)
|
||||
( \loopState@LoopState {currentPathStack = _ List.NonEmpty.:| paths} path ->
|
||||
loopState {currentPathStack = path List.NonEmpty.:| paths}
|
||||
)
|
||||
|
||||
-- | Create an initial loop state given a root branch and the current path.
|
||||
loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
|
||||
loopState0 lastSavedRootHash b p = do
|
||||
loopState0 :: PP.ProjectPathIds -> LoopState
|
||||
loopState0 p = do
|
||||
LoopState
|
||||
{ root = b,
|
||||
lastSavedRootHash = lastSavedRootHash,
|
||||
currentPathStack = pure p,
|
||||
{ projectPathStack = pure p,
|
||||
latestFile = Nothing,
|
||||
latestTypecheckedFile = Nothing,
|
||||
lastInput = Nothing,
|
||||
@ -387,11 +378,25 @@ time label action =
|
||||
ms = ns / 1_000_000
|
||||
s = ns / 1_000_000_000
|
||||
|
||||
getProjectPathIds :: Cli PP.ProjectPathIds
|
||||
getProjectPathIds = do
|
||||
NonEmpty.head <$> use #projectPathStack
|
||||
|
||||
cd :: Path.Absolute -> Cli ()
|
||||
cd path = do
|
||||
setMostRecentNamespace path
|
||||
State.modify' \state ->
|
||||
state {currentPathStack = List.NonEmpty.cons path (currentPathStack state)}
|
||||
pp <- getProjectPathIds
|
||||
let newPP = pp & PP.absPath_ .~ path
|
||||
setMostRecentProjectPath newPP
|
||||
#projectPathStack %= NonEmpty.cons newPP
|
||||
|
||||
switchProject :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
|
||||
switchProject pab@(ProjectAndBranch projectId branchId) = do
|
||||
Env {codebase} <- ask
|
||||
let newPP = PP.ProjectPath projectId branchId Path.absoluteEmpty
|
||||
#projectPathStack %= NonEmpty.cons newPP
|
||||
runTransaction $ do Q.setMostRecentBranch projectId branchId
|
||||
setMostRecentProjectPath newPP
|
||||
liftIO $ Codebase.preloadProjectBranch codebase pab
|
||||
|
||||
-- | Pop the latest path off the stack, if it's not the only path in the stack.
|
||||
--
|
||||
@ -399,16 +404,16 @@ cd path = do
|
||||
popd :: Cli Bool
|
||||
popd = do
|
||||
state <- State.get
|
||||
case List.NonEmpty.uncons (currentPathStack state) of
|
||||
case List.NonEmpty.uncons (projectPathStack state) of
|
||||
(_, Nothing) -> pure False
|
||||
(_, Just paths) -> do
|
||||
setMostRecentNamespace (List.NonEmpty.head paths)
|
||||
State.put state {currentPathStack = paths}
|
||||
setMostRecentProjectPath (List.NonEmpty.head paths)
|
||||
State.put state {projectPathStack = paths}
|
||||
pure True
|
||||
|
||||
setMostRecentNamespace :: Path.Absolute -> Cli ()
|
||||
setMostRecentNamespace =
|
||||
runTransaction . Queries.setMostRecentNamespace . Path.toList . Path.unabsolute
|
||||
setMostRecentProjectPath :: PP.ProjectPathIds -> Cli ()
|
||||
setMostRecentProjectPath loc =
|
||||
runTransaction $ Codebase.setCurrentProjectPath loc
|
||||
|
||||
respond :: Output -> Cli ()
|
||||
respond output = do
|
||||
|
@ -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)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
@ -1,15 +1,27 @@
|
||||
-- | Utilities that have to do with constructing names objects.
|
||||
module Unison.Cli.NamesUtils
|
||||
( currentNames,
|
||||
currentProjectRootNames,
|
||||
projectBranchNames,
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.MonadUtils (getCurrentBranch0)
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Names (Names)
|
||||
|
||||
-- | Produce a 'Names' object which contains names for the current branch.
|
||||
currentNames :: Cli Names
|
||||
currentNames = do
|
||||
Branch.toNames <$> getCurrentBranch0
|
||||
Branch.toNames <$> Cli.getCurrentBranch0
|
||||
|
||||
currentProjectRootNames :: Cli Names
|
||||
currentProjectRootNames = do
|
||||
Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
|
||||
projectBranchNames :: ProjectBranch -> Cli Names
|
||||
projectBranchNames pb = do
|
||||
Branch.toNames . Branch.head <$> Cli.getProjectBranchRoot pb
|
||||
|
@ -5,7 +5,8 @@
|
||||
module Unison.Cli.Pretty
|
||||
( displayBranchHash,
|
||||
prettyAbsolute,
|
||||
prettyAbsoluteStripProject,
|
||||
prettyProjectPath,
|
||||
prettyBranchRelativePath,
|
||||
prettyBase32Hex#,
|
||||
prettyBase32Hex,
|
||||
prettyBranchId,
|
||||
@ -33,7 +34,6 @@ module Unison.Cli.Pretty
|
||||
prettyRepoInfo,
|
||||
prettySCH,
|
||||
prettySemver,
|
||||
prettyShareLink,
|
||||
prettySharePath,
|
||||
prettyShareURI,
|
||||
prettySlashProjectBranchName,
|
||||
@ -57,12 +57,10 @@ import Control.Monad.Writer (Writer, runWriter)
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
|
||||
import Network.URI (URI)
|
||||
import Network.URI qualified as URI
|
||||
import Network.URI.Encode qualified as URI
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Reference qualified as Reference
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
@ -70,23 +68,20 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Util.Base32Hex (Base32Hex)
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..))
|
||||
import Unison.Cli.ProjectUtils (projectBranchPathPrism)
|
||||
import Unison.Cli.Share.Projects.Types qualified as Share
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadRemoteNamespace (..),
|
||||
ShareUserHandle (..),
|
||||
WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
shareUserHandleToText,
|
||||
)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||
import Unison.Core.Project (ProjectBranchName)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Debug qualified as Debug
|
||||
@ -126,6 +121,7 @@ import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Names qualified as UF
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
@ -150,7 +146,7 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty
|
||||
prettyReadRemoteNamespaceWith printProject =
|
||||
P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject
|
||||
|
||||
prettyWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
||||
prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
|
||||
prettyWriteRemoteNamespace =
|
||||
P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace
|
||||
|
||||
@ -161,14 +157,6 @@ prettyRepoInfo :: Share.RepoInfo -> Pretty
|
||||
prettyRepoInfo (Share.RepoInfo repoInfo) =
|
||||
P.blue (P.text repoInfo)
|
||||
|
||||
prettyShareLink :: WriteShareRemoteNamespace -> Pretty
|
||||
prettyShareLink WriteShareRemoteNamespace {repo, path} =
|
||||
let encodedPath =
|
||||
Path.toList path
|
||||
& fmap (URI.encodeText . NameSegment.toUnescapedText)
|
||||
& Text.intercalate "/"
|
||||
in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath
|
||||
|
||||
prettySharePath :: Share.Path -> Pretty
|
||||
prettySharePath =
|
||||
prettyRelative
|
||||
@ -194,16 +182,17 @@ prettyPath' p' =
|
||||
then "the current namespace"
|
||||
else P.blue (P.shown p')
|
||||
|
||||
prettyNamespaceKey :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
|
||||
prettyNamespaceKey :: Either ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Pretty
|
||||
prettyNamespaceKey = \case
|
||||
Left path -> prettyPath' path
|
||||
Left path -> prettyProjectPath path
|
||||
Right (ProjectAndBranch project branch) ->
|
||||
prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name))
|
||||
|
||||
prettyBranchId :: Input.AbsBranchId -> Pretty
|
||||
prettyBranchId = \case
|
||||
Left sch -> prettySCH sch
|
||||
Right absPath -> prettyAbsolute $ absPath
|
||||
Input.BranchAtSCH sch -> prettySCH sch
|
||||
Input.BranchAtPath absPath -> prettyAbsolute $ absPath
|
||||
Input.BranchAtProjectPath pp -> prettyProjectPath pp
|
||||
|
||||
prettyRelative :: Path.Relative -> Pretty
|
||||
prettyRelative = P.blue . P.shown
|
||||
@ -211,6 +200,13 @@ prettyRelative = P.blue . P.shown
|
||||
prettyAbsolute :: Path.Absolute -> Pretty
|
||||
prettyAbsolute = P.blue . P.shown
|
||||
|
||||
prettyProjectPath :: PP.ProjectPath -> Pretty
|
||||
prettyProjectPath (PP.ProjectPath project branch path) =
|
||||
prettyProjectAndBranchName (ProjectAndBranch project.name branch.name)
|
||||
<>
|
||||
-- Only show the path if it's not the root
|
||||
Monoid.whenM (path /= Path.absoluteEmpty) (P.cyan (":" <> P.shown path))
|
||||
|
||||
prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s
|
||||
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
|
||||
|
||||
@ -271,6 +267,9 @@ prettyProjectAndBranchName :: ProjectAndBranch ProjectName ProjectBranchName ->
|
||||
prettyProjectAndBranchName (ProjectAndBranch project branch) =
|
||||
P.group (prettyProjectName project <> P.hiBlack "/" <> prettyProjectBranchName branch)
|
||||
|
||||
prettyBranchRelativePath :: BranchRelativePath -> Pretty
|
||||
prettyBranchRelativePath = P.blue . P.text . into @Text
|
||||
|
||||
-- produces:
|
||||
-- -- #5v5UtREE1fTiyTsTK2zJ1YNqfiF25SkfUnnji86Lms#0
|
||||
-- Optional.None, Maybe.Nothing : Maybe a
|
||||
@ -343,7 +342,7 @@ prettyTypeName ppe r =
|
||||
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
|
||||
prettyWhichBranchEmpty = \case
|
||||
WhichBranchEmptyHash hash -> P.shown hash
|
||||
WhichBranchEmptyPath path -> prettyPath' path
|
||||
WhichBranchEmptyPath pp -> prettyProjectPath pp
|
||||
|
||||
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
|
||||
displayBranchHash :: CausalHash -> Text
|
||||
@ -389,15 +388,6 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) =
|
||||
<> " on "
|
||||
<> P.shown host
|
||||
|
||||
stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path
|
||||
stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism
|
||||
|
||||
prettyAbsoluteStripProject :: Path.Absolute -> Pretty
|
||||
prettyAbsoluteStripProject path =
|
||||
P.blue case stripProjectBranchInfo path of
|
||||
Just p -> P.shown p
|
||||
Nothing -> P.shown path
|
||||
|
||||
prettyLabeledDependencies :: PPE.PrettyPrintEnv -> Set LabeledDependency -> Pretty
|
||||
prettyLabeledDependencies ppe lds =
|
||||
P.syntaxToColor (P.sep ", " (ld <$> toList lds))
|
||||
|
@ -3,9 +3,11 @@
|
||||
module Unison.Cli.PrettyPrintUtils
|
||||
( prettyPrintEnvDeclFromNames,
|
||||
currentPrettyPrintEnvDecl,
|
||||
projectBranchPPED,
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
@ -14,6 +16,7 @@ import Unison.Names (Names)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo)
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||
|
||||
-- | Builds a pretty print env decl from a names object.
|
||||
@ -30,3 +33,7 @@ prettyPrintEnvDeclFromNames ns =
|
||||
currentPrettyPrintEnvDecl :: Cli PPE.PrettyPrintEnvDecl
|
||||
currentPrettyPrintEnvDecl = do
|
||||
Cli.currentNames >>= prettyPrintEnvDeclFromNames
|
||||
|
||||
projectBranchPPED :: ProjectBranch -> Cli PPED.PrettyPrintEnvDecl
|
||||
projectBranchPPED pb = do
|
||||
Cli.projectBranchNames pb >>= prettyPrintEnvDeclFromNames
|
||||
|
@ -1,21 +1,10 @@
|
||||
-- | Project-related utilities.
|
||||
module Unison.Cli.ProjectUtils
|
||||
( -- * Project/path helpers
|
||||
getCurrentProject,
|
||||
expectCurrentProject,
|
||||
expectCurrentProjectIds,
|
||||
getCurrentProjectIds,
|
||||
getCurrentProjectBranch,
|
||||
getProjectBranchForPath,
|
||||
expectCurrentProjectBranch,
|
||||
expectProjectBranchByName,
|
||||
projectPath,
|
||||
projectBranchesPath,
|
||||
projectBranchPath,
|
||||
projectBranchSegment,
|
||||
projectBranchPathPrism,
|
||||
resolveBranchRelativePath,
|
||||
branchRelativePathToAbsolute,
|
||||
resolveProjectBranch,
|
||||
resolveProjectBranchInProject,
|
||||
|
||||
-- * Name hydration
|
||||
hydrateNames,
|
||||
@ -23,9 +12,8 @@ module Unison.Cli.ProjectUtils
|
||||
-- * Loading local project info
|
||||
expectProjectAndBranchByIds,
|
||||
getProjectAndBranchByTheseNames,
|
||||
expectProjectAndBranchByTheseNames,
|
||||
getProjectAndBranchByNames,
|
||||
expectLooseCodeOrProjectBranch,
|
||||
expectProjectAndBranchByTheseNames,
|
||||
getProjectBranchCausalHash,
|
||||
|
||||
-- * Loading remote project info
|
||||
@ -59,65 +47,43 @@ import Data.Maybe (fromJust)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Causal qualified
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.Share.Projects (IncludeSquashedHead)
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Input (LooseCodeOrProject)
|
||||
import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, ResolvedBranchRelativePath)
|
||||
import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
|
||||
import Unison.Core.Project (ProjectBranchName (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
import Unison.Project.Util
|
||||
import Unison.Sqlite (Transaction)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
|
||||
branchRelativePathToAbsolute brp =
|
||||
resolveBranchRelativePath brp <&> \case
|
||||
BranchRelativePath.ResolvedLoosePath p -> p
|
||||
BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
|
||||
let projectBranchIds = getIds projectBranch
|
||||
handleRel = case mRel of
|
||||
Nothing -> id
|
||||
Just rel -> flip Path.resolve rel
|
||||
in handleRel (projectBranchPath projectBranchIds)
|
||||
where
|
||||
getIds = \case
|
||||
ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
|
||||
|
||||
resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath
|
||||
resolveBranchRelativePath = \case
|
||||
BranchRelativePath.BranchRelative brp -> case brp of
|
||||
This projectBranch -> do
|
||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing)
|
||||
That path -> do
|
||||
(projectBranch, _) <- expectCurrentProjectBranch
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
||||
These projectBranch path -> do
|
||||
projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
|
||||
pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
|
||||
BranchRelativePath.LoosePath path ->
|
||||
BranchRelativePath.ResolvedLoosePath <$> Cli.resolvePath' path
|
||||
where
|
||||
toThese = \case
|
||||
Left branchName -> That branchName
|
||||
Right (projectName, branchName) -> These projectName branchName
|
||||
resolveBranchRelativePath :: BranchRelativePath -> Cli PP.ProjectPath
|
||||
resolveBranchRelativePath brp = do
|
||||
case brp of
|
||||
BranchPathInCurrentProject projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
QualifiedBranchPath projName projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
UnqualifiedPath newPath' -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||
|
||||
justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
|
||||
justTheIds x =
|
||||
@ -152,58 +118,11 @@ findTemporaryBranchName projectId preferred = do
|
||||
|
||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||
|
||||
-- | Get the current project that a user is on.
|
||||
getCurrentProject :: Cli (Maybe Sqlite.Project)
|
||||
getCurrentProject = do
|
||||
path <- Cli.getCurrentPath
|
||||
case preview projectBranchPathPrism path of
|
||||
Nothing -> pure Nothing
|
||||
Just (ProjectAndBranch projectId _branchId, _restPath) ->
|
||||
Cli.runTransaction do
|
||||
project <- Queries.expectProject projectId
|
||||
pure (Just project)
|
||||
|
||||
-- | Like 'getCurrentProject', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProject :: Cli Sqlite.Project
|
||||
expectCurrentProject = do
|
||||
getCurrentProject & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- | Get the current project ids that a user is on.
|
||||
getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId))
|
||||
getCurrentProjectIds =
|
||||
fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath
|
||||
|
||||
-- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
expectCurrentProjectIds =
|
||||
getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- | Get the current project+branch+branch path that a user is on.
|
||||
getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
|
||||
getCurrentProjectBranch = do
|
||||
path <- Cli.getCurrentPath
|
||||
getProjectBranchForPath path
|
||||
|
||||
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
||||
expectProjectBranchByName project branchName =
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
|
||||
getProjectBranchForPath :: Path.Absolute -> Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
|
||||
getProjectBranchForPath path = do
|
||||
case preview projectBranchPathPrism path of
|
||||
Nothing -> pure Nothing
|
||||
Just (ProjectAndBranch projectId branchId, restPath) ->
|
||||
Cli.runTransaction do
|
||||
project <- Queries.expectProject projectId
|
||||
branch <- Queries.expectProjectBranch projectId branchId
|
||||
pure (Just (ProjectAndBranch project branch, restPath))
|
||||
|
||||
-- | Like 'getCurrentProjectBranch', but fails with a message if the user is not on a project branch.
|
||||
expectCurrentProjectBranch :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path)
|
||||
expectCurrentProjectBranch =
|
||||
getCurrentProjectBranch & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
|
||||
-- We often accept a `These ProjectName ProjectBranchName` from the user, so they can leave off either a project or
|
||||
-- branch name, which we infer. This helper "hydrates" such a type to a `(ProjectName, BranchName)`, using the following
|
||||
-- defaults if a name is missing:
|
||||
@ -214,8 +133,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
|
||||
hydrateNames = \case
|
||||
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
||||
pure (ProjectAndBranch (project ^. #name) branchName)
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure (ProjectAndBranch (pp ^. #project . #name) branchName)
|
||||
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
||||
|
||||
getProjectAndBranchByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
@ -244,11 +163,15 @@ getProjectAndBranchByTheseNames ::
|
||||
getProjectAndBranchByTheseNames = \case
|
||||
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> runMaybeT do
|
||||
(ProjectAndBranch project _branch, _restPath) <- MaybeT getCurrentProjectBranch
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName))
|
||||
pure (ProjectAndBranch project branch)
|
||||
These projectName branchName ->
|
||||
Cli.runTransaction (getProjectAndBranchByNames (ProjectAndBranch projectName branchName))
|
||||
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
|
||||
pure (ProjectAndBranch proj branch)
|
||||
These projectName branchName -> do
|
||||
Cli.runTransaction do
|
||||
runMaybeT do
|
||||
project <- MaybeT (Queries.loadProjectByName projectName)
|
||||
branch <- MaybeT (Queries.loadProjectBranchByName (project ^. #projectId) branchName)
|
||||
pure (ProjectAndBranch project branch)
|
||||
|
||||
-- Expect a local project branch by a "these names", using the following defaults if a name is missing:
|
||||
--
|
||||
@ -260,7 +183,7 @@ expectProjectAndBranchByTheseNames ::
|
||||
expectProjectAndBranchByTheseNames = \case
|
||||
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
(ProjectAndBranch project _branch, _restPath) <- expectCurrentProjectBranch
|
||||
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
|
||||
branch <-
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
@ -275,31 +198,33 @@ expectProjectAndBranchByTheseNames = \case
|
||||
maybeProjectAndBranch & onNothing do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
|
||||
-- | Expect/resolve a possibly-ambiguous "loose code or project", with the following rules:
|
||||
-- | Expect/resolve branch reference with the following rules:
|
||||
--
|
||||
-- 1. If we have an unambiguous `/branch` or `project/branch`, look up in the database.
|
||||
-- 2. If we have an unambiguous `loose.code.path`, just return it.
|
||||
-- 3. If we have an ambiguous `foo`, *because we do not currently have an unambiguous syntax for relative paths*,
|
||||
-- we elect to treat it as a loose code path (because `/branch` can be selected with a leading forward slash).
|
||||
expectLooseCodeOrProjectBranch ::
|
||||
These Path' (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) ->
|
||||
Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
expectLooseCodeOrProjectBranch =
|
||||
_Right expectProjectAndBranchByTheseNames . f
|
||||
where
|
||||
f :: LooseCodeOrProject -> Either Path' (These ProjectName ProjectBranchName) -- (Maybe ProjectName, ProjectBranchName)
|
||||
f = \case
|
||||
This path -> Left path
|
||||
That (ProjectAndBranch Nothing branch) -> Right (That branch)
|
||||
That (ProjectAndBranch (Just project) branch) -> Right (These project branch)
|
||||
These path _ -> Left path -- (3) above
|
||||
-- 1. If the project is missing, use the provided project.
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
resolveProjectBranchInProject :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranchInProject defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
||||
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||
pure projectAndBranch
|
||||
|
||||
-- | Expect/resolve branch reference with the following rules:
|
||||
--
|
||||
-- 1. If the project is missing, use the current project.
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
resolveProjectBranch :: ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranch pab = do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
resolveProjectBranchInProject (pp ^. #project) pab
|
||||
|
||||
-- | Get the causal hash of a project branch.
|
||||
getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash
|
||||
getProjectBranchCausalHash branch = do
|
||||
let path = projectBranchPath branch
|
||||
causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)
|
||||
pure causal.causalHash
|
||||
getProjectBranchCausalHash :: ProjectBranch -> Transaction CausalHash
|
||||
getProjectBranchCausalHash ProjectBranch {projectId, branchId} = do
|
||||
causalHashId <- Q.expectProjectBranchHead projectId branchId
|
||||
Q.expectCausalHash causalHashId
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Remote project utils
|
||||
@ -384,7 +309,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
That branchName -> do
|
||||
(ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch
|
||||
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
|
||||
let localProjectId = localProject ^. #projectId
|
||||
let localBranchId = localBranch ^. #branchId
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
|
@ -5,37 +5,26 @@ module Unison.Cli.UniqueTypeGuidLookup
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (unsnoc)
|
||||
import Data.Foldable qualified as Foldable
|
||||
import Data.Maybe (fromJust)
|
||||
import U.Codebase.Branch qualified as Codebase.Branch
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPath)
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.UniqueTypeGuidLookup qualified as Codebase
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
|
||||
loadUniqueTypeGuid :: Path.Absolute -> Name -> Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid currentPath name0 = do
|
||||
-- First, resolve the current path and the (probably/hopefully relative) name of the unique type to the full path
|
||||
-- to the unique type, plus its final distinguished name segment.
|
||||
let (branchPath, name) =
|
||||
name0
|
||||
& Path.fromName'
|
||||
& Path.resolve currentPath
|
||||
& Path.unabsolute
|
||||
& Path.toSeq
|
||||
& unsnoc
|
||||
-- This is safe because we were handed a Name, which can't be empty
|
||||
& fromJust
|
||||
loadUniqueTypeGuid :: ProjectPath -> Name -> Sqlite.Transaction (Maybe Text)
|
||||
loadUniqueTypeGuid pp name0 = do
|
||||
let (namePath, finalSegment) = Path.splitFromName name0
|
||||
let fullPP = pp & over PP.path_ (<> namePath)
|
||||
|
||||
-- Define an operation to load a branch by its full path from the root namespace.
|
||||
--
|
||||
-- This ought to probably lean somewhat on a cache (so long as the caller is aware of the cache, and discrads it at
|
||||
-- an appropriate time, such as after the current unison file finishes parsing).
|
||||
let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||
loadBranchAtPath = Operations.loadBranchAtPath Nothing
|
||||
let loadBranchAtPath :: ProjectPath -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction))
|
||||
loadBranchAtPath = Codebase.getMaybeShallowBranchAtProjectPath
|
||||
|
||||
Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name
|
||||
Codebase.loadUniqueTypeGuid loadBranchAtPath fullPP finalSegment
|
||||
|
@ -1,90 +0,0 @@
|
||||
-- | @.unisonConfig@ file utilities
|
||||
module Unison.Cli.UnisonConfigUtils
|
||||
( remoteMappingKey,
|
||||
resolveConfiguredUrl,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Foldable.Extra qualified as Foldable
|
||||
import Data.Sequence (Seq (..))
|
||||
import Data.Sequence qualified as Seq
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.Output.PushPull (PushPull)
|
||||
import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace (..))
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.UriParser qualified as UriParser
|
||||
import Unison.Codebase.Path (Path' (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
|
||||
configKey :: Text -> Path.Absolute -> Text
|
||||
configKey k p =
|
||||
Text.intercalate "." . toList $
|
||||
k
|
||||
:<| fmap
|
||||
NameSegment.toEscapedText
|
||||
(Path.toSeq $ Path.unabsolute p)
|
||||
|
||||
remoteMappingKey :: Path.Absolute -> Text
|
||||
remoteMappingKey = configKey "RemoteMapping"
|
||||
|
||||
-- Takes a maybe (namespace address triple); returns it as-is if `Just`;
|
||||
-- otherwise, tries to load a value from .unisonConfig, and complains
|
||||
-- if needed.
|
||||
resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void)
|
||||
resolveConfiguredUrl pushPull destPath' = do
|
||||
destPath <- Cli.resolvePath' destPath'
|
||||
whenNothingM (remoteMappingForPath pushPull destPath) do
|
||||
Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath)
|
||||
|
||||
-- | Tries to look up a remote mapping for a given path.
|
||||
-- Will also resolve paths relative to any mapping which is configured for a parent of that
|
||||
-- path.
|
||||
--
|
||||
-- E.g.
|
||||
--
|
||||
-- A config which maps:
|
||||
--
|
||||
-- .myshare.foo -> .me.public.foo
|
||||
--
|
||||
-- Will resolve the following local paths into share paths like so:
|
||||
--
|
||||
-- .myshare.foo -> .me.public.foo
|
||||
-- .myshare.foo.bar -> .me.public.foo.bar
|
||||
-- .myshare.foo.bar.baz -> .me.public.foo.bar.baz
|
||||
-- .myshare -> <Nothing>
|
||||
remoteMappingForPath :: PushPull -> Path.Absolute -> Cli (Maybe (WriteRemoteNamespace Void))
|
||||
remoteMappingForPath pushPull dest = do
|
||||
pathPrefixes dest & Foldable.firstJustM \(prefix, suffix) -> do
|
||||
let remoteMappingConfigKey = remoteMappingKey prefix
|
||||
Cli.getConfig remoteMappingConfigKey >>= \case
|
||||
Just url -> do
|
||||
let parseResult = P.parse (UriParser.writeRemoteNamespaceWith empty) (Text.unpack remoteMappingConfigKey) url
|
||||
in case parseResult of
|
||||
Left err -> Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull dest url (show err))
|
||||
Right wrp -> do
|
||||
let remote = wrp & RemoteRepo.remotePath_ %~ \p -> Path.resolve p suffix
|
||||
in pure $ Just remote
|
||||
Nothing -> pure Nothing
|
||||
where
|
||||
-- Produces a list of path prefixes and suffixes, from longest prefix to shortest
|
||||
--
|
||||
-- E.g.
|
||||
--
|
||||
-- >>> pathPrefixes ("a" :< "b" :< Path.absoluteEmpty)
|
||||
-- fromList [(.a.b,),(.a,b),(.,a.b)]
|
||||
pathPrefixes :: Path.Absolute -> Seq (Path.Absolute, Path.Path)
|
||||
pathPrefixes p =
|
||||
Path.unabsolute p
|
||||
& Path.toSeq
|
||||
& \seq ->
|
||||
Seq.zip (Seq.inits seq) (Seq.tails seq)
|
||||
& Seq.reverse
|
||||
<&> bimap (Path.Absolute . Path.Path) (Path.Path)
|
@ -21,7 +21,6 @@ import Data.Set qualified as Set
|
||||
import Data.Set.NonEmpty (NESet)
|
||||
import Data.Set.NonEmpty qualified as NESet
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Tuple.Extra (uncurry3)
|
||||
import Text.Megaparsec qualified as Megaparsec
|
||||
@ -29,14 +28,13 @@ import U.Codebase.Branch.Diff qualified as V2Branch.Diff
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Reflog qualified as Reflog
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Builtin qualified as Builtin
|
||||
import Unison.Builtin.Terms qualified as Builtin
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils (getCurrentProjectBranch)
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
@ -59,12 +57,14 @@ import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge)
|
||||
import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
|
||||
import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
|
||||
import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges
|
||||
import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm)
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
|
||||
import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
|
||||
import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI)
|
||||
import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format
|
||||
import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib)
|
||||
import Unison.Codebase.Editor.HandleInput.LSPDebug qualified as LSPDebug
|
||||
import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile)
|
||||
import Unison.Codebase.Editor.HandleInput.Ls (handleLs)
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 (handleMerge)
|
||||
@ -81,6 +81,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
|
||||
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
|
||||
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
|
||||
import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.Reflogs qualified as Reflogs
|
||||
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
|
||||
import Unison.Codebase.Editor.HandleInput.Run (handleRun)
|
||||
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
|
||||
@ -93,7 +94,6 @@ import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
|
||||
import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2)
|
||||
import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
|
||||
import Unison.Codebase.Editor.Input
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN
|
||||
@ -105,9 +105,10 @@ import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityChec
|
||||
import Unison.Codebase.Metadata qualified as Metadata
|
||||
import Unison.Codebase.Path (Path, Path' (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
|
||||
import Unison.CommandLine.Completion qualified as Completion
|
||||
import Unison.CommandLine.DisplayValues qualified as DisplayValues
|
||||
import Unison.CommandLine.InputPattern qualified as IP
|
||||
@ -115,7 +116,6 @@ import Unison.CommandLine.InputPatterns qualified as IP
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.Hash qualified as Hash
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.HashQualifiedPrime qualified as HQ'
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
@ -132,12 +132,8 @@ import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Parsers qualified as Parsers
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty)
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
import Unison.Project.Util (projectContextFromPath)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
@ -202,6 +198,7 @@ loop e = do
|
||||
Cli.respond $ Typechecked (Text.pack sourceName) suffixifiedPPE sr uf
|
||||
in Cli.time "InputPattern" case input of
|
||||
ApiI -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Cli.Env {serverBaseUrl} <- ask
|
||||
whenJust serverBaseUrl \baseUrl ->
|
||||
Cli.respond $
|
||||
@ -209,17 +206,17 @@ loop e = do
|
||||
P.lines
|
||||
[ "The API information is as follows:",
|
||||
P.newline,
|
||||
P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.LooseCodeUI Path.absoluteEmpty Nothing) baseUrl))),
|
||||
P.indentN 2 (P.hiBlue ("UI: " <> Pretty.text (Server.urlFor (Server.ProjectBranchUI (PP.toProjectAndBranch . PP.toNames $ pp) Path.absoluteEmpty Nothing) baseUrl))),
|
||||
P.newline,
|
||||
P.indentN 2 (P.hiBlue ("API: " <> Pretty.text (Server.urlFor Server.Api baseUrl)))
|
||||
]
|
||||
CreateMessage pretty ->
|
||||
Cli.respond $ PrintMessage pretty
|
||||
ShowReflogI -> do
|
||||
ShowRootReflogI -> do
|
||||
let numEntriesToShow = 500
|
||||
(schLength, entries) <-
|
||||
Cli.runTransaction $
|
||||
(,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow
|
||||
(,) <$> Codebase.branchHashLength <*> Codebase.getDeprecatedRootReflog numEntriesToShow
|
||||
let moreEntriesToLoad = length entries == numEntriesToShow
|
||||
let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad)
|
||||
let (shortEntries, numberedEntries) =
|
||||
@ -248,86 +245,20 @@ loop e = do
|
||||
-- No expectation, either because this is the most recent entry or
|
||||
-- because we're recovering from a discontinuity
|
||||
Nothing -> ((Just time, toRootCausalHash, reason), (rest, Just fromRootCausalHash, moreEntriesToLoad))
|
||||
ShowProjectBranchReflogI mayProjBranch -> do
|
||||
Reflogs.showProjectBranchReflog mayProjBranch
|
||||
ShowGlobalReflogI -> do
|
||||
Reflogs.showGlobalReflog
|
||||
ShowProjectReflogI mayProj -> do
|
||||
Reflogs.showProjectReflog mayProj
|
||||
ResetI newRoot mtarget -> do
|
||||
newRoot <-
|
||||
case newRoot of
|
||||
This newRoot -> case newRoot of
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
That (ProjectAndBranch mProjectName branchName) -> do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
||||
Cli.expectBranchAtPath'
|
||||
( Path.absoluteToPath'
|
||||
( ProjectUtils.projectBranchPath
|
||||
(ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))
|
||||
)
|
||||
)
|
||||
These branchId (ProjectAndBranch mProjectName branchName) -> Cli.label \jump -> do
|
||||
absPath <- case branchId of
|
||||
Left hash -> jump =<< Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.resolvePath' path'
|
||||
mrelativePath <-
|
||||
Cli.getMaybeBranchAt absPath <&> \case
|
||||
Nothing -> Nothing
|
||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
||||
projectAndBranch <- do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
||||
thePath <- case (mrelativePath, projectAndBranch) of
|
||||
(Nothing, Nothing) ->
|
||||
ProjectUtils.getCurrentProject >>= \case
|
||||
Nothing -> pure absPath
|
||||
Just project ->
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Hash (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
||||
Cli.returnEarlyWithoutOutput
|
||||
(Just _relativePath, Nothing) -> pure absPath
|
||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
Cli.expectBranchAtPath' (Path.absoluteToPath' thePath)
|
||||
|
||||
newRoot <- resolveBranchId2 newRoot
|
||||
target <-
|
||||
case mtarget of
|
||||
Nothing -> Cli.getCurrentPath
|
||||
Just looseCodeOrProject -> case looseCodeOrProject of
|
||||
This path' -> Cli.resolvePath' path'
|
||||
That (ProjectAndBranch mProjectName branchName) -> do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames arg
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
These path' (ProjectAndBranch mProjectName branchName) -> do
|
||||
absPath <- Cli.resolvePath' path'
|
||||
mrelativePath <-
|
||||
Cli.getMaybeBranchAt absPath <&> \case
|
||||
Nothing -> Nothing
|
||||
Just _ -> preview ProjectUtils.projectBranchPathPrism absPath
|
||||
projectAndBranch <- do
|
||||
let arg = case mProjectName of
|
||||
Nothing -> That branchName
|
||||
Just projectName -> These projectName branchName
|
||||
ProjectUtils.getProjectAndBranchByTheseNames arg
|
||||
case (mrelativePath, projectAndBranch) of
|
||||
(Nothing, Nothing) ->
|
||||
ProjectUtils.getCurrentProject >>= \case
|
||||
Nothing -> pure absPath
|
||||
Just project ->
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
(Just (projectAndBranch0, relPath), Just (ProjectAndBranch project branch)) -> do
|
||||
projectAndBranch0 <- Cli.runTransaction (ProjectUtils.expectProjectAndBranchByIds projectAndBranch0)
|
||||
Cli.respondNumbered (AmbiguousReset AmbiguousReset'Target (projectAndBranch0, relPath) (ProjectAndBranch (project ^. #name) (branch ^. #name)))
|
||||
Cli.returnEarlyWithoutOutput
|
||||
(Just _relativePath, Nothing) -> pure absPath
|
||||
(Nothing, Just (ProjectAndBranch project branch)) ->
|
||||
pure (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
Nothing -> Cli.getCurrentProjectPath
|
||||
Just unresolvedProjectAndBranch -> do
|
||||
targetProjectAndBranch <- ProjectUtils.resolveProjectBranch (second Just unresolvedProjectAndBranch)
|
||||
pure $ PP.projectBranchRoot targetProjectAndBranch
|
||||
description <- inputDescription input
|
||||
_ <- Cli.updateAt description target (const newRoot)
|
||||
Cli.respond Success
|
||||
@ -335,22 +266,23 @@ loop e = do
|
||||
Cli.time "reset-root" do
|
||||
newRoot <-
|
||||
case src0 of
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||
BranchAtPath path' -> Cli.expectBranchAtPath' path'
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot newRoot description
|
||||
pb <- getCurrentProjectBranch
|
||||
void $ Cli.updateProjectBranchRoot_ pb description (const newRoot)
|
||||
Cli.respond Success
|
||||
ForkLocalBranchI src0 dest0 -> do
|
||||
(srcb, branchEmpty) <-
|
||||
case src0 of
|
||||
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
absPath <- ProjectUtils.branchRelativePathToAbsolute path'
|
||||
let srcp = Path.AbsolutePath' absPath
|
||||
srcb <- Cli.expectBranchAtPath' srcp
|
||||
pure (srcb, WhichBranchEmptyPath srcp)
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath path'
|
||||
srcb <- Cli.getBranchFromProjectPath srcPP
|
||||
pure (srcb, WhichBranchEmptyPath srcPP)
|
||||
description <- inputDescription input
|
||||
dest <- ProjectUtils.branchRelativePathToAbsolute dest0
|
||||
dest <- ProjectUtils.resolveBranchRelativePath dest0
|
||||
ok <- Cli.updateAtM description dest (const $ pure srcb)
|
||||
Cli.respond
|
||||
if ok
|
||||
@ -358,45 +290,43 @@ loop e = do
|
||||
else BranchEmpty branchEmpty
|
||||
MergeI branch -> handleMerge branch
|
||||
MergeCommitI -> handleCommitMerge
|
||||
MergeLocalBranchI src0 dest0 mergeMode -> do
|
||||
MergeLocalBranchI unresolvedSrc mayUnresolvedDest mergeMode -> do
|
||||
description <- inputDescription input
|
||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
||||
let srcp = looseCodeOrProjectToPath src0
|
||||
let destp = looseCodeOrProjectToPath dest0
|
||||
srcb <- Cli.expectBranchAtPath' srcp
|
||||
dest <- Cli.resolvePath' destp
|
||||
let err =
|
||||
Just $
|
||||
MergeAlreadyUpToDate
|
||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0)
|
||||
((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0)
|
||||
mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest
|
||||
PreviewMergeLocalBranchI src0 dest0 -> do
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||
(destPP, destBRP) <- case mayUnresolvedDest of
|
||||
Nothing -> Cli.getCurrentProjectPath <&> \pp -> (pp, QualifiedBranchPath (pp ^. #project . #name) (pp ^. #branch . #name) (pp ^. PP.absPath_))
|
||||
Just unresolvedDest -> do
|
||||
ProjectUtils.resolveBranchRelativePath unresolvedDest <&> \pp -> (pp, unresolvedDest)
|
||||
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||
let err = Just $ MergeAlreadyUpToDate unresolvedSrc destBRP
|
||||
mergeBranchAndPropagateDefaultPatch mergeMode description err srcBranch (Just $ Left destPP) destPP
|
||||
PreviewMergeLocalBranchI unresolvedSrc mayUnresolvedDest -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
||||
dest0 <- ProjectUtils.expectLooseCodeOrProjectBranch dest0
|
||||
srcb <- Cli.expectBranchAtPath' $ looseCodeOrProjectToPath src0
|
||||
dest <- Cli.resolvePath' $ looseCodeOrProjectToPath dest0
|
||||
destb <- Cli.getBranchAt dest
|
||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||
if merged == destb
|
||||
then Cli.respond (PreviewMergeAlreadyUpToDate src0 dest0)
|
||||
srcPP <- ProjectUtils.resolveBranchRelativePath unresolvedSrc
|
||||
destPP <- case mayUnresolvedDest of
|
||||
Nothing -> Cli.getCurrentProjectPath
|
||||
Just unresolvedDest -> do
|
||||
ProjectUtils.resolveBranchRelativePath unresolvedDest
|
||||
srcBranch <- Cli.getProjectBranchRoot srcPP.branch
|
||||
destBranch <- Cli.getProjectBranchRoot destPP.branch
|
||||
merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcBranch destBranch)
|
||||
if merged == destBranch
|
||||
then Cli.respond (PreviewMergeAlreadyUpToDate srcPP destPP)
|
||||
else do
|
||||
(ppe, diff) <- diffHelper (Branch.head destb) (Branch.head merged)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePreview dest0 dest ppe diff)
|
||||
(ppe, diff) <- diffHelper (Branch.head destBranch) (Branch.head merged)
|
||||
Cli.respondNumbered (ShowDiffAfterMergePreview (Left destPP) destPP ppe diff)
|
||||
DiffNamespaceI before after -> do
|
||||
absBefore <- traverseOf _Right Cli.resolvePath' before
|
||||
absAfter <- traverseOf _Right Cli.resolvePath' after
|
||||
beforeBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absBefore
|
||||
afterBranch0 <- Branch.head <$> Cli.resolveAbsBranchId absAfter
|
||||
beforeLoc <- traverse ProjectUtils.resolveBranchRelativePath before
|
||||
beforeBranch0 <- Branch.head <$> resolveBranchId2 before
|
||||
afterLoc <- traverse ProjectUtils.resolveBranchRelativePath after
|
||||
afterBranch0 <- Branch.head <$> resolveBranchId2 after
|
||||
case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
|
||||
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
|
||||
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (absBefore Nel.:| [])
|
||||
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (absAfter Nel.:| [])
|
||||
(True, True) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [afterLoc])
|
||||
(True, False) -> Cli.returnEarly . NamespaceEmpty $ (beforeLoc Nel.:| [])
|
||||
(False, True) -> Cli.returnEarly . NamespaceEmpty $ (afterLoc Nel.:| [])
|
||||
(False, False) -> pure ()
|
||||
(ppe, diff) <- diffHelper beforeBranch0 afterBranch0
|
||||
Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
|
||||
Cli.respondNumbered (ShowDiffNamespace beforeLoc afterLoc ppe diff)
|
||||
MoveBranchI src' dest' -> do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
description <- inputDescription input
|
||||
@ -404,8 +334,8 @@ loop e = do
|
||||
SwitchBranchI path' -> do
|
||||
path <- Cli.resolvePath' path'
|
||||
branchExists <- Cli.branchExistsAtPath' path'
|
||||
when (not branchExists) (Cli.respond $ CreatedNewBranch path)
|
||||
Cli.cd path
|
||||
when (not branchExists) (Cli.respond $ CreatedNewBranch (path ^. PP.absPath_))
|
||||
Cli.cd (path ^. PP.absPath_)
|
||||
UpI -> do
|
||||
path0 <- Cli.getCurrentPath
|
||||
whenJust (unsnoc path0) \(path, _) ->
|
||||
@ -416,10 +346,11 @@ loop e = do
|
||||
HistoryI resultsCap diffCap from -> do
|
||||
branch <-
|
||||
case from of
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
path <- Cli.resolvePath' path'
|
||||
Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
|
||||
BranchAtSCH hash -> Cli.resolveShortCausalHash hash
|
||||
BranchAtPath path' -> do
|
||||
pp <- Cli.resolvePath' path'
|
||||
Cli.getBranchFromProjectPath pp
|
||||
BranchAtProjectPath pp -> Cli.getBranchFromProjectPath pp
|
||||
schLength <- Cli.runTransaction Codebase.branchHashLength
|
||||
history <- liftIO (doHistory schLength 0 branch [])
|
||||
Cli.respondNumbered history
|
||||
@ -437,7 +368,7 @@ loop e = do
|
||||
let elem = (Branch.headHash b, Branch.namesDiff b' b)
|
||||
doHistory schLength (n + 1) b' (elem : acc)
|
||||
UndoI -> do
|
||||
rootBranch <- Cli.getRootBranch
|
||||
rootBranch <- Cli.getCurrentProjectRoot
|
||||
(_, prev) <-
|
||||
liftIO (Branch.uncons rootBranch) & onNothingM do
|
||||
Cli.returnEarly . CantUndo $
|
||||
@ -445,7 +376,8 @@ loop e = do
|
||||
then CantUndoPastStart
|
||||
else CantUndoPastMerge
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot prev description
|
||||
pb <- getCurrentProjectBranch
|
||||
Cli.updateProjectBranchRoot_ pb description (const prev)
|
||||
(ppe, diff) <- diffHelper (Branch.head prev) (Branch.head rootBranch)
|
||||
Cli.respondNumbered (Output.ShowDiffAfterUndo ppe diff)
|
||||
UiI path' -> openUI path'
|
||||
@ -464,8 +396,8 @@ loop e = do
|
||||
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
|
||||
DocsToHtmlI namespacePath' sourceDirectory -> do
|
||||
Cli.Env {codebase, sandboxedRuntime} <- ask
|
||||
absPath <- ProjectUtils.branchRelativePathToAbsolute namespacePath'
|
||||
branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
|
||||
projPath <- ProjectUtils.resolveBranchRelativePath namespacePath'
|
||||
branch <- Cli.getBranchFromProjectPath projPath
|
||||
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
|
||||
pure ()
|
||||
AliasTermI force src' dest' -> do
|
||||
@ -490,7 +422,7 @@ loop e = do
|
||||
when (not force && not (Set.null destTerms)) do
|
||||
Cli.returnEarly (TermAlreadyExists dest' destTerms)
|
||||
description <- inputDescription input
|
||||
Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm)
|
||||
Cli.stepAt description (BranchUtil.makeAddTermName dest srcTerm)
|
||||
Cli.respond Success
|
||||
AliasTypeI force src' dest' -> do
|
||||
src <- traverseOf _Right Cli.resolveSplit' src'
|
||||
@ -513,22 +445,22 @@ loop e = do
|
||||
when (not force && not (Set.null destTypes)) do
|
||||
Cli.returnEarly (TypeAlreadyExists dest' destTypes)
|
||||
description <- inputDescription input
|
||||
Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType)
|
||||
Cli.stepAt description (BranchUtil.makeAddTypeName dest srcType)
|
||||
Cli.respond Success
|
||||
|
||||
-- this implementation will happily produce name conflicts,
|
||||
-- but will surface them in a normal diff at the end of the operation.
|
||||
AliasManyI srcs dest' -> do
|
||||
root0 <- Cli.getRootBranch0
|
||||
root0 <- Cli.getCurrentProjectRoot0
|
||||
currentBranch0 <- Cli.getCurrentBranch0
|
||||
destAbs <- Cli.resolvePath' dest'
|
||||
old <- Cli.getBranch0At destAbs
|
||||
destPP <- Cli.resolvePath' dest'
|
||||
old <- Cli.getBranch0FromProjectPath destPP
|
||||
description <- inputDescription input
|
||||
let (unknown, actions) = foldl' (go root0 currentBranch0 destAbs) mempty srcs
|
||||
Cli.stepManyAt description actions
|
||||
new <- Cli.getBranch0At destAbs
|
||||
let (unknown, actions) = foldl' (go root0 currentBranch0 (PP.absPath destPP)) mempty srcs
|
||||
Cli.stepManyAt destPP.branch description actions
|
||||
new <- Cli.getBranch0FromProjectPath destPP
|
||||
(ppe, diff) <- diffHelper old new
|
||||
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' destAbs ppe diff)
|
||||
Cli.respondNumbered (ShowDiffAfterModifyBranch dest' (destPP.absPath) ppe diff)
|
||||
when (not (null unknown)) do
|
||||
Cli.respond . SearchTermsNotFound . fmap fixupOutput $ unknown
|
||||
where
|
||||
@ -537,28 +469,29 @@ loop e = do
|
||||
Branch0 IO ->
|
||||
Branch0 IO ->
|
||||
Path.Absolute ->
|
||||
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)]) ->
|
||||
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)]) ->
|
||||
Path.HQSplit ->
|
||||
([Path.HQSplit], [(Path, Branch0 m -> Branch0 m)])
|
||||
([Path.HQSplit], [(Path.Absolute, Branch0 m -> Branch0 m)])
|
||||
go root0 currentBranch0 dest (missingSrcs, actions) hqsrc =
|
||||
let proposedDest :: Path.Split
|
||||
let proposedDest :: Path.AbsSplit
|
||||
proposedDest = second HQ'.toName hqProposedDest
|
||||
hqProposedDest :: Path.HQSplit
|
||||
hqProposedDest = first Path.unabsolute $ Path.resolve dest hqsrc
|
||||
hqProposedDest :: Path.HQSplitAbsolute
|
||||
hqProposedDest = Path.resolve dest hqsrc
|
||||
-- `Nothing` if src doesn't exist
|
||||
doType :: Maybe [(Path, Branch0 m -> Branch0 m)]
|
||||
doType :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
doType = case ( BranchUtil.getType hqsrc currentBranch0,
|
||||
BranchUtil.getType hqProposedDest root0
|
||||
BranchUtil.getType (first Path.unabsolute hqProposedDest) root0
|
||||
) of
|
||||
(null -> True, _) -> Nothing -- missing src
|
||||
(rsrcs, existing) ->
|
||||
-- happy path
|
||||
Just . map addAlias . toList $ Set.difference rsrcs existing
|
||||
where
|
||||
addAlias :: Reference -> (Path.Absolute, Branch0 m -> Branch0 m)
|
||||
addAlias r = BranchUtil.makeAddTypeName proposedDest r
|
||||
doTerm :: Maybe [(Path, Branch0 m -> Branch0 m)]
|
||||
doTerm :: Maybe [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
doTerm = case ( BranchUtil.getTerm hqsrc currentBranch0,
|
||||
BranchUtil.getTerm hqProposedDest root0
|
||||
BranchUtil.getTerm (first Path.unabsolute hqProposedDest) root0
|
||||
) of
|
||||
(null -> True, _) -> Nothing -- missing src
|
||||
(rsrcs, existing) ->
|
||||
@ -575,15 +508,10 @@ loop e = do
|
||||
fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
|
||||
NamesI global query -> do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
root <- Cli.getRootBranch
|
||||
(names, pped) <-
|
||||
if global || any Name.isAbsolute query
|
||||
if global
|
||||
then do
|
||||
let root0 = Branch.head root
|
||||
-- Use an absolutely qualified ppe for view.global
|
||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||
let pped = PPED.makePPED (PPE.hqNamer hqLength names) (PPE.suffixifyByHash names)
|
||||
pure (names, pped)
|
||||
error "TODO: Implement names.global."
|
||||
else do
|
||||
names <- Cli.currentNames
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
@ -613,11 +541,13 @@ loop e = do
|
||||
authorPath <- Cli.resolveSplit' authorPath'
|
||||
copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.copyrightHoldersSegment |> authorNameSegment)
|
||||
guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment)
|
||||
pb <- Cli.getCurrentProjectBranch
|
||||
Cli.stepManyAt
|
||||
pb
|
||||
description
|
||||
[ BranchUtil.makeAddTermName (first Path.unabsolute authorPath) (d authorRef),
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
|
||||
[ BranchUtil.makeAddTermName (first PP.absPath authorPath) (d authorRef),
|
||||
BranchUtil.makeAddTermName (first PP.absPath copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (first PP.absPath guidPath) (d guidRef)
|
||||
]
|
||||
currentPath <- Cli.getCurrentPath
|
||||
finalBranch <- Cli.getCurrentBranch0
|
||||
@ -640,48 +570,54 @@ loop e = do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
desc <- inputDescription input
|
||||
handleMoveAll hasConfirmed src' dest' desc
|
||||
DeleteI dtarget -> case dtarget of
|
||||
DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
|
||||
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
|
||||
DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs
|
||||
DeleteTarget'Namespace insistence Nothing -> do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
if hasConfirmed || insistence == Force
|
||||
then do
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot Branch.empty description
|
||||
Cli.respond DeletedEverything
|
||||
else Cli.respond DeleteEverythingConfirmation
|
||||
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
|
||||
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
||||
description <- inputDescription input
|
||||
let toDelete =
|
||||
Names.prefix0
|
||||
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
||||
(Branch.toNames (Branch.head branch))
|
||||
afterDelete <- do
|
||||
names <- Cli.currentNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
||||
case (null endangerments, insistence) of
|
||||
(True, _) -> pure (Cli.respond Success)
|
||||
(False, Force) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
pure do
|
||||
Cli.respond Success
|
||||
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
||||
(False, Try) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
||||
Cli.returnEarlyWithoutOutput
|
||||
parentPathAbs <- Cli.resolvePath parentPath
|
||||
-- We have to modify the parent in order to also wipe out the history at the
|
||||
-- child.
|
||||
Cli.updateAt description parentPathAbs \parentBranch ->
|
||||
parentBranch
|
||||
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
||||
afterDelete
|
||||
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
||||
DeleteTarget'Project name -> handleDeleteProject name
|
||||
DeleteI dtarget -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let getTerms (absPath, seg) = Cli.getTermsAt (set PP.absPath_ absPath pp, seg)
|
||||
let getTypes (absPath, seg) = Cli.getTypesAt (set PP.absPath_ absPath pp, seg)
|
||||
case dtarget of
|
||||
DeleteTarget'TermOrType doutput hqs -> do
|
||||
delete input doutput getTerms getTypes hqs
|
||||
DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs
|
||||
DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs
|
||||
DeleteTarget'Namespace insistence Nothing -> do
|
||||
hasConfirmed <- confirmedCommand input
|
||||
if hasConfirmed || insistence == Force
|
||||
then do
|
||||
description <- inputDescription input
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
_ <- Cli.updateAt description pp (const Branch.empty)
|
||||
Cli.respond DeletedEverything
|
||||
else Cli.respond DeleteEverythingConfirmation
|
||||
DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do
|
||||
branch <- Cli.expectBranchAtPath (Path.unsplit p)
|
||||
description <- inputDescription input
|
||||
let toDelete =
|
||||
Names.prefix0
|
||||
(Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
|
||||
(Branch.toNames (Branch.head branch))
|
||||
afterDelete <- do
|
||||
names <- Cli.currentNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names)
|
||||
case (null endangerments, insistence) of
|
||||
(True, _) -> pure (Cli.respond Success)
|
||||
(False, Force) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
pure do
|
||||
Cli.respond Success
|
||||
Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
|
||||
(False, Try) -> do
|
||||
ppeDecl <- Cli.currentPrettyPrintEnvDecl
|
||||
Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments
|
||||
Cli.returnEarlyWithoutOutput
|
||||
parentPathAbs <- Cli.resolvePath parentPath
|
||||
-- We have to modify the parent in order to also wipe out the history at the
|
||||
-- child.
|
||||
Cli.updateAt description parentPathAbs \parentBranch ->
|
||||
parentBranch
|
||||
& Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty
|
||||
afterDelete
|
||||
DeleteTarget'ProjectBranch name -> handleDeleteBranch name
|
||||
DeleteTarget'Project name -> handleDeleteProject name
|
||||
DisplayI outputLoc namesToDisplay -> do
|
||||
traverse_ (displayI outputLoc) namesToDisplay
|
||||
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
|
||||
@ -697,16 +633,15 @@ loop e = do
|
||||
let vars = Set.map Name.toVar requestedNames
|
||||
uf <- Cli.expectLatestTypecheckedFile
|
||||
Cli.Env {codebase} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
currentNames <- Branch.toNames <$> Cli.getCurrentBranch0
|
||||
let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
|
||||
let adds = SlurpResult.adds sr
|
||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Cli.stepAt description (pp, doSlurpAdds adds uf)
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames $ UF.addNamesFromTypeCheckedUnisonFile uf currentNames
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||
Cli.syncRoot description
|
||||
SaveExecuteResultI resultName -> handleAddRun input resultName
|
||||
PreviewAddI requestedNames -> do
|
||||
(sourceName, _) <- Cli.expectLatestFile
|
||||
@ -756,7 +691,8 @@ loop e = do
|
||||
let destPath = case opath of
|
||||
Just path -> Path.resolve currentPath (Path.Relative path)
|
||||
Nothing -> currentPath `snoc` NameSegment.builtinSegment
|
||||
_ <- Cli.updateAtM description destPath \destb ->
|
||||
pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath
|
||||
_ <- Cli.updateAtM description pp \destb ->
|
||||
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||
Cli.respond Success
|
||||
MergeIOBuiltinsI opath -> do
|
||||
@ -783,7 +719,8 @@ loop e = do
|
||||
let destPath = case opath of
|
||||
Just path -> Path.resolve currentPath (Path.Relative path)
|
||||
Nothing -> currentPath `snoc` NameSegment.builtinSegment
|
||||
_ <- Cli.updateAtM description destPath \destb ->
|
||||
pp <- set PP.absPath_ destPath <$> Cli.getCurrentProjectPath
|
||||
_ <- Cli.updateAtM description pp \destb ->
|
||||
liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb)
|
||||
Cli.respond Success
|
||||
PullI sourceTarget pullMode -> handlePull sourceTarget pullMode
|
||||
@ -805,20 +742,21 @@ loop e = do
|
||||
Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms
|
||||
DebugTabCompletionI inputs -> do
|
||||
Cli.Env {authHTTPClient, codebase} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient currentPath
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
let completionFunc = Completion.haskelineTabComplete IP.patternMap codebase authHTTPClient pp
|
||||
(_, completions) <- liftIO $ completionFunc (reverse (unwords inputs), "")
|
||||
Cli.respond (DisplayDebugCompletions completions)
|
||||
DebugLSPNameCompletionI prefix -> do
|
||||
LSPDebug.debugLspNameCompletion prefix
|
||||
DebugFuzzyOptionsI command args -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0
|
||||
let projCtx = projectContextFromPath currentPath
|
||||
case Map.lookup command InputPatterns.patternMap of
|
||||
Just (IP.InputPattern {args = argTypes}) -> do
|
||||
zip argTypes args & Monoid.foldMapM \case
|
||||
((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do
|
||||
results <- liftIO $ getOptions codebase projCtx currentBranch
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
results <- liftIO $ getOptions codebase pp currentBranch
|
||||
Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results))
|
||||
((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do
|
||||
Cli.respond DebugFuzzyOptionsNoResolver
|
||||
@ -888,13 +826,13 @@ loop e = do
|
||||
prettyRef renderR r = P.indentN 2 $ P.text (renderR r)
|
||||
prettyDefn renderR (r, Foldable.toList -> names) =
|
||||
P.lines (P.text <$> if null names then ["<unnamed>"] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r
|
||||
rootBranch <- Cli.getRootBranch
|
||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch]
|
||||
projectRoot <- Cli.getCurrentProjectRoot
|
||||
void . liftIO . flip State.execStateT mempty $ goCausal [getCausal projectRoot]
|
||||
DebugDumpNamespaceSimpleI -> do
|
||||
rootBranch0 <- Cli.getRootBranch0
|
||||
for_ (Relation.toList . Branch.deepTypes $ rootBranch0) \(r, name) ->
|
||||
projectRootBranch0 <- Cli.getCurrentProjectRoot0
|
||||
for_ (Relation.toList . Branch.deepTypes $ projectRootBranch0) \(r, name) ->
|
||||
traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
|
||||
for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) ->
|
||||
for_ (Relation.toList . Branch.deepTerms $ projectRootBranch0) \(r, name) ->
|
||||
traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
|
||||
DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
|
||||
DebugLSPFoldRangesI -> do
|
||||
@ -934,7 +872,7 @@ loop e = do
|
||||
Cli.respond $ PrintVersion ucmVersion
|
||||
ProjectRenameI name -> handleProjectRename name
|
||||
ProjectSwitchI name -> projectSwitch name
|
||||
ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name
|
||||
ProjectCreateI tryDownloadingBase name -> void $ projectCreate tryDownloadingBase name
|
||||
ProjectsI -> handleProjects
|
||||
BranchI source name -> handleBranch source name
|
||||
BranchRenameI name -> handleBranchRename name
|
||||
@ -944,6 +882,7 @@ loop e = do
|
||||
UpgradeI old new -> handleUpgrade old new
|
||||
UpgradeCommitI -> handleCommitUpgrade
|
||||
LibInstallI remind libdep -> handleInstallLib remind libdep
|
||||
DebugSynhashTermI name -> handleDebugSynhashTerm name
|
||||
|
||||
inputDescription :: Input -> Cli Text
|
||||
inputDescription input =
|
||||
@ -954,26 +893,23 @@ inputDescription input =
|
||||
dest <- brp dest0
|
||||
pure ("fork " <> src <> " " <> dest)
|
||||
MergeLocalBranchI src0 dest0 mode -> do
|
||||
src <- looseCodeOrProjectToText src0
|
||||
dest <- looseCodeOrProjectToText dest0
|
||||
let src = into @Text src0
|
||||
let dest = maybe "" (into @Text) dest0
|
||||
let command =
|
||||
case mode of
|
||||
Branch.RegularMerge -> "merge"
|
||||
Branch.SquashMerge -> "merge.squash"
|
||||
pure (command <> " " <> src <> " " <> dest)
|
||||
ResetI hash tgt -> do
|
||||
hashTxt <- case hash of
|
||||
This hash -> hp' hash
|
||||
That pr -> pure (into @Text pr)
|
||||
These hash _pr -> hp' hash
|
||||
ResetI newRoot tgt -> do
|
||||
hashTxt <- bid2 newRoot
|
||||
tgt <- case tgt of
|
||||
Nothing -> pure ""
|
||||
Just tgt -> do
|
||||
tgt <- looseCodeOrProjectToText tgt
|
||||
pure (" " <> tgt)
|
||||
let tgtText = into @Text tgt
|
||||
pure (" " <> tgtText)
|
||||
pure ("reset " <> hashTxt <> tgt)
|
||||
ResetRootI src0 -> do
|
||||
src <- hp' src0
|
||||
let src = into @Text src0
|
||||
pure ("reset-root " <> src)
|
||||
AliasTermI force src0 dest0 -> do
|
||||
src <- hhqs' src0
|
||||
@ -1056,7 +992,17 @@ inputDescription input =
|
||||
CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name)
|
||||
ClearI {} -> pure "clear"
|
||||
DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
|
||||
--
|
||||
DebugTermI verbose hqName ->
|
||||
if verbose
|
||||
then pure ("debug.term.verbose " <> HQ.toText hqName)
|
||||
else pure ("debug.term " <> HQ.toText hqName)
|
||||
DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
|
||||
DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges"
|
||||
DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
|
||||
DebugFormatI -> pure "debug.format"
|
||||
EditNamespaceI paths ->
|
||||
pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
|
||||
-- wat land
|
||||
ApiI -> wat
|
||||
AuthLoginI {} -> wat
|
||||
BranchI {} -> wat
|
||||
@ -1068,17 +1014,11 @@ inputDescription input =
|
||||
DebugDoctorI {} -> wat
|
||||
DebugDumpNamespaceSimpleI {} -> wat
|
||||
DebugDumpNamespacesI {} -> wat
|
||||
DebugTermI verbose hqName ->
|
||||
if verbose
|
||||
then pure ("debug.term.verbose " <> HQ.toText hqName)
|
||||
else pure ("debug.term " <> HQ.toText hqName)
|
||||
DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
|
||||
DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges"
|
||||
DebugLSPNameCompletionI {} -> wat
|
||||
DebugNameDiffI {} -> wat
|
||||
DebugNumberedArgsI {} -> wat
|
||||
DebugTabCompletionI _input -> wat
|
||||
DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input)
|
||||
DebugFormatI -> pure "debug.format"
|
||||
DebugSynhashTermI {} -> wat
|
||||
DebugTabCompletionI {} -> wat
|
||||
DebugTypecheckedUnisonFileI {} -> wat
|
||||
DiffNamespaceI {} -> wat
|
||||
DisplayI {} -> wat
|
||||
@ -1086,15 +1026,13 @@ inputDescription input =
|
||||
DocsToHtmlI {} -> wat
|
||||
FindI {} -> wat
|
||||
FindShallowI {} -> wat
|
||||
StructuredFindI {} -> wat
|
||||
StructuredFindReplaceI {} -> wat
|
||||
HistoryI {} -> wat
|
||||
LibInstallI {} -> wat
|
||||
ListDependenciesI {} -> wat
|
||||
ListDependentsI {} -> wat
|
||||
LoadI {} -> wat
|
||||
MergeI {} -> wat
|
||||
MergeCommitI {} -> wat
|
||||
MergeI {} -> wat
|
||||
NamesI {} -> wat
|
||||
NamespaceDependenciesI {} -> wat
|
||||
PopBranchI {} -> wat
|
||||
@ -1110,26 +1048,34 @@ inputDescription input =
|
||||
QuitI {} -> wat
|
||||
ReleaseDraftI {} -> wat
|
||||
ShowDefinitionI {} -> wat
|
||||
EditNamespaceI paths ->
|
||||
pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths))
|
||||
ShowReflogI {} -> wat
|
||||
StructuredFindI {} -> wat
|
||||
StructuredFindReplaceI {} -> wat
|
||||
ShowRootReflogI {} -> pure "deprecated.root-reflog"
|
||||
ShowGlobalReflogI {} -> pure "reflog.global"
|
||||
ShowProjectReflogI mayProjName -> do
|
||||
case mayProjName of
|
||||
Nothing -> pure "project.reflog"
|
||||
Just projName -> pure $ "project.reflog" <> into @Text projName
|
||||
ShowProjectBranchReflogI mayProjBranch -> do
|
||||
case mayProjBranch of
|
||||
Nothing -> pure "branch.reflog"
|
||||
Just (PP.ProjectAndBranch Nothing branchName) -> pure $ "branch.reflog" <> into @Text branchName
|
||||
Just (PP.ProjectAndBranch (Just projName) branchName) -> pure $ "branch.reflog" <> into @Text (PP.ProjectAndBranch projName branchName)
|
||||
SwitchBranchI {} -> wat
|
||||
TestI {} -> wat
|
||||
TodoI {} -> wat
|
||||
UiI {} -> wat
|
||||
UpI {} -> wat
|
||||
UpgradeI {} -> wat
|
||||
UpgradeCommitI {} -> wat
|
||||
UpgradeI {} -> wat
|
||||
VersionI -> wat
|
||||
where
|
||||
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
|
||||
hp' = either (pure . Text.pack . show) p'
|
||||
p :: Path -> Cli Text
|
||||
p = fmap tShow . Cli.resolvePath
|
||||
p = fmap (into @Text) . Cli.resolvePath
|
||||
p' :: Path' -> Cli Text
|
||||
p' = fmap tShow . Cli.resolvePath'
|
||||
p' = fmap (into @Text) . Cli.resolvePath'
|
||||
brp :: BranchRelativePath -> Cli Text
|
||||
brp = fmap from . ProjectUtils.resolveBranchRelativePath
|
||||
brp = fmap (into @Text) . ProjectUtils.resolveBranchRelativePath
|
||||
ops :: Maybe Path.Split -> Cli Text
|
||||
ops = maybe (pure ".") ps
|
||||
wat = error $ show input ++ " is not expected to alter the branch"
|
||||
@ -1144,12 +1090,10 @@ inputDescription input =
|
||||
hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
|
||||
ps' = p' . Path.unsplit'
|
||||
ps = p . Path.unsplit
|
||||
looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text
|
||||
looseCodeOrProjectToText = \case
|
||||
This path -> p' path
|
||||
That branch -> pure (into @Text branch)
|
||||
-- just trying to recover the syntax the user wrote
|
||||
These path _branch -> pure (Path.toText' path)
|
||||
bid2 :: BranchId2 -> Cli Text
|
||||
bid2 = \case
|
||||
Left sch -> pure $ into @Text sch
|
||||
Right p -> brp p
|
||||
|
||||
handleFindI ::
|
||||
Bool ->
|
||||
@ -1162,7 +1106,7 @@ handleFindI isVerbose fscope ws input = do
|
||||
(pped, names, searchRoot, branch0) <- case fscope of
|
||||
FindLocal p -> do
|
||||
searchRoot <- Cli.resolvePath' p
|
||||
branch0 <- Cli.getBranch0At searchRoot
|
||||
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||
let names = Branch.toNames (Branch.withoutLib branch0)
|
||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||
-- results may contain things in lib.
|
||||
@ -1170,17 +1114,18 @@ handleFindI isVerbose fscope ws input = do
|
||||
pure (pped, names, Just p, branch0)
|
||||
FindLocalAndDeps p -> do
|
||||
searchRoot <- Cli.resolvePath' p
|
||||
branch0 <- Cli.getBranch0At searchRoot
|
||||
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||
let names = Branch.toNames (Branch.withoutTransitiveLibs branch0)
|
||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||
-- results may contain things in lib.
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
pure (pped, names, Just p, branch0)
|
||||
FindGlobal -> do
|
||||
globalNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getRootBranch0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames globalNames
|
||||
-- TODO: Rewrite to be properly global again
|
||||
projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
|
||||
currentBranch0 <- Cli.getCurrentBranch0
|
||||
pure (pped, globalNames, Nothing, currentBranch0)
|
||||
pure (pped, projectRootNames, Nothing, currentBranch0)
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
let getResults :: Names -> Cli [SearchResult]
|
||||
getResults names =
|
||||
@ -1316,16 +1261,16 @@ handleShowDefinition outputLoc showDefinitionScope query = do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
let hasAbsoluteQuery = any (any Name.isAbsolute) query
|
||||
(names, unbiasedPPED) <- case (hasAbsoluteQuery, showDefinitionScope) of
|
||||
-- If any of the queries are absolute, use global names.
|
||||
-- TODO: We should instead print each definition using the names from its project-branch root.
|
||||
(True, _) -> do
|
||||
root <- Cli.getRootBranch
|
||||
root <- Cli.getCurrentProjectRoot
|
||||
let root0 = Branch.head root
|
||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
pure (names, pped)
|
||||
(_, ShowDefinitionGlobal) -> do
|
||||
root <- Cli.getRootBranch
|
||||
-- TODO: Maybe rewrite to be properly global
|
||||
root <- Cli.getCurrentProjectRoot
|
||||
let root0 = Branch.head root
|
||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
@ -1527,8 +1472,8 @@ delete input doutput getTerms getTypes hqs' = do
|
||||
traverse
|
||||
( \hq -> do
|
||||
absolute <- Cli.resolveSplit' hq
|
||||
types <- getTypes absolute
|
||||
terms <- getTerms absolute
|
||||
types <- getTypes (first PP.absPath absolute)
|
||||
terms <- getTerms (first PP.absPath absolute)
|
||||
return (hq, types, terms)
|
||||
)
|
||||
hqs'
|
||||
@ -1547,25 +1492,20 @@ checkDeletes :: [(Path.HQSplit', Set Reference, Set Referent)] -> DeleteOutput -
|
||||
checkDeletes typesTermsTuples doutput inputs = do
|
||||
let toSplitName ::
|
||||
(Path.HQSplit', Set Reference, Set Referent) ->
|
||||
Cli (Path.Split, Name, Set Reference, Set Referent)
|
||||
Cli (Path.AbsSplit, Name, Set Reference, Set Referent)
|
||||
toSplitName hq = do
|
||||
-- __FIXME__: `resolvedPath` is ostensiby `Absolute`, but the paths here must be `Relative` below
|
||||
resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
(pp, ns) <- Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
let resolvedSplit = (pp.absPath, ns)
|
||||
return
|
||||
( resolvedPath,
|
||||
Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
|
||||
hq ^. _2,
|
||||
hq ^. _3
|
||||
)
|
||||
(resolvedSplit, Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative . Path.unabsolute) resolvedSplit, hq ^. _2, hq ^. _3)
|
||||
|
||||
-- get the splits and names with terms and types
|
||||
splitsNames <- traverse toSplitName typesTermsTuples
|
||||
let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref
|
||||
toRel setRef name = R.fromList (fmap (name,) (toList setRef))
|
||||
let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames
|
||||
-- make sure endangered is compeletely contained in paths
|
||||
-- TODO: We should just check for endangerments from the project root, not the
|
||||
-- global root!
|
||||
rootNames <- Branch.toNames <$> Cli.getRootBranch0
|
||||
projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
-- get only once for the entire deletion set
|
||||
let allTermsToDelete :: Set LabeledDependency
|
||||
allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete)
|
||||
@ -1574,7 +1514,7 @@ checkDeletes typesTermsTuples doutput inputs = do
|
||||
Cli.runTransaction $
|
||||
traverse
|
||||
( \targetToDelete ->
|
||||
getEndangeredDependents targetToDelete (allTermsToDelete) rootNames
|
||||
getEndangeredDependents targetToDelete (allTermsToDelete) projectNames
|
||||
)
|
||||
toDelete
|
||||
-- If the overall dependency map is not completely empty, abort deletion
|
||||
@ -1589,7 +1529,8 @@ checkDeletes typesTermsTuples doutput inputs = do
|
||||
)
|
||||
before <- Cli.getCurrentBranch0
|
||||
description <- inputDescription inputs
|
||||
Cli.stepManyAt description deleteTypesTerms
|
||||
pb <- Cli.getCurrentProjectBranch
|
||||
Cli.stepManyAt pb description deleteTypesTerms
|
||||
case doutput of
|
||||
DeleteOutput'Diff -> do
|
||||
after <- Cli.getCurrentBranch0
|
||||
@ -1598,7 +1539,7 @@ checkDeletes typesTermsTuples doutput inputs = do
|
||||
DeleteOutput'NoDiff -> do
|
||||
Cli.respond Success
|
||||
else do
|
||||
ppeDecl <- Cli.prettyPrintEnvDeclFromNames rootNames
|
||||
ppeDecl <- Cli.prettyPrintEnvDeclFromNames projectNames
|
||||
let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions
|
||||
Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs)
|
||||
|
||||
@ -1659,7 +1600,7 @@ displayI outputLoc hq = do
|
||||
(names, pped) <-
|
||||
if useRoot
|
||||
then do
|
||||
root <- Cli.getRootBranch
|
||||
root <- Cli.getCurrentProjectRoot
|
||||
let root0 = Branch.head root
|
||||
let names = Names.makeAbsolute $ Branch.toNames root0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
@ -1771,14 +1712,10 @@ addWatch watchName (Just uf) = do
|
||||
)
|
||||
_ -> addWatch watchName Nothing
|
||||
|
||||
looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path'
|
||||
looseCodeOrProjectToPath = \case
|
||||
Left pth -> pth
|
||||
Right (ProjectAndBranch prj br) ->
|
||||
Path.absoluteToPath'
|
||||
( ProjectUtils.projectBranchPath
|
||||
( ProjectAndBranch
|
||||
(prj ^. #projectId)
|
||||
(br ^. #branchId)
|
||||
)
|
||||
)
|
||||
resolveBranchId2 :: BranchId2 -> Cli (Branch IO)
|
||||
resolveBranchId2 = \case
|
||||
Left sch -> Cli.resolveShortCausalHash sch
|
||||
Right brp -> do
|
||||
pp <- ProjectUtils.resolveBranchRelativePath brp
|
||||
Cli.Env {codebase} <- ask
|
||||
fromMaybe Branch.empty <$> liftIO (Codebase.getBranchAtProjectPath codebase pp)
|
||||
|
@ -19,7 +19,6 @@ import Unison.Codebase.Editor.Input (Input)
|
||||
import Unison.Codebase.Editor.Output (Output (NoLastRunResult, SaveTermNameConflict, SlurpOutput))
|
||||
import Unison.Codebase.Editor.Slurp qualified as Slurp
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.CommandLine.InputPattern qualified as InputPattern
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.Name (Name)
|
||||
@ -37,16 +36,16 @@ handleAddRun input resultName = do
|
||||
let resultVar = Name.toVar resultName
|
||||
uf <- addSavedTermToUnisonFile resultName
|
||||
Cli.Env {codebase} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
currentNames <- Cli.currentNames
|
||||
let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
|
||||
let adds = SlurpResult.adds sr
|
||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
let description = (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName)
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Cli.stepAt description (pp, doSlurpAdds adds uf)
|
||||
let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf currentNames
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile
|
||||
let suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||
Cli.syncRoot (Text.pack (InputPattern.patternName InputPatterns.saveExecuteResult) <> " " <> Name.toText resultName)
|
||||
Cli.respond $ SlurpOutput input suffixifiedPPE sr
|
||||
|
||||
addSavedTermToUnisonFile :: Name -> Cli (TypecheckedUnisonFile Symbol Ann)
|
||||
|
@ -1,44 +1,42 @@
|
||||
-- | @branch@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.Branch
|
||||
( handleBranch,
|
||||
CreateFrom (..),
|
||||
doCreateBranch,
|
||||
doCreateBranch',
|
||||
( CreateFrom (..),
|
||||
handleBranch,
|
||||
createBranch,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.These (These (..))
|
||||
import Control.Monad.Reader
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (getBranchAt, getCurrentPath, updateAt)
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch (empty)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
|
||||
data CreateFrom
|
||||
= CreateFrom'Branch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
| CreateFrom'LooseCode Path.Absolute
|
||||
= CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
|
||||
| CreateFrom'ParentBranch Sqlite.ProjectBranch
|
||||
| CreateFrom'Namespace (Branch IO)
|
||||
| CreateFrom'Nothingness
|
||||
|
||||
-- | Create a new project branch from an existing project branch or namespace.
|
||||
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleBranch sourceI projectAndBranchNames0 = do
|
||||
projectAndBranchNames@(ProjectAndBranch projectName newBranchName) <-
|
||||
case projectAndBranchNames0 of
|
||||
ProjectAndBranch Nothing branchName -> ProjectUtils.hydrateNames (That branchName)
|
||||
ProjectAndBranch (Just projectName) branchName -> pure (ProjectAndBranch projectName branchName)
|
||||
|
||||
handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newBranchName) = do
|
||||
-- You can only create release branches with `branch.clone`
|
||||
--
|
||||
-- We do allow creating draft release branches with `branch`, but you'll get different output if you use
|
||||
@ -50,93 +48,81 @@ handleBranch sourceI projectAndBranchNames0 = do
|
||||
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
|
||||
ProjectBranchNameKind'NothingSpecial -> pure ()
|
||||
|
||||
currentProjectName <- Cli.getCurrentProjectPath <&> view (#project . #name)
|
||||
let projectName = (fromMaybe currentProjectName mayProjectName)
|
||||
destProject <- do
|
||||
Cli.runTransactionWithRollback
|
||||
\rollback -> do
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName))
|
||||
|
||||
-- Compute what we should create the branch from.
|
||||
createFrom <-
|
||||
maySrcProjectAndBranch <-
|
||||
case sourceI of
|
||||
Input.BranchSourceI'CurrentContext ->
|
||||
ProjectUtils.getCurrentProjectBranch >>= \case
|
||||
Nothing -> CreateFrom'LooseCode <$> Cli.getCurrentPath
|
||||
Just (currentBranch, _restPath) -> pure (CreateFrom'Branch currentBranch)
|
||||
Input.BranchSourceI'Empty -> pure CreateFrom'Nothingness
|
||||
Input.BranchSourceI'LooseCodeOrProject (This sourcePath) -> do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
pure (CreateFrom'LooseCode (Path.resolve currentPath sourcePath))
|
||||
Input.BranchSourceI'LooseCodeOrProject (That sourceBranch) ->
|
||||
fmap CreateFrom'Branch do
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case sourceBranch of
|
||||
ProjectAndBranch Nothing b -> That b
|
||||
ProjectAndBranch (Just p) b -> These p b
|
||||
-- For now, treat ambiguous parses as branch names, as this seems (far) more common than trying to create a
|
||||
-- branch from a relative one-segment namespace.
|
||||
--
|
||||
-- Future work: be smarter; for example, if there is such a relative namespace, but no such branch, maybe they
|
||||
-- really meant create a branch from that namespace.
|
||||
Input.BranchSourceI'LooseCodeOrProject (These _sourcePath sourceBranch) ->
|
||||
fmap CreateFrom'Branch do
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case sourceBranch of
|
||||
ProjectAndBranch Nothing b -> That b
|
||||
ProjectAndBranch (Just p) b -> These p b
|
||||
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
|
||||
Input.BranchSourceI'Empty -> pure Nothing
|
||||
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Just <$> ProjectUtils.resolveProjectBranchInProject (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
|
||||
|
||||
project <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
-- We can't make the *first* branch of a project with `branch`; the project has to already exist.
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
|
||||
_ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
|
||||
case maySrcProjectAndBranch of
|
||||
Just srcProjectAndBranch -> do
|
||||
let description = "Branch created from " <> into @Text (srcProjectAndBranch & bimap (view #name) (view #name))
|
||||
void $ createBranch description (CreateFrom'ParentBranch (view #branch srcProjectAndBranch)) destProject (pure newBranchName)
|
||||
Nothing -> do
|
||||
let description = "Empty branch created"
|
||||
void $ createBranch description CreateFrom'Nothingness destProject (pure newBranchName)
|
||||
|
||||
Cli.respond $
|
||||
Output.CreatedProjectBranch
|
||||
( case createFrom of
|
||||
CreateFrom'Branch sourceBranch ->
|
||||
if sourceBranch ^. #project . #projectId == project ^. #projectId
|
||||
( case maySrcProjectAndBranch of
|
||||
Just sourceBranch ->
|
||||
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
|
||||
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
||||
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
||||
CreateFrom'LooseCode path -> Output.CreatedProjectBranchFrom'LooseCode path
|
||||
CreateFrom'Nothingness -> Output.CreatedProjectBranchFrom'Nothingness
|
||||
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
||||
)
|
||||
projectAndBranchNames
|
||||
(projectAndBranchNames & #project .~ projectName)
|
||||
|
||||
-- | @doCreateBranch createFrom project branch description@:
|
||||
-- | @createBranch description createFrom project getNewBranchName@:
|
||||
--
|
||||
-- 1. Creates a new branch row for @branch@ in project @project@ (failing if @branch@ already exists in @project@)
|
||||
-- 2. Puts the branch contents from @createFrom@ in the root namespace., using @description@ for the reflog.
|
||||
-- 3. cds to the new branch in the root namespace.
|
||||
-- 1. Creates a new branch row in @project@ at the name from @getNewBranchName@ (failing if branch already exists in @project@).
|
||||
-- 2. Switches to the new branch.
|
||||
--
|
||||
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
|
||||
-- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
|
||||
--
|
||||
-- Returns the branch id of the newly-created branch.
|
||||
doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
|
||||
doCreateBranch createFrom project newBranchName description = do
|
||||
sourceNamespaceObject <-
|
||||
case createFrom of
|
||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch) -> do
|
||||
let sourceProjectId = sourceBranch ^. #projectId
|
||||
let sourceBranchId = sourceBranch ^. #branchId
|
||||
Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId))
|
||||
CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath
|
||||
CreateFrom'Nothingness -> pure Branch.empty
|
||||
let parentBranchId =
|
||||
case createFrom of
|
||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch)
|
||||
| sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId
|
||||
_ -> Nothing
|
||||
(newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description
|
||||
pure newBranchId
|
||||
|
||||
doCreateBranch' ::
|
||||
Branch IO ->
|
||||
Maybe ProjectBranchId ->
|
||||
-- Returns the branch id and name of the newly-created branch.
|
||||
createBranch ::
|
||||
Text ->
|
||||
CreateFrom ->
|
||||
Sqlite.Project ->
|
||||
Sqlite.Transaction ProjectBranchName ->
|
||||
Text ->
|
||||
Cli (ProjectBranchId, ProjectBranchName)
|
||||
doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do
|
||||
createBranch description createFrom project getNewBranchName = do
|
||||
let projectId = project ^. #projectId
|
||||
(newBranchId, newBranchName) <-
|
||||
Cli.Env {codebase} <- ask
|
||||
(mayParentBranchId, newBranchCausalHashId) <- case createFrom of
|
||||
CreateFrom'ParentBranch parentBranch -> Cli.runTransaction do
|
||||
newBranchCausalHashId <- Q.expectProjectBranchHead parentBranch.projectId parentBranch.branchId
|
||||
let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing
|
||||
pure (parentBranchId, newBranchCausalHashId)
|
||||
CreateFrom'Nothingness -> Cli.runTransaction do
|
||||
(_, causalHashId) <- Codebase.emptyCausalHash
|
||||
pure (Nothing, causalHashId)
|
||||
CreateFrom'NamespaceWithParent parentBranch namespace -> do
|
||||
liftIO $ Codebase.putBranch codebase namespace
|
||||
Cli.runTransaction $ do
|
||||
newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash namespace)
|
||||
let parentBranchId = if parentBranch.projectId == projectId then Just parentBranch.branchId else Nothing
|
||||
pure (parentBranchId, newBranchCausalHashId)
|
||||
CreateFrom'Namespace branch -> do
|
||||
liftIO $ Codebase.putBranch codebase branch
|
||||
Cli.runTransaction $ do
|
||||
newBranchCausalHashId <- Q.expectCausalHashIdByCausalHash (Branch.headHash branch)
|
||||
pure (Nothing, newBranchCausalHashId)
|
||||
(newBranchName, newBranchId) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
newBranchName <- getNewBranchName
|
||||
Queries.projectBranchExistsByName projectId newBranchName >>= \case
|
||||
@ -146,16 +132,15 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de
|
||||
-- `bar`, so the fork will succeed.
|
||||
newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
Queries.insertProjectBranch
|
||||
description
|
||||
newBranchCausalHashId
|
||||
Sqlite.ProjectBranch
|
||||
{ projectId,
|
||||
branchId = newBranchId,
|
||||
name = newBranchName,
|
||||
parentBranchId = parentBranchId
|
||||
parentBranchId = mayParentBranchId
|
||||
}
|
||||
Queries.setMostRecentBranch projectId newBranchId
|
||||
pure (newBranchId, newBranchName)
|
||||
pure (newBranchName, newBranchId)
|
||||
|
||||
let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
|
||||
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
|
||||
Cli.cd newBranchPath
|
||||
Cli.switchProject (ProjectAndBranch projectId newBranchId)
|
||||
pure (newBranchId, newBranchName)
|
||||
|
@ -7,14 +7,15 @@ where
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), classifyProjectBranchName)
|
||||
|
||||
handleBranchRename :: ProjectBranchName -> Cli ()
|
||||
handleBranchRename newBranchName = do
|
||||
(ProjectAndBranch project branch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
PP.ProjectPath project branch _path <- Cli.getCurrentProjectPath
|
||||
|
||||
case classifyProjectBranchName newBranchName of
|
||||
ProjectBranchNameKind'Contributor {} -> pure ()
|
||||
|
@ -10,14 +10,14 @@ import Network.URI (URI)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectBranchName, ProjectName)
|
||||
|
||||
handleBranches :: Maybe ProjectName -> Cli ()
|
||||
handleBranches maybeProjectName = do
|
||||
maybeCurrentProjectIds <- ProjectUtils.getCurrentProjectIds
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
(project, branches) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
project <-
|
||||
@ -26,8 +26,7 @@ handleBranches maybeProjectName = do
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
rollback (Output.LocalProjectDoesntExist projectName)
|
||||
Nothing -> do
|
||||
ProjectAndBranch projectId _ <- maybeCurrentProjectIds & onNothing (rollback Output.NotOnProjectBranch)
|
||||
Queries.expectProject projectId
|
||||
pure (pp ^. #project)
|
||||
branches <- Queries.loadAllProjectBranchInfo (project ^. #projectId)
|
||||
pure (project, branches)
|
||||
Cli.respondNumbered (Output.ListBranches (project ^. #name) (f branches))
|
||||
|
@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
handleCommitMerge :: Cli ()
|
||||
handleCommitMerge = do
|
||||
(mergeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
mergeProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||
|
||||
-- Assert that this is a "merge" branch, get its parent (which is the branch we were on when we ran `merge`),
|
||||
-- and switch to the parent.
|
||||
@ -33,9 +34,8 @@ handleCommitMerge = do
|
||||
parentBranch <-
|
||||
Cli.runTransaction do
|
||||
parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId
|
||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
||||
pure parentBranch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
|
||||
Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId)
|
||||
|
||||
-- Merge the merge branch into the parent
|
||||
|
||||
|
@ -9,6 +9,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||
@ -21,7 +22,7 @@ import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
handleCommitUpgrade :: Cli ()
|
||||
handleCommitUpgrade = do
|
||||
(upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
upgradeProjectAndBranch <- Cli.getCurrentProjectAndBranch
|
||||
|
||||
-- Assert that this is an "upgrade" branch, get its parent (which is the branch we were on when we ran `upgrade`),
|
||||
-- and switch to the parent.
|
||||
@ -33,9 +34,8 @@ handleCommitUpgrade = do
|
||||
parentBranch <-
|
||||
Cli.runTransaction do
|
||||
parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
|
||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
||||
pure parentBranch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
|
||||
Cli.switchProject (ProjectAndBranch parentBranch.projectId parentBranch.branchId)
|
||||
|
||||
-- Merge the upgrade branch into the parent
|
||||
|
||||
|
@ -0,0 +1,65 @@
|
||||
-- | @debug.synhash.term@ input handler.
|
||||
module Unison.Codebase.Editor.HandleInput.DebugSynhashTerm
|
||||
( handleDebugSynhashTerm,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.Pretty (prettyBase32Hex, prettyHash)
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.Editor.Output (Output (..))
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Hashable qualified as Hashable
|
||||
import Unison.Merge.Synhash (hashBuiltinTermTokens, hashDerivedTermTokens)
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Util.Pretty (ColorText, Pretty)
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import qualified Unison.Syntax.Name as Name
|
||||
|
||||
handleDebugSynhashTerm :: Name -> Cli ()
|
||||
handleDebugSynhashTerm name = do
|
||||
namespace <- Cli.getCurrentBranch0
|
||||
let names = Branch.toNames namespace
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
|
||||
for_ (Names.refTermsNamed names name) \ref -> do
|
||||
maybeTokens <-
|
||||
case ref of
|
||||
Reference.Builtin builtin -> pure (Just (hashBuiltinTermTokens builtin))
|
||||
Reference.DerivedId refId -> do
|
||||
env <- ask
|
||||
Cli.runTransaction (Codebase.getTerm env.codebase refId) <&> \case
|
||||
Nothing -> Nothing
|
||||
Just term -> Just (hashDerivedTermTokens pped.unsuffixifiedPPE term)
|
||||
whenJust maybeTokens \tokens -> do
|
||||
let filename = Name.toText name <> "-" <> Reference.toText ref <> "-synhash-tokens.txt"
|
||||
let renderedTokens =
|
||||
tokens
|
||||
& map prettyToken
|
||||
& Pretty.lines
|
||||
& Pretty.toAnsiUnbroken
|
||||
& Text.pack
|
||||
liftIO (Text.writeFile (Text.unpack filename) renderedTokens)
|
||||
Cli.respond (Output'DebugSynhashTerm ref (Hashable.accumulate tokens) filename)
|
||||
|
||||
prettyToken :: Hashable.Token Hash -> Pretty ColorText
|
||||
prettyToken = \case
|
||||
Hashable.Bytes bytes -> "0x" <> prettyBase32Hex (Base32Hex.fromByteString bytes)
|
||||
Hashable.Double n -> Pretty.string (show n)
|
||||
Hashable.Hashed h -> prettyHash h
|
||||
Hashable.Int n -> (if n >= 0 then "+" else mempty) <> Pretty.string (show n)
|
||||
Hashable.Nat n -> Pretty.string (show n)
|
||||
Hashable.Tag n -> "@" <> Pretty.string (show n)
|
||||
Hashable.Text s -> Pretty.string (show s)
|
@ -5,19 +5,26 @@ module Unison.Codebase.Editor.HandleInput.DeleteBranch
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.These (These (..))
|
||||
import Control.Lens
|
||||
import Data.List qualified as List
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectCreate
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
-- | Delete a project branch.
|
||||
@ -27,44 +34,64 @@ import Witch (unsafeFrom)
|
||||
-- project.
|
||||
handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleDeleteBranch projectAndBranchNamesToDelete = do
|
||||
projectAndBranchToDelete <-
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames
|
||||
case projectAndBranchNamesToDelete of
|
||||
ProjectAndBranch Nothing branch -> That branch
|
||||
ProjectAndBranch (Just project) branch -> These project branch
|
||||
|
||||
maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
|
||||
doDeleteProjectBranch projectAndBranchToDelete
|
||||
ProjectPath currentProject currentBranch _ <- Cli.getCurrentProjectPath
|
||||
projectAndBranchToDelete@(ProjectAndBranch projectOfBranchToDelete branchToDelete) <- ProjectUtils.resolveProjectBranchInProject currentProject (projectAndBranchNamesToDelete & #branch %~ Just)
|
||||
|
||||
-- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order:
|
||||
--
|
||||
-- 1. cd to parent branch, if it exists
|
||||
-- 2. cd to "main", if it exists
|
||||
-- 3. cd to loose code path `.`
|
||||
whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) ->
|
||||
when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do
|
||||
newPath <-
|
||||
case projectAndBranchToDelete.branch.parentBranchId of
|
||||
Nothing ->
|
||||
let loadMain =
|
||||
Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main")
|
||||
in Cli.runTransaction loadMain <&> \case
|
||||
Nothing -> Path.Absolute Path.empty
|
||||
Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch)
|
||||
Just parentBranchId ->
|
||||
pure $
|
||||
ProjectUtils.projectBranchPath
|
||||
(ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId)
|
||||
Cli.cd newPath
|
||||
-- 3. Any other branch in the codebase
|
||||
-- 4. Create a new branch in the current project
|
||||
when (branchToDelete ^. #branchId == currentBranch ^. #branchId) do
|
||||
mayNextLocation <-
|
||||
Cli.runTransaction . runMaybeT $
|
||||
asum
|
||||
[ parentBranch (branchToDelete ^. #projectId) (branchToDelete ^. #parentBranchId),
|
||||
findMainBranchInProjectExcept (currentProject ^. #projectId) (branchToDelete ^. #branchId),
|
||||
-- Any branch in the codebase except the one we're deleting
|
||||
findAnyBranchInProjectExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId),
|
||||
findAnyBranchInCodebaseExcept (branchToDelete ^. #projectId) (branchToDelete ^. #branchId),
|
||||
createNewBranchInProjectExcept projectOfBranchToDelete.name branchToDelete.name
|
||||
]
|
||||
|
||||
nextLoc <- mayNextLocation `whenNothing` projectCreate False Nothing
|
||||
Cli.switchProject nextLoc
|
||||
doDeleteProjectBranch projectAndBranchToDelete
|
||||
where
|
||||
parentBranch :: ProjectId -> Maybe ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
parentBranch projectId mayParentBranchId = do
|
||||
parentBranchId <- hoistMaybe mayParentBranchId
|
||||
pure (ProjectAndBranch projectId parentBranchId)
|
||||
|
||||
findMainBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
findMainBranchInProjectExcept projectId exceptBranchId = do
|
||||
branch <- MaybeT $ Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")
|
||||
guard (branch ^. #branchId /= exceptBranchId)
|
||||
pure (ProjectAndBranch projectId (branch ^. #branchId))
|
||||
|
||||
findAnyBranchInProjectExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
findAnyBranchInProjectExcept projectId exceptBranchId = do
|
||||
(someBranchId, _) <- MaybeT . fmap (List.find (\(branchId, _) -> branchId /= exceptBranchId)) $ Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
||||
pure (ProjectAndBranch projectId someBranchId)
|
||||
|
||||
findAnyBranchInCodebaseExcept :: ProjectId -> ProjectBranchId -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
findAnyBranchInCodebaseExcept exceptProjectId exceptBranchId = do
|
||||
(_, pbIds) <- MaybeT . fmap (List.find (\(_, ids) -> ids /= ProjectAndBranch exceptProjectId exceptBranchId)) $ Queries.loadAllProjectBranchNamePairs
|
||||
pure pbIds
|
||||
|
||||
createNewBranchInProjectExcept :: ProjectName -> ProjectBranchName -> MaybeT Sqlite.Transaction (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
createNewBranchInProjectExcept projectName (UnsafeProjectBranchName "main") = lift $ do
|
||||
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
|
||||
Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main2") emptyCausalHashId
|
||||
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId
|
||||
createNewBranchInProjectExcept projectName _ = lift $ do
|
||||
(_, emptyCausalHashId) <- Codebase.emptyCausalHash
|
||||
Ops.insertProjectAndBranch projectName (UnsafeProjectBranchName "main") emptyCausalHashId
|
||||
<&> \(proj, branch) -> ProjectAndBranch proj.projectId branch.branchId
|
||||
|
||||
-- | Delete a project branch and record an entry in the reflog.
|
||||
doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
|
||||
doDeleteProjectBranch :: (HasCallStack) => ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli ()
|
||||
doDeleteProjectBranch projectAndBranch = do
|
||||
Cli.runTransaction do
|
||||
Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId
|
||||
Cli.stepAt
|
||||
("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch))
|
||||
( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId),
|
||||
over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId))
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -0,0 +1,15 @@
|
||||
module Unison.Codebase.Editor.HandleInput.LSPDebug (debugLspNameCompletion) where
|
||||
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output (Output (DisplayDebugLSPNameCompletions))
|
||||
import Unison.LSP.Completion qualified as Completion
|
||||
import Unison.Prelude
|
||||
|
||||
debugLspNameCompletion :: Text -> Cli ()
|
||||
debugLspNameCompletion prefix = do
|
||||
names <- Cli.currentNames
|
||||
let ct = Completion.namesToCompletionTree names
|
||||
let (_, matches) = Completion.completionsForQuery ct prefix
|
||||
Cli.respond $ DisplayDebugLSPNameCompletions matches
|
@ -78,7 +78,7 @@ loadUnisonFile sourceName text = do
|
||||
Text ->
|
||||
Cli (TypecheckedUnisonFile Symbol Ann)
|
||||
withFile names sourceName text = do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
State.modify' \loopState ->
|
||||
loopState
|
||||
& #latestFile .~ Just (Text.unpack sourceName, False)
|
||||
@ -88,7 +88,7 @@ loadUnisonFile sourceName text = do
|
||||
let parsingEnv =
|
||||
Parser.ParsingEnv
|
||||
{ uniqueNames = uniqueName,
|
||||
uniqueTypeGuid = Cli.loadUniqueTypeGuid currentPath,
|
||||
uniqueTypeGuid = Cli.loadUniqueTypeGuid pp,
|
||||
names
|
||||
}
|
||||
unisonFile <-
|
||||
|
@ -8,9 +8,11 @@ import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
@ -18,9 +20,9 @@ import Unison.Server.Backend qualified as Backend
|
||||
handleLs :: Path' -> Cli ()
|
||||
handleLs pathArg = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
pathArgAbs <- Cli.resolvePath' pathArg
|
||||
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
|
||||
pp <- Cli.resolvePath' pathArg
|
||||
projectRootBranch <- Cli.runTransaction $ Codebase.expectShallowProjectBranchRoot pp.branch
|
||||
entries <- liftIO (Backend.lsAtPath codebase projectRootBranch (pp.absPath))
|
||||
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
|
@ -1,3 +1,4 @@
|
||||
-- | @merge@ input handler.
|
||||
module Unison.Codebase.Editor.HandleInput.Merge2
|
||||
( handleMerge,
|
||||
|
||||
@ -8,6 +9,9 @@ module Unison.Codebase.Editor.HandleInput.Merge2
|
||||
LcaMergeInfo (..),
|
||||
doMerge,
|
||||
doMergeLocalBranch,
|
||||
|
||||
-- * API exported for @todo@
|
||||
hasDefnsInLib,
|
||||
)
|
||||
where
|
||||
|
||||
@ -65,6 +69,8 @@ import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath (ProjectPathG (..))
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
|
||||
@ -85,6 +91,7 @@ import Unison.Merge.EitherWay (EitherWay (..))
|
||||
import Unison.Merge.EitherWayI (EitherWayI (..))
|
||||
import Unison.Merge.EitherWayI qualified as EitherWayI
|
||||
import Unison.Merge.Libdeps qualified as Merge
|
||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
|
||||
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
|
||||
import Unison.Merge.Synhashed (Synhashed (..))
|
||||
import Unison.Merge.Synhashed qualified as Synhashed
|
||||
@ -138,12 +145,12 @@ import Unison.Util.SyntaxText (SyntaxText')
|
||||
import Unison.Var (Var)
|
||||
import Witch (unsafeFrom)
|
||||
import Prelude hiding (unzip, zip, zipWith)
|
||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
|
||||
|
||||
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
|
||||
-- Assert that Alice (us) is on a project branch, and grab the causal hash.
|
||||
(aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
ProjectPath aliceProject aliceProjectBranch _path <- Cli.getCurrentProjectPath
|
||||
let aliceProjectAndBranch = ProjectAndBranch aliceProject aliceProjectBranch
|
||||
|
||||
-- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch
|
||||
-- name, and causal hash.
|
||||
@ -193,7 +200,6 @@ doMerge info = do
|
||||
then realDebugFunctions
|
||||
else fakeDebugFunctions
|
||||
|
||||
let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch)
|
||||
let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch
|
||||
let mergeSource = MergeSourceOrTarget'Source info.bob.source
|
||||
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
|
||||
@ -210,7 +216,7 @@ doMerge info = do
|
||||
-- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
|
||||
when (info.lca.causalHash == Just info.alice.causalHash) do
|
||||
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
|
||||
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
|
||||
_ <- Cli.updateAt info.description (PP.projectBranchRoot info.alice.projectAndBranch) (\_aliceBranch -> bobBranch)
|
||||
done (Output.MergeSuccessFastForward mergeSourceAndTarget)
|
||||
|
||||
-- Create a bunch of cached database lookup functions
|
||||
@ -238,11 +244,7 @@ doMerge info = do
|
||||
|
||||
-- Assert that neither Alice nor Bob have defns in lib
|
||||
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
|
||||
libdeps <-
|
||||
case Map.lookup NameSegment.libSegment branch.children of
|
||||
Nothing -> pure V2.Branch.empty
|
||||
Just libdeps -> Cli.runTransaction libdeps.value
|
||||
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
|
||||
whenM (Cli.runTransaction (hasDefnsInLib branch)) do
|
||||
done (Output.MergeDefnsInLib who)
|
||||
|
||||
-- Load Alice/Bob/LCA definitions and decl name lookups
|
||||
@ -397,7 +399,7 @@ doMerge info = do
|
||||
in if thisMergeHasConflicts
|
||||
then pure Nothing
|
||||
else do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
currentPath <- Cli.getCurrentProjectPath
|
||||
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
||||
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
||||
|
||||
@ -408,12 +410,12 @@ doMerge info = do
|
||||
Nothing -> do
|
||||
Cli.Env {writeSource} <- ask
|
||||
(_temporaryBranchId, temporaryBranchName) <-
|
||||
HandleInput.Branch.doCreateBranch'
|
||||
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
||||
(Just info.alice.projectAndBranch.branch.branchId)
|
||||
HandleInput.Branch.createBranch
|
||||
info.description
|
||||
(HandleInput.Branch.CreateFrom'NamespaceWithParent info.alice.projectAndBranch.branch (Branch.mergeNode stageOneBranch parents.alice parents.bob))
|
||||
info.alice.projectAndBranch.project
|
||||
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||
info.description
|
||||
|
||||
scratchFilePath <-
|
||||
Cli.getLatestFile <&> \case
|
||||
Nothing -> "scratch.u"
|
||||
@ -423,11 +425,10 @@ doMerge info = do
|
||||
Just tuf -> do
|
||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||
_ <-
|
||||
Cli.updateAt
|
||||
info.description
|
||||
alicePath
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
Cli.updateProjectBranchRoot_
|
||||
info.alice.projectAndBranch.branch
|
||||
info.description
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
pure (Output.MergeSuccess mergeSourceAndTarget)
|
||||
|
||||
Cli.respond finalOutput
|
||||
@ -436,8 +437,8 @@ doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
|
||||
doMergeLocalBranch branches = do
|
||||
(aliceCausalHash, bobCausalHash, lcaCausalHash) <-
|
||||
Cli.runTransaction do
|
||||
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice)
|
||||
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob)
|
||||
aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.alice ^. #branch)
|
||||
bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (branches.bob ^. #branch)
|
||||
-- Using Alice and Bob's causal hashes, find the LCA (if it exists)
|
||||
lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash
|
||||
pure (aliceCausalHash, bobCausalHash, lcaCausalHash)
|
||||
@ -485,6 +486,17 @@ loadLibdeps branches = do
|
||||
libdepsBranch <- libdepsCausal.value
|
||||
pure libdepsBranch.children
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Merge precondition violation checks
|
||||
|
||||
hasDefnsInLib :: Applicative m => V2.Branch m -> m Bool
|
||||
hasDefnsInLib branch = do
|
||||
libdeps <-
|
||||
case Map.lookup NameSegment.libSegment branch.children of
|
||||
Nothing -> pure V2.Branch.empty
|
||||
Just libdeps -> libdeps.value
|
||||
pure (not (Map.null libdeps.terms) || not (Map.null libdeps.types))
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Creating Unison files
|
||||
|
||||
|
@ -23,5 +23,6 @@ handleMoveAll hasConfirmed src' dest' description = do
|
||||
case (moveBranchFunc, moveTermTypeSteps) of
|
||||
(Nothing, []) -> Cli.respond (Output.MoveNothingFound src')
|
||||
(mupdates, steps) -> do
|
||||
Cli.updateAndStepAt description (maybeToList mupdates) steps
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Cli.updateAndStepAt description (pp ^. #branch) (maybeToList mupdates) steps
|
||||
Cli.respond Output.Success
|
||||
|
@ -7,17 +7,21 @@ import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Output (Output (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Note: Currently only allows moving within the same project-branch, should be easy to change in the future if
|
||||
-- needed.
|
||||
moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
|
||||
moveBranchFunc hasConfirmed src' dest' = do
|
||||
srcAbs <- Cli.resolvePath' src'
|
||||
destAbs <- Cli.resolvePath' dest'
|
||||
-- We currently only support moving within the same project branch.
|
||||
srcPP@(PP.ProjectPath _proj _projBranch srcAbs) <- Cli.resolvePath' src'
|
||||
PP.ProjectPath _ _ destAbs <- Cli.resolvePath' dest'
|
||||
destBranchExists <- Cli.branchExistsAtPath' dest'
|
||||
let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
|
||||
when (isRootMove && not hasConfirmed) do
|
||||
Cli.returnEarly MoveRootBranchConfirmation
|
||||
Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
|
||||
Cli.getMaybeBranchFromProjectPath srcPP >>= traverse \srcBranch -> do
|
||||
-- We want the move to appear as a single step in the root namespace, but we need to make
|
||||
-- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
|
||||
-- those changes such that they appear as a single change in the root.
|
||||
@ -37,6 +41,7 @@ doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
|
||||
doMoveBranch actionDescription hasConfirmed src' dest' = do
|
||||
moveBranchFunc hasConfirmed src' dest' >>= \case
|
||||
Nothing -> Cli.respond (BranchNotFound src')
|
||||
Just (path, func) -> do
|
||||
_ <- Cli.updateAt actionDescription path func
|
||||
Just (absPath, func) -> do
|
||||
pp <- Cli.resolvePath' (Path.AbsolutePath' absPath)
|
||||
_ <- Cli.updateAt actionDescription pp func
|
||||
Cli.respond Success
|
||||
|
@ -1,6 +1,6 @@
|
||||
module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where
|
||||
|
||||
import Control.Lens (_2)
|
||||
import Control.Lens (_1, _2)
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch0)
|
||||
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path, Path')
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.HashQualifiedPrime qualified as HQ'
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
|
||||
moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
|
||||
moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
moveTermSteps src' dest' = do
|
||||
src <- Cli.resolveSplit' src'
|
||||
srcTerms <- Cli.getTermsAt src
|
||||
@ -29,11 +30,11 @@ moveTermSteps src' dest' = do
|
||||
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
|
||||
when (not (Set.null destTerms)) do
|
||||
Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
|
||||
let p = first Path.unabsolute src
|
||||
let p = src & _1 %~ view PP.absPath_
|
||||
pure
|
||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||
BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm
|
||||
BranchUtil.makeAddTermName (over _1 (view PP.absPath_) dest) srcTerm
|
||||
]
|
||||
|
||||
doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||
@ -41,5 +42,6 @@ doMoveTerm src' dest' description = do
|
||||
steps <- moveTermSteps src' dest'
|
||||
when (null steps) do
|
||||
Cli.returnEarly (Output.TermNotFound src')
|
||||
Cli.stepManyAt description steps
|
||||
pb <- Cli.getCurrentProjectBranch
|
||||
Cli.stepManyAt pb description steps
|
||||
Cli.respond Output.Success
|
||||
|
@ -1,6 +1,6 @@
|
||||
module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where
|
||||
|
||||
import Control.Lens (_2)
|
||||
import Control.Lens (_1, _2)
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -9,13 +9,14 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch0)
|
||||
import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path, Path')
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.HashQualifiedPrime qualified as HQ'
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
|
||||
moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
|
||||
moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path.Absolute, Branch0 m -> Branch0 m)]
|
||||
moveTypeSteps src' dest' = do
|
||||
src <- Cli.resolveSplit' src'
|
||||
srcTypes <- Cli.getTypesAt src
|
||||
@ -29,11 +30,11 @@ moveTypeSteps src' dest' = do
|
||||
destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
|
||||
when (not (Set.null destTypes)) do
|
||||
Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
|
||||
let p = first Path.unabsolute src
|
||||
let p = over _1 (view PP.absPath_) src
|
||||
pure
|
||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||
BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
|
||||
BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType
|
||||
BranchUtil.makeAddTypeName (over _1 (view PP.absPath_) dest) srcType
|
||||
]
|
||||
|
||||
doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||
@ -41,5 +42,6 @@ doMoveType src' dest' description = do
|
||||
steps <- moveTypeSteps src' dest'
|
||||
when (null steps) do
|
||||
Cli.returnEarly (Output.TypeNotFound src')
|
||||
Cli.stepManyAt description steps
|
||||
pb <- Cli.getCurrentProjectBranch
|
||||
Cli.stepManyAt pb description steps
|
||||
Cli.respond Output.Success
|
||||
|
@ -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,
|
||||
|
@ -36,7 +36,7 @@ diffHelper before after =
|
||||
Cli.Env {codebase} <- ask
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
diff <- liftIO (BranchDiff.diff0 before after)
|
||||
names <- Cli.currentNames
|
||||
names <- Cli.currentNames <&> \currentNames -> currentNames <> Branch.toNames before <> Branch.toNames after
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
fmap (suffixifiedPPE,) do
|
||||
|
@ -5,24 +5,21 @@ module Unison.Codebase.Editor.HandleInput.ProjectClone
|
||||
where
|
||||
|
||||
import Control.Lens (_2)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.These (These (..))
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
|
||||
import U.Codebase.Sqlite.DbId qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (updateAt)
|
||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch)
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, projectNameUserSlug)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -39,9 +36,9 @@ data RemoteProjectKey
|
||||
-- | Clone a remote branch.
|
||||
handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
|
||||
handleClone remoteNames0 maybeLocalNames0 = do
|
||||
maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
|
||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
|
||||
localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||
currentProjectBranch <- Cli.getCurrentProjectAndBranch
|
||||
resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead currentProjectBranch remoteNames0
|
||||
localNames1 <- resolveLocalNames currentProjectBranch resolvedRemoteNames maybeLocalNames0
|
||||
cloneInto localNames1 resolvedRemoteNames.branch
|
||||
|
||||
data ResolvedRemoteNames = ResolvedRemoteNames
|
||||
@ -78,63 +75,59 @@ data ResolvedRemoteNamesFrom
|
||||
-- otherwise abort
|
||||
resolveRemoteNames ::
|
||||
Share.IncludeSquashedHead ->
|
||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
||||
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||
ProjectAndBranchNames ->
|
||||
Cli ResolvedRemoteNames
|
||||
resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
||||
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
|
||||
case maybeCurrentProjectBranch of
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just (currentProjectAndBranch, _path) ->
|
||||
case projectNameUserSlug remoteProjectName of
|
||||
Nothing -> resolveB remoteBranchName
|
||||
Just _ ->
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just remoteBranchProjectId -> do
|
||||
-- Fetching these in parallel would be an improvement
|
||||
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
||||
maybeRemoteBranch <-
|
||||
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
||||
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||
(Just remoteProject, Nothing) -> do
|
||||
let remoteProjectId = remoteProject.projectId
|
||||
let remoteProjectName = remoteProject.projectName
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Project
|
||||
}
|
||||
(Nothing, Just remoteBranch) ->
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Branch
|
||||
}
|
||||
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
||||
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
||||
-- wouldn't help, because we did enough work to know neither thing exists"
|
||||
_ -> do
|
||||
branchProjectName <-
|
||||
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneRemote
|
||||
remoteProjectName
|
||||
(ProjectAndBranch branchProjectName remoteBranchName)
|
||||
resolveRemoteNames includeSquashed currentProjectAndBranch = \case
|
||||
ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName -> do
|
||||
case projectNameUserSlug remoteProjectName of
|
||||
Nothing -> resolveB remoteBranchName
|
||||
Just _ ->
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) >>= \case
|
||||
Nothing -> resolveP remoteProjectName
|
||||
Just remoteBranchProjectId -> do
|
||||
-- Fetching these in parallel would be an improvement
|
||||
maybeRemoteProject <- Share.getProjectByName remoteProjectName
|
||||
maybeRemoteBranch <-
|
||||
Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
|
||||
Share.GetProjectBranchResponseBranchNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseProjectNotFound -> Nothing
|
||||
Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
|
||||
case (maybeRemoteProject, maybeRemoteBranch) of
|
||||
(Just remoteProject, Nothing) -> do
|
||||
let remoteProjectId = remoteProject.projectId
|
||||
let remoteProjectName = remoteProject.projectName
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
includeSquashed
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Project
|
||||
}
|
||||
(Nothing, Just remoteBranch) ->
|
||||
pure
|
||||
ResolvedRemoteNames
|
||||
{ branch = remoteBranch,
|
||||
from = ResolvedRemoteNamesFrom'Branch
|
||||
}
|
||||
-- Treat neither existing and both existing uniformly as "ambiguous input"
|
||||
-- Alternatively, if neither exist, we could instead say "although your input was ambiguous, disambuating
|
||||
-- wouldn't help, because we did enough work to know neither thing exists"
|
||||
_ -> do
|
||||
branchProjectName <-
|
||||
Cli.runTransaction (Queries.expectRemoteProjectName remoteBranchProjectId Share.hardCodedUri)
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneRemote
|
||||
remoteProjectName
|
||||
(ProjectAndBranch branchProjectName remoteBranchName)
|
||||
ProjectAndBranchNames'Unambiguous (This p) -> resolveP p
|
||||
ProjectAndBranchNames'Unambiguous (That b) -> resolveB b
|
||||
ProjectAndBranchNames'Unambiguous (These p b) -> resolvePB p b
|
||||
where
|
||||
resolveB branchName = do
|
||||
(currentProjectAndBranch, _path) <- maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
remoteProjectId <-
|
||||
Cli.runTransaction (loadAssociatedRemoteProjectId currentProjectAndBranch) & onNothingM do
|
||||
Cli.returnEarly (Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri currentProjectAndBranch)
|
||||
@ -181,11 +174,11 @@ resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
|
||||
-- `clone @foo/bar` resulted in treating `@foo/bar` as a contributor branch of the current project, then it is as if
|
||||
-- the user typed `clone /@foo/bar` instead, which is equivalent to the two-arg `clone /@foo/bar /@foo/bar`.
|
||||
resolveLocalNames ::
|
||||
Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
|
||||
(ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ->
|
||||
ResolvedRemoteNames ->
|
||||
Maybe ProjectAndBranchNames ->
|
||||
Cli (ProjectAndBranch LocalProjectKey ProjectBranchName)
|
||||
resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames =
|
||||
resolveLocalNames (ProjectAndBranch currentProject _) resolvedRemoteNames maybeLocalNames =
|
||||
resolve case maybeLocalNames of
|
||||
Nothing ->
|
||||
ProjectAndBranchNames'Unambiguous case resolvedRemoteNames.from of
|
||||
@ -199,14 +192,11 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
|
||||
resolve names =
|
||||
case names of
|
||||
ProjectAndBranchNames'Ambiguous localProjectName localBranchName ->
|
||||
case maybeCurrentProjectBranch of
|
||||
Nothing -> resolveP localProjectName
|
||||
Just (ProjectAndBranch currentProject _, _path) -> do
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneLocal
|
||||
(ProjectAndBranch localProjectName remoteBranchName)
|
||||
(ProjectAndBranch currentProject.name localBranchName)
|
||||
ProjectAndBranchNames'Ambiguous localProjectName localBranchName -> do
|
||||
Cli.returnEarly $
|
||||
Output.AmbiguousCloneLocal
|
||||
(ProjectAndBranch localProjectName remoteBranchName)
|
||||
(ProjectAndBranch currentProject.name localBranchName)
|
||||
ProjectAndBranchNames'Unambiguous (This localProjectName) -> resolveP localProjectName
|
||||
ProjectAndBranchNames'Unambiguous (That localBranchName) -> resolveB localBranchName
|
||||
ProjectAndBranchNames'Unambiguous (These localProjectName localBranchName) -> resolvePB localProjectName localBranchName
|
||||
@ -215,8 +205,6 @@ resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames
|
||||
go (LocalProjectKey'Name localProjectName) remoteBranchName
|
||||
|
||||
resolveB localBranchName = do
|
||||
(ProjectAndBranch currentProject _, _path) <-
|
||||
maybeCurrentProjectBranch & onNothing (Cli.returnEarly Output.NotOnProjectBranch)
|
||||
go (LocalProjectKey'Project currentProject) localBranchName
|
||||
|
||||
resolvePB localProjectName localBranchName =
|
||||
@ -254,7 +242,11 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
pure (localProjectId, localProjectName)
|
||||
Right localProject -> pure (localProject.projectId, localProject.name)
|
||||
localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
causalHashId <- Q.expectCausalHashIdByCausalHash branchHead
|
||||
let description = "Cloned from " <> into @Text (ProjectAndBranch remoteProjectName remoteBranchName)
|
||||
Queries.insertProjectBranch
|
||||
description
|
||||
causalHashId
|
||||
Sqlite.ProjectBranch
|
||||
{ projectId = localProjectId,
|
||||
branchId = localBranchId,
|
||||
@ -277,12 +269,8 @@ cloneInto localProjectBranch remoteProjectBranch = do
|
||||
localProjectBranch.branch
|
||||
)
|
||||
|
||||
-- Manipulate the root namespace and cd
|
||||
Cli.Env {codebase} <- ask
|
||||
theBranch <- liftIO (Codebase.expectBranchForHash codebase branchHead)
|
||||
let path = projectBranchPath (over #project fst localProjectAndBranch)
|
||||
Cli.updateAt ("clone " <> into @Text remoteProjectBranchNames) path (const theBranch)
|
||||
Cli.cd path
|
||||
let newProjectAndBranch = (over #project fst localProjectAndBranch)
|
||||
Cli.switchProject newProjectAndBranch
|
||||
|
||||
-- Return the remote project id associated with the given project branch
|
||||
loadAssociatedRemoteProjectId ::
|
||||
|
@ -4,23 +4,23 @@ module Unison.Codebase.Editor.HandleInput.ProjectCreate
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import System.Random.Shuffle qualified as RandomShuffle
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash)
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli (stepAt)
|
||||
import Unison.Cli.ProjectUtils (projectBranchPath)
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Causal qualified as Causal
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
@ -55,14 +55,12 @@ import Witch (unsafeFrom)
|
||||
--
|
||||
-- For now, it doesn't seem worth it to do (1) or (2), since we want to do (3) eventually, and we'd rather not waste too
|
||||
-- much time getting everything perfectly correct before we get there.
|
||||
projectCreate :: Bool -> Maybe ProjectName -> Cli ()
|
||||
projectCreate :: Bool -> Maybe ProjectName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
|
||||
projectCreate tryDownloadingBase maybeProjectName = do
|
||||
projectId <- liftIO (ProjectId <$> UUID.nextRandom)
|
||||
branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom)
|
||||
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
(_, emptyCausalHashId) <- Cli.runTransaction Codebase.emptyCausalHash
|
||||
|
||||
projectName <-
|
||||
(project, branch) <-
|
||||
case maybeProjectName of
|
||||
Nothing -> do
|
||||
randomProjectNames <- liftIO generateRandomProjectNames
|
||||
@ -70,23 +68,21 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
let loop = \case
|
||||
[] -> error (reportBug "E066388" "project name supply is supposed to be infinite")
|
||||
projectName : projectNames ->
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
True -> loop projectNames
|
||||
Queries.loadProjectByName projectName >>= \case
|
||||
Nothing -> do
|
||||
(project, branch) <- Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||
pure (project, branch)
|
||||
Just _project -> loop projectNames
|
||||
loop randomProjectNames
|
||||
Just projectName -> do
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
Ops.insertProjectAndBranch projectName branchName emptyCausalHashId
|
||||
True -> rollback (Output.ProjectNameAlreadyExists projectName)
|
||||
|
||||
let path = projectBranchPath ProjectAndBranch {project = projectId, branch = branchId}
|
||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) projectName)
|
||||
Cli.cd path
|
||||
Cli.respond (Output.CreatedProject (isNothing maybeProjectName) project.name)
|
||||
Cli.switchProject (ProjectAndBranch project.projectId branch.branchId)
|
||||
|
||||
maybeBaseLatestReleaseBranchObject <-
|
||||
if tryDownloadingBase
|
||||
@ -126,30 +122,29 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
pure maybeBaseLatestReleaseBranchObject
|
||||
else pure Nothing
|
||||
|
||||
let projectBranchObject =
|
||||
case maybeBaseLatestReleaseBranchObject of
|
||||
Nothing -> Branch.empty0
|
||||
Just baseLatestReleaseBranchObject ->
|
||||
let -- lib.base
|
||||
projectBranchLibBaseObject =
|
||||
over
|
||||
Branch.children
|
||||
(Map.insert NameSegment.baseSegment baseLatestReleaseBranchObject)
|
||||
Branch.empty0
|
||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||
in over
|
||||
Branch.children
|
||||
(Map.insert NameSegment.libSegment projectBranchLibObject)
|
||||
Branch.empty0
|
||||
|
||||
Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject)
|
||||
for_ maybeBaseLatestReleaseBranchObject \baseLatestReleaseBranchObject -> do
|
||||
-- lib.base
|
||||
let projectBranchLibBaseObject =
|
||||
Branch.empty0
|
||||
& Branch.children
|
||||
. at NameSegment.baseSegment
|
||||
.~ Just baseLatestReleaseBranchObject
|
||||
projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty
|
||||
let branchWithBase =
|
||||
Branch.empty
|
||||
& Branch.history
|
||||
. Causal.head_
|
||||
. Branch.children
|
||||
. at NameSegment.libSegment
|
||||
.~ Just projectBranchLibObject
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ Codebase.putBranch codebase branchWithBase
|
||||
Cli.runTransaction $ do
|
||||
baseBranchCausalHashId <- expectCausalHashIdByCausalHash (Branch.headHash branchWithBase)
|
||||
Queries.setProjectBranchHead "Include latest base library" project.projectId branch.branchId baseBranchCausalHashId
|
||||
|
||||
Cli.respond Output.HappyCoding
|
||||
where
|
||||
reflogDescription =
|
||||
case maybeProjectName of
|
||||
Nothing -> "project.create"
|
||||
Just projectName -> "project.create " <> into @Text projectName
|
||||
pure ProjectAndBranch {project = project.projectId, branch = branch.branchId}
|
||||
|
||||
-- An infinite list of random project names that looks like
|
||||
--
|
||||
|
@ -4,21 +4,22 @@ module Unison.Codebase.Editor.HandleInput.ProjectRename
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
|
||||
handleProjectRename :: ProjectName -> Cli ()
|
||||
handleProjectRename newName = do
|
||||
project <- ProjectUtils.expectCurrentProject
|
||||
let oldName = project ^. #name
|
||||
ProjectAndBranch project _branch <- Cli.getCurrentProjectAndBranch
|
||||
let oldName = project.name
|
||||
when (oldName /= newName) do
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.loadProjectByName newName >>= \case
|
||||
Just _ -> rollback (Output.ProjectNameAlreadyExists newName)
|
||||
Nothing -> Queries.renameProject (project ^. #projectId) newName
|
||||
Nothing -> Queries.renameProject project.projectId newName
|
||||
Cli.respond (Output.RenamedProject oldName newName)
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user