unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

⅄ trunk → 22-10-19-syntax-name

Browse Source
This commit is contained in:
Mitchell Rosen 2022-11-29 16:07:49 -05:00
commit 8e6dbc1351
27 changed files with 449 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
parser-typechecker/package.yaml
View File

@ -41,6 +41,7 @@ dependencies:
- errors
- exceptions
- extra
- filelock
- filepath
- fingertree
- fsnotify

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

@ -329,7 +329,7 @@ getTypeOfConstructor codebase (ConstructorReference r0 cid) =
-- MaybeT (getWatch codebase RegularWatch ref)
-- <|> MaybeT (getWatch codebase TestWatch ref))
-- @
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference.Id -> m (Maybe (Term v a))
lookupWatchCache :: Codebase m v a -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a))
lookupWatchCache codebase h = do
m1 <- getWatch codebase WK.RegularWatch h
maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1

47
parser-typechecker/src/Unison/Codebase/Init.hs
View File

@ -6,6 +6,7 @@ module Unison.Codebase.Init
DebugName,
InitError (..),
CodebaseInitOptions (..),
CodebaseLockOption (..),
InitResult (..),
SpecifiedCodebase (..),
MigrationStrategy (..),
@ -42,6 +43,10 @@ data SpecifiedCodebase
= CreateWhenMissing CodebasePath
| DontCreateWhenMissing CodebasePath
data CodebaseLockOption
= DoLock
| DontLock
data MigrationStrategy
= -- | Perform a migration immediately if one is required.
MigrateAutomatically
@ -60,9 +65,9 @@ type DebugName = String
data Init m v a = Init
{ -- | open an existing codebase
withOpenCodebase :: forall r. DebugName -> CodebasePath -> MigrationStrategy -> (Codebase m v a -> m r) -> m (Either OpenCodebaseError r),
withOpenCodebase :: forall r. DebugName -> CodebasePath -> CodebaseLockOption -> MigrationStrategy -> (Codebase m v a -> m r) -> m (Either OpenCodebaseError r),
-- | create a new codebase
withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
withCreatedCodebase :: forall r. DebugName -> CodebasePath -> CodebaseLockOption -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
-- | given a codebase root, and given that the codebase root may have other junk in it,
-- give the path to the "actual" files; e.g. what a forked transcript should clone.
codebasePath :: CodebasePath -> CodebasePath
@ -85,10 +90,11 @@ createCodebaseWithResult ::
Init m v a ->
DebugName ->
CodebasePath ->
CodebaseLockOption ->
(Codebase m v a -> m r) ->
m (Either (CodebasePath, InitError) r)
createCodebaseWithResult cbInit debugName dir action =
createCodebase cbInit debugName dir action <&> mapLeft \case
createCodebaseWithResult cbInit debugName dir lockOption action =
createCodebase cbInit debugName dir lockOption action <&> mapLeft \case
errorMessage -> (dir, (CouldntCreateCodebase errorMessage))
withOpenOrCreateCodebase ::
@ -96,12 +102,13 @@ withOpenOrCreateCodebase ::
Init m v a ->
DebugName ->
CodebaseInitOptions ->
CodebaseLockOption ->
MigrationStrategy ->
((InitResult, CodebasePath, Codebase m v a) -> m r) ->
m (Either (CodebasePath, InitError) r)
withOpenOrCreateCodebase cbInit debugName initOptions migrationStrategy action = do
withOpenOrCreateCodebase cbInit debugName initOptions lockOption migrationStrategy action = do
let resolvedPath = initOptionsToDir initOptions
result <- withOpenCodebase cbInit debugName resolvedPath migrationStrategy \codebase -> do
result <- withOpenCodebase cbInit debugName resolvedPath lockOption migrationStrategy \codebase -> do
action (OpenedCodebase, resolvedPath, codebase)
case result of
Right r -> pure $ Right r
@ -114,7 +121,7 @@ withOpenOrCreateCodebase cbInit debugName initOptions migrationStrategy action =
(do pure (Left (homeDir, FoundV1Codebase)))
( do
-- Create V2 codebase if neither a V1 or V2 exists
createCodebaseWithResult cbInit debugName homeDir (\codebase -> action (CreatedCodebase, homeDir, codebase))
createCodebaseWithResult cbInit debugName homeDir lockOption (\codebase -> action (CreatedCodebase, homeDir, codebase))
)
Specified specified ->
ifM
@ -124,14 +131,15 @@ withOpenOrCreateCodebase cbInit debugName initOptions migrationStrategy action =
DontCreateWhenMissing dir ->
pure (Left (dir, (InitErrorOpen OpenCodebaseDoesntExist)))
CreateWhenMissing dir ->
createCodebaseWithResult cbInit debugName dir (\codebase -> action (CreatedCodebase, dir, codebase))
createCodebaseWithResult cbInit debugName dir lockOption (\codebase -> action (CreatedCodebase, dir, codebase))
OpenCodebaseUnknownSchemaVersion {} -> pure (Left (resolvedPath, InitErrorOpen err))
OpenCodebaseRequiresMigration {} -> pure (Left (resolvedPath, InitErrorOpen err))
OpenCodebaseFileLockFailed {} -> pure (Left (resolvedPath, InitErrorOpen err))
createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r)
createCodebase cbInit debugName path action = do
createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> CodebaseLockOption -> (Codebase m v a -> m r) -> m (Either Pretty r)
createCodebase cbInit debugName path lockOption action = do
prettyDir <- P.string <$> canonicalizePath path
withCreatedCodebase cbInit debugName path action <&> mapLeft \case
withCreatedCodebase cbInit debugName path lockOption action <&> mapLeft \case
CreateCodebaseAlreadyExists ->
P.wrap $
"It looks like there's already a codebase in: "
@ -141,30 +149,31 @@ createCodebase cbInit debugName path action = do
-- previously: initCodebaseOrExit :: CodebasePath -> m (m (), Codebase m v a)
-- previously: FileCodebase.initCodebase :: CodebasePath -> m (m (), Codebase m v a)
withNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> (Codebase m Symbol Ann -> m r) -> m r
withNewUcmCodebaseOrExit cbInit debugName path action = do
withNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> CodebaseLockOption -> (Codebase m Symbol Ann -> m r) -> m r
withNewUcmCodebaseOrExit cbInit debugName path lockOption action = do
prettyDir <- P.string <$> canonicalizePath path
let codebaseSetup codebase = do
liftIO $ PT.putPrettyLn' . P.wrap $ "Initializing a new codebase in: " <> prettyDir
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
createCodebase cbInit debugName path (\cb -> codebaseSetup cb *> action cb)
createCodebase cbInit debugName path lockOption (\cb -> codebaseSetup cb *> action cb)
>>= \case
Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure
Right result -> pure result
-- | try to init a codebase where none exists and then exit regardless (i.e. `ucm --codebase dir init`)
initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m ()
initCodebaseAndExit i debugName mdir = do
initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> CodebaseLockOption -> m ()
initCodebaseAndExit i debugName mdir lockOption = do
codebaseDir <- Codebase.getCodebaseDir mdir
withNewUcmCodebaseOrExit i debugName codebaseDir (const $ pure ())
withNewUcmCodebaseOrExit i debugName codebaseDir lockOption (const $ pure ())
withTemporaryUcmCodebase ::
MonadUnliftIO m =>
Init m Symbol Ann ->
DebugName ->
CodebaseLockOption ->
((CodebasePath, Codebase m Symbol Ann) -> m r) ->
m r
withTemporaryUcmCodebase cbInit debugName action = do
withTemporaryUcmCodebase cbInit debugName lockOption action = do
UnliftIO.withSystemTempDirectory debugName $ \tempDir -> do
withNewUcmCodebaseOrExit cbInit debugName tempDir $ \codebase -> do
withNewUcmCodebaseOrExit cbInit debugName tempDir lockOption $ \codebase -> do
action (tempDir, codebase)

