mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
⅄ trunk → 22-10-19-syntax-name
This commit is contained in:
commit
8e6dbc1351
@ -41,6 +41,7 @@ dependencies:
|
||||
- errors
|
||||
- exceptions
|
||||
- extra
|
||||
- filelock
|
||||
- filepath
|
||||
- fingertree
|
||||
- fsnotify
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
110
parser-typechecker/src/Unison/Codebase/RootBranchCache.hs
Normal 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
|
@ -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
|
||||
|
@ -6,6 +6,7 @@ import Unison.CodebasePath (CodebasePath)
|
||||
|
||||
data GitSqliteCodebaseError
|
||||
= GitCouldntParseRootBranchHash ReadGitRepo String
|
||||
| CodebaseFileLockFailed
|
||||
| NoDatabaseFile ReadGitRepo CodebasePath
|
||||
| UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion
|
||||
| CodebaseRequiresMigration SchemaVersion SchemaVersion
|
||||
|
@ -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.
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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")
|
||||
|
@ -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"
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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) =
|
||||
|
@ -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
39
unison-cli/unison/Stats.hs
Normal 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,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"]
|
||||
|
@ -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
25
unison-src/transcripts/update-ignores-lib-namespace.md
Normal 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
|
||||
```
|
@ -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.
|
||||
|
||||
```
|
Loading…
Reference in New Issue
Block a user