1
parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs
View File

@ -15,6 +15,7 @@ data OpenCodebaseError
OpenCodebaseDoesntExist
| -- | The codebase exists, but its schema version is unknown to this application.
OpenCodebaseUnknownSchemaVersion SchemaVersion
| OpenCodebaseFileLockFailed
| -- | The codebase exists, but requires a migration before it can be used.
OpenCodebaseRequiresMigration
-- current version

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

@ -0,0 +1,110 @@
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 qualified Unison.Sqlite 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

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

@ -9,6 +9,7 @@
module Unison.Codebase.SqliteCodebase
( Unison.Codebase.SqliteCodebase.init,
MigrationStrategy (..),
CodebaseLockOption (..),
)
where
@ -23,6 +24,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Time (getCurrentTime)
import qualified System.Console.ANSI as ANSI
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
import qualified System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import qualified U.Codebase.Branch as V2Branch
@ -48,12 +50,13 @@ import Unison.Codebase.Editor.RemoteRepo
writeToReadGit,
)
import qualified Unison.Codebase.GitError as GitError
import Unison.Codebase.Init (MigrationStrategy (..))
import Unison.Codebase.Init (CodebaseLockOption (..), MigrationStrategy (..))
import qualified Unison.Codebase.Init as Codebase
import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1
import Unison.Codebase.Path (Path)
import Unison.Codebase.RootBranchCache
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
@ -106,13 +109,14 @@ withOpenOrCreateCodebase ::
Codebase.DebugName ->
CodebasePath ->
LocalOrRemote ->
CodebaseLockOption ->
MigrationStrategy ->
((CodebaseStatus, Codebase m Symbol Ann) -> m r) ->
m (Either Codebase1.OpenCodebaseError r)
withOpenOrCreateCodebase debugName codebasePath localOrRemote migrationStrategy action = do
createCodebaseOrError debugName codebasePath (action' CreatedCodebase) >>= \case
withOpenOrCreateCodebase debugName codebasePath localOrRemote lockOption migrationStrategy action = do
createCodebaseOrError debugName codebasePath lockOption (action' CreatedCodebase) >>= \case
Left (Codebase1.CreateCodebaseAlreadyExists) -> do
sqliteCodebase debugName codebasePath localOrRemote migrationStrategy (action' ExistingCodebase)
sqliteCodebase debugName codebasePath localOrRemote lockOption migrationStrategy (action' ExistingCodebase)
Right r -> pure (Right r)
where
action' openOrCreate codebase = action (openOrCreate, codebase)
@ -122,9 +126,10 @@ createCodebaseOrError ::
(MonadUnliftIO m) =>
Codebase.DebugName ->
CodebasePath ->
CodebaseLockOption ->
(Codebase m Symbol Ann -> m r) ->
m (Either Codebase1.CreateCodebaseError r)
createCodebaseOrError debugName path action = do
createCodebaseOrError debugName path lockOption action = do
ifM
(doesFileExist $ makeCodebasePath path)
(pure $ Left Codebase1.CreateCodebaseAlreadyExists)
@ -136,7 +141,7 @@ createCodebaseOrError debugName path action = do
Q.createSchema
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
sqliteCodebase debugName path Local DontMigrate action >>= \case
sqliteCodebase debugName path Local lockOption DontMigrate action >>= \case
Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.")
Right result -> pure (Right result)
@ -147,13 +152,14 @@ withCodebaseOrError ::
(MonadUnliftIO m) =>
Codebase.DebugName ->
CodebasePath ->
CodebaseLockOption ->
MigrationStrategy ->
(Codebase m Symbol Ann -> m r) ->
m (Either Codebase1.OpenCodebaseError r)
withCodebaseOrError debugName dir migrationStrategy action = do
withCodebaseOrError debugName dir lockOption migrationStrategy action = do
doesFileExist (makeCodebasePath dir) >>= \case
False -> pure (Left Codebase1.OpenCodebaseDoesntExist)
True -> sqliteCodebase debugName dir Local migrationStrategy action
True -> sqliteCodebase debugName dir Local lockOption migrationStrategy action
initSchemaIfNotExist :: MonadIO m => FilePath -> m ()
initSchemaIfNotExist path = liftIO do
@ -187,11 +193,12 @@ sqliteCodebase ::
CodebasePath ->
-- | When local, back up the existing codebase before migrating, in case there's a catastrophic bug in the migration.
LocalOrRemote ->
CodebaseLockOption ->
MigrationStrategy ->
(Codebase m Symbol Ann -> m r) ->
m (Either Codebase1.OpenCodebaseError r)
sqliteCodebase debugName root localOrRemote migrationStrategy action = do
rootBranchCache <- newTVarIO Nothing
sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action = handleLockOption do
rootBranchCache <- newEmptyRootBranchCacheIO
branchCache <- newBranchCache
getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
-- The v1 codebase interface has operations to read and write individual definitions
@ -268,21 +275,36 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
getShallowCausalForHash bh =
V2Branch.hoistCausalBranch runTransaction <$> runTransaction (Ops.expectCausalBranchByCausalHash bh)
getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m)
getRootBranch rootBranchCache =
Branch.transform runTransaction <$> runTransaction (CodebaseOps.getRootBranch branchCache getDeclType rootBranchCache)
getRootBranch :: m (Branch m)
getRootBranch =
Branch.transform runTransaction
<$> fetchRootBranch
rootBranchCache
(runTransaction (CodebaseOps.uncachedLoadRootBranch branchCache getDeclType))
putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Text -> Branch m -> m ()
putRootBranch rootBranchCache reason branch1 = do
putRootBranch :: Text -> Branch m -> m ()
putRootBranch reason branch1 = do
now <- liftIO getCurrentTime
withRunInIO \runInIO -> do
runInIO do
runTransaction do
let emptyCausalHash = Cv.causalHash1to2 $ Branch.headHash Branch.empty
fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash
let toRootCausalHash = Cv.causalHash1to2 $ Branch.headHash branch1
CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1)
Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason})
-- 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 = Cv.causalHash1to2 (Branch.headHash Branch.empty)
fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash
let toRootCausalHash = Cv.causalHash1to2 (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.
@ -314,9 +336,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
Sqlite.runWriteTransaction destConn \runDest -> do
syncInternal (syncProgress progressStateRef) runSrc runDest b
getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann))
getWatch k r =
runTransaction (CodebaseOps.getWatch getDeclType k r)
getWatch :: UF.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term Symbol Ann))
getWatch =
CodebaseOps.getWatch getDeclType
termsOfTypeImpl :: Reference -> m (Set Referent.Id)
termsOfTypeImpl r =
@ -348,8 +370,8 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
putTypeDeclaration,
putTypeDeclarationComponent,
getTermComponentWithTypes,
getRootBranch = getRootBranch rootBranchCache,
putRootBranch = putRootBranch rootBranchCache,
getRootBranch = getRootBranch,
putRootBranch = putRootBranch,
getShallowCausalForHash,
getBranchForHashImpl = getBranchForHash,
putBranch,
@ -375,6 +397,13 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
runTransaction action =
withConn \conn -> Sqlite.runTransaction conn action
handleLockOption ma = case lockOption of
DontLock -> ma
DoLock -> withRunInIO \runInIO ->
withTryFileLock (lockfilePath root) Exclusive (\_flock -> runInIO ma) <&> \case
Nothing -> Left OpenCodebaseFileLockFailed
Just x -> x
syncInternal ::
forall m.
MonadUnliftIO m =>
@ -567,7 +596,7 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior act
then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath))
else throwIO exception
result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote MigrateAfterPrompt \codebase -> do
result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote DoLock MigrateAfterPrompt \codebase -> do
-- try to load the requested branch from it
branch <- time "Git fetch (sch)" $ case sch of
-- no sub-branch was specified, so use the root.
@ -617,7 +646,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = Unlif
-- set up the cache dir
throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do
newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo)
. withOpenOrCreateCodebase "push.dest" (Git.gitDirToPath pushStaging) Remote MigrateAfterPrompt
. withOpenOrCreateCodebase "push.dest" (Git.gitDirToPath pushStaging) Remote DoLock MigrateAfterPrompt
$ \(codebaseStatus, destCodebase) -> do
currentRootBranch <-
Codebase1.runTransaction destCodebase CodebaseOps.getRootBranchExists >>= \case
@ -696,9 +725,10 @@ pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = Unlif
-- so we have to convert our expected path to test.
posixCodebasePath =
FilePath.Posix.joinPath (FilePath.splitDirectories codebasePath)
posixLockfilePath = FilePath.replaceExtension posixCodebasePath "lockfile"
statusLines = Text.unpack <$> Text.lines status
t = dropWhile Char.isSpace
okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath = True
okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath || p == posixLockfilePath = True
okLine (t -> 'M' : (t -> p)) | p == posixCodebasePath = True
okLine line = isWalDelete line || isShmDelete line
isWalDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True

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

@ -6,6 +6,7 @@ import Unison.CodebasePath (CodebasePath)
data GitSqliteCodebaseError
= GitCouldntParseRootBranchHash ReadGitRepo String
| CodebaseFileLockFailed
| NoDatabaseFile ReadGitRepo CodebasePath
| UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion
| CodebaseRequiresMigration SchemaVersion SchemaVersion

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

@ -8,14 +8,13 @@
module Unison.Codebase.SqliteCodebase.Operations where
import Control.Lens (ifor)
import Data.Bifunctor (second)
import Data.Maybe (fromJust)
import Data.Bitraversable (bitraverse)
import Data.Either.Extra ()
import qualified Data.List as List
import qualified Data.List.NonEmpty as NEList
import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified U.Codebase.Branch as V2Branch
@ -377,36 +376,6 @@ tryFlushDeclBuffer termBuffer declBuffer =
h
in loop
getRootBranch ::
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
BranchCache Sqlite.Transaction ->
(C.Reference.Reference -> Transaction CT.ConstructorType) ->
TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) ->
Transaction (Branch Transaction)
getRootBranch branchCache doGetDeclType rootBranchCache =
Sqlite.unsafeIO (readTVarIO rootBranchCache) >>= \case
Nothing -> forceReload
Just (v, b) -> do
-- check to see if root namespace hash has been externally modified
-- and reload it if necessary
v' <- Sqlite.getDataVersion
if v == v'
then pure b
else do
newRootHash <- Ops.expectRootCausalHash
if Branch.headHash b == Cv.causalHash2to1 newRootHash
then pure b
else do
traceM $ "database was externally modified (" ++ show v ++ " -> " ++ show v' ++ ")"
forceReload
where
forceReload :: Transaction (Branch Transaction)
forceReload = do
branch1 <- uncachedLoadRootBranch branchCache doGetDeclType
ver <- Sqlite.getDataVersion
Sqlite.unsafeIO (atomically (writeTVar rootBranchCache (Just (ver, branch1))))
pure branch1
uncachedLoadRootBranch ::
BranchCache Sqlite.Transaction ->
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
@ -420,12 +389,11 @@ getRootBranchExists :: Transaction Bool
getRootBranchExists =
isJust <$> Ops.loadRootCausalHash
putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Branch Transaction -> Transaction ()
putRootBranch rootBranchCache branch1 = do
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))
Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1))
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
-- to one that returns Maybe.

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

@ -3,6 +3,7 @@ module Unison.Codebase.SqliteCodebase.Paths
makeCodebasePath,
makeCodebaseDirPath,
backupCodebasePath,
lockfilePath,
)
where
@ -18,6 +19,9 @@ codebasePath = ".unison" </> "v2" </> "unison.sqlite3"
makeCodebasePath :: CodebasePath -> FilePath
makeCodebasePath root = makeCodebaseDirPath root </> "unison.sqlite3"
lockfilePath :: CodebasePath -> FilePath
lockfilePath root = makeCodebaseDirPath root </> "unison.lockfile"
-- | Makes a path to the location where sqlite files are stored within a codebase path.
makeCodebaseDirPath :: CodebasePath -> FilePath
makeCodebaseDirPath root = root </> ".unison" </> "v2"

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

@ -97,7 +97,7 @@ data Codebase m v a = Codebase
-- | Push the given branch to the given repo, and optionally set it as the root branch.
pushGitBranch :: forall e. WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
-- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@.
getWatch :: WK.WatchKind -> Reference.Id -> m (Maybe (Term v a)),
getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
-- | Get the set of user-defined terms-or-constructors that have the given type.
termsOfTypeImpl :: Reference -> m (Set Referent.Id),
-- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature.
@ -159,3 +159,4 @@ gitErrorFromOpenCodebaseError path repo = \case
UnrecognizedSchemaVersion repo path (fromIntegral v)
OpenCodebaseRequiresMigration fromSv toSv ->
CodebaseRequiresMigration fromSv toSv
OpenCodebaseFileLockFailed -> CodebaseFileLockFailed

20
parser-typechecker/tests/Unison/Test/CodebaseInit.hs
View File

@ -29,7 +29,7 @@ test =
[ scope "a v2 codebase should be opened" do
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithCodebase
r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) CI.DontMigrate \case
r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) CI.DontLock CI.DontMigrate \case
(CI.OpenedCodebase, _, _) -> pure True
_ -> pure False
case r of
@ -38,7 +38,7 @@ test =
scope "a v2 codebase should be created when one does not exist" do
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithoutCodebase
r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) CI.DontMigrate \case
r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) CI.DontLock CI.DontMigrate \case
(CI.CreatedCodebase, _, _) -> pure True
_ -> pure False
case r of
@ -51,7 +51,7 @@ test =
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithCodebase
res <- io $
CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) CI.DontMigrate $ \case
CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) CI.DontLock CI.DontMigrate $ \case
(CI.OpenedCodebase, _, _) -> pure True
_ -> pure False
case res of
@ -61,7 +61,7 @@ test =
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithoutCodebase
res <- io $
CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) CI.DontMigrate $ \case
CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) CI.DontLock CI.DontMigrate $ \case
_ -> pure False
case res of
Left (_, CI.InitErrorOpen OpenCodebaseDoesntExist) -> expect True
@ -72,7 +72,7 @@ test =
[ scope "a v2 codebase should be created when one does not exist at the Specified dir" do
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithoutCodebase
res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) CI.DontMigrate \case
res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) CI.DontLock CI.DontMigrate \case
(CI.CreatedCodebase, _, _) -> pure True
_ -> pure False
case res of
@ -81,7 +81,7 @@ test =
scope "a v2 codebase should be opened when one exists" do
tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
cbInit <- io initMockWithCodebase
res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) CI.DontMigrate \case
res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) CI.DontLock CI.DontMigrate \case
(CI.OpenedCodebase, _, _) -> pure True
_ -> pure False
case res of
@ -98,9 +98,9 @@ initMockWithCodebase = do
pure $
Init
{ -- withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
withOpenCodebase = \_ _ _ action -> Right <$> action codebase,
withOpenCodebase = \_ _ _ _ action -> Right <$> action codebase,
-- withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
withCreatedCodebase = \_ _ action -> Right <$> action codebase,
withCreatedCodebase = \_ _ _ action -> Right <$> action codebase,
-- CodebasePath -> CodebasePath
codebasePath = id
}
@ -110,9 +110,9 @@ initMockWithoutCodebase = do
let codebase = error "did we /actually/ need a Codebase?"
pure $
Init
{ withOpenCodebase = \_ _ _ _ -> pure (Left OpenCodebaseDoesntExist),
{ withOpenCodebase = \_ _ _ _ _ -> pure (Left OpenCodebaseDoesntExist),
-- withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
withCreatedCodebase = \_ _ action -> Right <$> action codebase,
withCreatedCodebase = \_ _ _ action -> Right <$> action codebase,
-- CodebasePath -> CodebasePath
codebasePath = id
}

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

@ -59,6 +59,7 @@ library
Unison.Codebase.Path
Unison.Codebase.Path.Parse
Unison.Codebase.PushBehavior
Unison.Codebase.RootBranchCache
Unison.Codebase.Runtime
Unison.Codebase.Serialization
Unison.Codebase.ShortCausalHash
@ -208,6 +209,7 @@ library
, errors
, exceptions
, extra
, filelock
, filepath
, fingertree
, free
@ -392,6 +394,7 @@ test-suite parser-typechecker-tests
, errors
, exceptions
, extra
, filelock
, filemanip
, filepath
, fingertree

2
unison-cli/package.yaml
View File

@ -119,7 +119,7 @@ executables:
other-modules: Paths_unison_cli
source-dirs: unison
main: Main.hs
ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1" -optP-Wno-nonportable-include-path
ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
dependencies:
- code-page
- optparse-applicative >= 0.16.1.0

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

@ -2038,7 +2038,7 @@ handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do
fmap Map.fromList do
Set.toList testRefs & wither \case
Reference.Builtin _ -> pure Nothing
r@(Reference.DerivedId rid) -> liftIO (fmap (r,) <$> Codebase.getWatch codebase WK.TestWatch rid)
r@(Reference.DerivedId rid) -> fmap (r,) <$> Cli.runTransaction (Codebase.getWatch codebase WK.TestWatch rid)
let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests)
names <-
makePrintNamesFromLabeled' $
@ -3205,7 +3205,7 @@ evalUnisonFile sandbox ppe unisonFile args = do
let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
watchCache ref = do
maybeTerm <- Codebase.lookupWatchCache codebase ref
maybeTerm <- Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase ref)
pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm)
Cli.with_ (withArgs args) do
@ -3231,7 +3231,7 @@ evalUnisonTermE sandbox ppe useCache tm = do
let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
watchCache ref = do
maybeTerm <- Codebase.lookupWatchCache codebase ref
maybeTerm <- Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase ref)
pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm)
let cache = if useCache then watchCache else Runtime.noCache

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

@ -36,13 +36,14 @@ import qualified Unison.DataDeclaration as Decl
import Unison.FileParsers (synthesizeFile')
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment)
import Unison.Names (Names)
import qualified Unison.Names as Names
import Unison.Parser.Ann (Ann (..))
import Unison.Prelude
import Unison.Reference (Reference (..))
import Unison.Reference (Reference (..), TermReference, TypeReference)
import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
@ -58,6 +59,7 @@ import Unison.UnisonFile (UnisonFile (..))
import qualified Unison.UnisonFile as UF
import Unison.Util.Monoid (foldMapM)
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Set as Set
import qualified Unison.Util.Star3 as Star3
import Unison.Util.TransitiveClosure (transitiveClosure)
import Unison.Var (Var)
@ -240,14 +242,7 @@ propagate patch b = case validatePatch patch of
-- TODO: this can be removed once patches have term replacement of type `Referent -> Referent`
rootNames <- Branch.toNames <$> Cli.getRootBranch0
let entireBranch =
Set.union
(Branch.deepTypeReferences b)
( Set.fromList
[r | Referent.Ref r <- Set.toList $ Branch.deepReferents b]
)
-- TODO: these are just used for tracing, could be deleted if we don't care
let -- TODO: these are just used for tracing, could be deleted if we don't care
-- about printing meaningful names for definitions during propagation, or if
-- we want to just remove the tracing.
refName r =
@ -270,7 +265,8 @@ propagate patch b = case validatePatch patch of
computeDirty
(Codebase.dependents Queries.ExcludeOwnComponent)
patch
(Names.contains names0)
-- Dirty reference predicate: does the reference have a name in this branch that isn't in the "lib" namespace?
(Names.contains (Names.filter nameNotInLibNamespace (Branch.toNames b)))
let initialTypeReplacements = Map.mapMaybe TypeEdit.toReference initialTypeEdits
-- TODO: once patches can directly contain constructor replacements, this
@ -278,7 +274,16 @@ propagate patch b = case validatePatch patch of
-- in the patch which have a `Referent.Con` as their LHS.
initialCtorMappings <- genInitialCtorMapping rootNames initialTypeReplacements
order <- sortDependentsGraph initialDirty entireBranch
order <-
let restrictToTypes :: Set TypeReference
restrictToTypes =
R.dom (R.filterRan nameNotInLibNamespace (Branch.deepTypes b))
restrictToTerms :: Set TermReference
restrictToTerms =
Set.mapMaybe Referent.toTermReference (R.dom (R.filterRan nameNotInLibNamespace (Branch.deepTerms b)))
in sortDependentsGraph
initialDirty
(Set.union restrictToTypes restrictToTerms)
let getOrdered :: Set Reference -> Map Int Reference
getOrdered rs =
@ -478,7 +483,6 @@ propagate patch b = case validatePatch patch of
(zip (view _1 . getReference <$> Graph.topSort graph) [0 ..])
-- vertex i precedes j whenever i has an edge to j and not vice versa.
-- vertex i precedes j when j is a dependent of i.
names0 = Branch.toNames b
validatePatch ::
Patch -> Maybe (Map Reference TermEdit, Map Reference TypeEdit)
validatePatch p =
@ -600,12 +604,20 @@ applyDeprecations patch =
-- | Things in the patch are not marked as propagated changes, but every other
-- definition that is created by the `Edits` which is passed in is marked as
-- a propagated change.
applyPropagate :: Applicative m => Patch -> Edits Symbol -> Branch0 m -> Branch0 m
applyPropagate :: forall m. Applicative m => Patch -> Edits Symbol -> Branch0 m -> Branch0 m
applyPropagate patch Edits {newTerms, termReplacements, typeReplacements, constructorReplacements} = do
let termTypes = Map.map (Hashing.typeToReference . snd) newTerms
-- recursively update names and delete deprecated definitions
Branch.stepEverywhere (updateLevel termReplacements typeReplacements termTypes)
stepEverywhereButLib (updateLevel termReplacements typeReplacements termTypes)
where
-- Like Branch.stepEverywhere, but don't step the child named "lib"
stepEverywhereButLib :: (Branch0 m -> Branch0 m) -> (Branch0 m -> Branch0 m)
stepEverywhereButLib f branch =
let children =
Map.mapWithKey
(\name child -> if name == "lib" then child else Branch.step (Branch.stepEverywhere f) child)
(branch ^. Branch.children)
in f (Branch.branch0 (branch ^. Branch.terms) (branch ^. Branch.types) children (branch ^. Branch.edits))
isPropagated r = Set.notMember r allPatchTargets
allPatchTargets = Patch.allReferenceTargets patch
propagatedMd :: forall r. r -> (r, Metadata.Type, Metadata.Value)
@ -678,11 +690,9 @@ applyPropagate patch Edits {newTerms, termReplacements, typeReplacements, constr
-- | Compute the set of "dirty" references. They each:
--
-- 1. Depend directly on some reference that was edited in the given patch
-- 2. Have a name in the current namespace (the given Names)
-- 3. Are not themselves edited in the given patch.
--
-- Note: computeDirty a b c = R.dom <$> computeFrontier a b c
-- 1. Depend directly on some reference that was edited in the given patch
-- 2. Are not themselves edited in the given patch.
-- 3. Pass the given predicate.
computeDirty ::
Monad m =>
(Reference -> m (Set Reference)) -> -- eg Codebase.dependents codebase
@ -699,3 +709,7 @@ computeDirty getDependents patch shouldUpdate =
edited :: Set Reference
edited = R.dom (Patch._termEdits patch) <> R.dom (Patch._typeEdits patch)
nameNotInLibNamespace :: Name -> Bool
nameNotInLibNamespace name =
not (Name.beginsWithSegment name "lib")

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

@ -1140,6 +1140,9 @@ notifyUser dir o = case o of
else pure mempty
GitError e -> pure $ case e of
GitSqliteCodebaseError e -> case e of
CodebaseFileLockFailed ->
P.wrap $
"It looks to me like another ucm process is using this codebase. Only one ucm process can use a codebase at a time."
NoDatabaseFile repo localPath ->
P.wrap $
"I didn't find a codebase in the repository at"

7
unison-cli/tests/Unison/Test/GitSync.hs
View File

@ -513,9 +513,10 @@ test =
|]
)
( \cb -> do
void . fmap (fromJust . sequence) $
traverse (Codebase.getWatch cb TestWatch)
=<< Codebase.runTransaction cb (Codebase.watches TestWatch)
Codebase.runTransaction cb do
void . fmap (fromJust . sequence) $
traverse (Codebase.getWatch cb TestWatch)
=<< Codebase.watches TestWatch
),
gistTest fmt,
pushPullBranchesTests fmt,

6
unison-cli/tests/Unison/Test/Ucm.hs
View File

@ -53,7 +53,7 @@ initCodebase fmt = do
tmp <-
Temp.getCanonicalTemporaryDirectory
>>= flip Temp.createTempDirectory "ucm-test"
result <- Codebase.Init.withCreatedCodebase cbInit "ucm-test" tmp (const $ pure ())
result <- Codebase.Init.withCreatedCodebase cbInit "ucm-test" tmp SC.DoLock (const $ pure ())
case result of
Left CreateCodebaseAlreadyExists -> fail $ P.toANSI 80 "Codebase already exists"
Right _ -> pure $ Codebase tmp fmt
@ -66,7 +66,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
let err e = fail $ "Parse error: \n" <> show e
cbInit = case fmt of CodebaseFormat2 -> SC.init
TR.withTranscriptRunner "Unison.Test.Ucm.runTranscript Invalid Version String" configFile $ \runner -> do
result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DontMigrate \codebase -> do
result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
let transcriptSrc = Text.pack . stripMargin $ unTranscript transcript
output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
@ -81,7 +81,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a
lowLevel (Codebase root fmt) action = do
let cbInit = case fmt of CodebaseFormat2 -> SC.init
result <- Codebase.Init.withOpenCodebase cbInit "lowLevel" root SC.DontMigrate action
result <- Codebase.Init.withOpenCodebase cbInit "lowLevel" root SC.DoLock SC.DontMigrate action
case result of
Left e -> PT.putPrettyLn (P.shown e) *> pure (error "This really should have loaded")
Right a -> pure a

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

@ -34,7 +34,7 @@ type TestBuilder = FilePath -> [String] -> String -> Test ()
testBuilder ::
Bool -> FilePath -> [String] -> String -> Test ()
testBuilder expectFailure dir prelude transcript = scope transcript $ do
outputs <- io . withTemporaryUcmCodebase SC.init "transcript" $ \(codebasePath, codebase) -> do
outputs <- io . withTemporaryUcmCodebase SC.init "transcript" SC.DoLock $ \(codebasePath, codebase) -> do
withTranscriptRunner "TODO: pass version here" Nothing $ \runTranscript -> do
for files $ \filePath -> do
transcriptSrc <- readUtf8 filePath

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

@ -454,6 +454,7 @@ executable unison
main-is: Main.hs
other-modules:
ArgParse
Stats
System.Path
Version
hs-source-dirs:
@ -488,7 +489,7 @@ executable unison
TupleSections
TypeApplications
ViewPatterns
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1" -optP-Wno-nonportable-include-path
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1 -T" -optP-Wno-nonportable-include-path
build-depends:
IntervalMap
, ListLike

18
unison-cli/unison/ArgParse.hs
View File

@ -53,6 +53,7 @@ import qualified Options.Applicative as OptParse
import Options.Applicative.Builder.Internal (noGlobal {- https://github.com/pcapriotti/optparse-applicative/issues/461 -})
import Options.Applicative.Help (bold, (<+>))
import qualified Options.Applicative.Help.Pretty as P
import Stats
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
import qualified Unison.Codebase.Path as Path
@ -116,7 +117,7 @@ data Command
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
Init
| Run RunSource [String]
| Transcript ShouldForkCodebase ShouldSaveCodebase (NonEmpty FilePath)
| Transcript ShouldForkCodebase ShouldSaveCodebase (Maybe RtsStatsPath) (NonEmpty FilePath)
deriving (Show, Eq)
-- | Options shared by sufficiently many subcommands.
@ -381,6 +382,15 @@ runCompiledParser :: Parser Command
runCompiledParser =
Run . RunCompiled <$> fileArgument "path/to/file" <*> runArgumentParser
rtsStatsOption :: Parser (Maybe RtsStatsPath)
rtsStatsOption =
let meta =
metavar "FILE.json"
<> long "rts-stats"
<> help "Write json summary of rts stats to FILE"
<> noGlobal
in optional (option OptParse.str meta)
saveCodebaseFlag :: Parser ShouldSaveCodebase
saveCodebaseFlag = flag DontSaveCodebase SaveCodebase (long "save-codebase" <> help saveHelp)
where
@ -448,15 +458,17 @@ transcriptParser :: Parser Command
transcriptParser = do
-- ApplicativeDo
shouldSaveCodebase <- saveCodebaseFlag
mrtsStatsFp <- rtsStatsOption
files <- liftA2 (NE.:|) (fileArgument "FILE") (many (fileArgument "FILES..."))
pure (Transcript DontFork shouldSaveCodebase files)
pure (Transcript DontFork shouldSaveCodebase mrtsStatsFp files)
transcriptForkParser :: Parser Command
transcriptForkParser = do
-- ApplicativeDo
shouldSaveCodebase <- saveCodebaseFlag
mrtsStatsFp <- rtsStatsOption
files <- liftA2 (NE.:|) (fileArgument "FILE") (many (fileArgument "FILES..."))
pure (Transcript UseFork shouldSaveCodebase files)
pure (Transcript UseFork shouldSaveCodebase mrtsStatsFp files)
unisonHelp :: String -> String -> P.Doc
unisonHelp (P.text -> executable) (P.text -> version) =

19
unison-cli/unison/Main.hs
View File

@ -42,6 +42,7 @@ import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import Stats (recordRtsStats)
import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
import System.Environment (getProgName, lookupEnv, withArgs)
import qualified System.Exit as Exit
@ -246,8 +247,11 @@ main = withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
"to produce a new compiled program \
\that matches your version of Unison."
]
Transcript shouldFork shouldSaveCodebase transcriptFiles ->
runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
Transcript shouldFork shouldSaveCodebase mrtsStatsFp transcriptFiles -> do
let action = runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
case mrtsStatsFp of
Nothing -> action
Just fp -> recordRtsStats fp action
Launch isHeadless codebaseServerOpts downloadBase mayStartingPath shouldWatchFiles -> do
getCodebaseOrExit mCodePathOption SC.MigrateAfterPrompt \(initRes, _, theCodebase) -> do
runtime <- RTI.startRuntime False RTI.Persistent Version.gitDescribeWithDate
@ -336,7 +340,7 @@ prepareTranscriptDir shouldFork mCodePathOption = do
Path.copyDir (CodebaseInit.codebasePath cbInit path) (CodebaseInit.codebasePath cbInit tmp)
DontFork -> do
PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase."
CodebaseInit.withNewUcmCodebaseOrExit cbInit "main.transcript" tmp (const $ pure ())
CodebaseInit.withNewUcmCodebaseOrExit cbInit "main.transcript" tmp SC.DoLock (const $ pure ())
pure tmp
runTranscripts' ::
@ -516,7 +520,7 @@ defaultBaseLib =
getCodebaseOrExit :: Maybe CodebasePathOption -> SC.MigrationStrategy -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
getCodebaseOrExit codebasePathOption migrationStrategy action = do
initOptions <- argsToCodebaseInitOptions codebasePathOption
result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions migrationStrategy \case
result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions SC.DoLock migrationStrategy \case
cbInit@(CreatedCodebase, dir, _) -> do
pDir <- prettyDir dir
PT.putPrettyLn' ""
@ -535,6 +539,13 @@ getCodebaseOrExit codebasePathOption migrationStrategy action = do
case err of
InitErrorOpen err ->
case err of
OpenCodebaseFileLockFailed ->
pure
( P.lines
[ "Failed to obtain a file lock on the codebase. ",
"Perhaps you are running multiple ucm processes against the same codebase."
]
)
OpenCodebaseDoesntExist ->
pure
( P.lines

39
unison-cli/unison/Stats.hs Normal file
View File

@ -0,0 +1,39 @@
module Stats
( RtsStatsPath (..),
recordRtsStats,
)
where
import Control.Exception (finally)
import Data.Aeson (encode, object, (.=))
import qualified Data.ByteString.Lazy as BL
import Data.Function
import Data.String (IsString)
import GHC.Stats
newtype RtsStatsPath
= RtsStatsPath FilePath
deriving stock (Show, Eq)
deriving newtype (IsString)
recordRtsStats :: RtsStatsPath -> IO a -> IO a
recordRtsStats (RtsStatsPath fp) action = do
r0 <- getRTSStats
action `finally` do
r1 <- getRTSStats
BL.writeFile fp (encode (produceStats r0 r1))
where
produceStats r0 r1 =
object
[ "gcs" .= on (-) gcs r1 r0,
"major_gcs" .= on (-) major_gcs r1 r0,
"allocated_bytes" .= on (-) allocated_bytes r1 r0,
"max_live_bytes" .= on (-) max_live_bytes r1 r0,
"copied_bytes" .= on (-) copied_bytes r1 r0,
"mutator_cpu_ns" .= on (-) mutator_cpu_ns r1 r0,
"mutator_elapsed_ns" .= on (-) mutator_elapsed_ns r1 r0,
"gc_cpu_ns" .= on (-) mutator_cpu_ns r1 r0,
"gc_elapsed_ns" .= on (-) mutator_elapsed_ns r1 r0,
"cpu_ns" .= on (-) cpu_ns r1 r0,
"elapsed_ns" .= on (-) cpu_ns r1 r0
]

14
unison-core/src/Unison/Name.hs
View File

@ -14,6 +14,7 @@ module Unison.Name
countSegments,
isAbsolute,
isPrefixOf,
beginsWithSegment,
endsWithReverseSegments,
endsWithSegments,
stripReversedPrefix,
@ -118,6 +119,19 @@ countSegments :: Name -> Int
countSegments (Name _ ss) =
length ss
-- | @beginsWithSegment name segment@ returns whether @name@'s first name segment is @segment@.
--
-- >>> beginsWithSegment "abc.def" "abc"
-- True
--
-- >>> beginsWithSegment "abc.def" "ab"
-- False
--
-- /O(n)/, where /n/ is the number of name segments.
beginsWithSegment :: Name -> NameSegment -> Bool
beginsWithSegment name segment =
segment == List.NonEmpty.head (segments name)
-- | @endsWithSegments x y@ returns whether @x@ ends with @y@.
--
-- >>> endsWithSegments "a.b.c" ["b", "c"]

2
unison-share-api/src/Unison/Server/Backend.hs
View File

@ -982,7 +982,7 @@ renderDoc ppe width rt codebase r = do
eval (Term.amap (const mempty) -> tm) = do
let ppes = PPED.suffixifiedPPE ppe
let codeLookup = Codebase.toCodeLookup codebase
let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r
let cache r = fmap Term.unannotate <$> Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase r)
r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm
case r of
Just tmr ->

25
unison-src/transcripts/update-ignores-lib-namespace.md Normal file
View File

@ -0,0 +1,25 @@
`update` / `patch` (anything that a patch) ignores the namespace named "lib" at the location it's applied. This follows
the project organization convention that dependencies are put in "lib"; it's much easier to apply a patch to all of
one's own code if the "lib" namespace is simply ignored.
```ucm:hide
.> builtins.merge
```
```unison
foo = 100
lib.foo = 100
```
```ucm
.> add
```
```unison
foo = 200
```
```ucm
.> update
.> names foo
```

66
unison-src/transcripts/update-ignores-lib-namespace.output.md Normal file
View File

@ -0,0 +1,66 @@
`update` / `patch` (anything that a patch) ignores the namespace named "lib" at the location it's applied. This follows
the project organization convention that dependencies are put in "lib"; it's much easier to apply a patch to all of
one's own code if the "lib" namespace is simply ignored.
```unison
foo = 100
lib.foo = 100
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These new definitions are ok to `add`:
foo : Nat
lib.foo : Nat
```
```ucm
.> add
⍟ I've added these definitions:
foo : Nat
lib.foo : Nat
```
```unison
foo = 200
```
```ucm
I found and typechecked these definitions in scratch.u. If you
do an `add` or `update`, here's how your codebase would
change:
⍟ These names already exist. You can `update` them to your
new definition:
foo : Nat
(The old definition is also named lib.foo. I'll update
this name too.)
```
```ucm
.> update
⍟ I've updated these names to your new definition:
foo : Nat
(The old definition was also named lib.foo. I updated this
name too.)
.> names foo
Term
Hash: #9ntnotdp87
Names: foo
Tip: Use `names.global` to see more results.
```