{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}

module Unison.Codebase.SqliteCodebase
  ( Unison.Codebase.SqliteCodebase.init,
    Unison.Codebase.SqliteCodebase.initWithSetup,
    MigrationStrategy (..),
    BackupStrategy (..),
    VacuumStrategy (..),
    CodebaseLockOption (..),
    copyCodebase,
  )
where

import Data.Either.Extra ()
import Data.Map qualified as Map
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase (Codebase, CodebasePath)
import Unison.Codebase qualified as Codebase1
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Init (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..))
import Unison.Codebase.Init qualified as Codebase
import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
import Unison.Codebase.SqliteCodebase.Paths
import Unison.Codebase.Type (LocalOrRemote (..))
import Unison.Codebase.Type qualified as C
import Unison.DataDeclaration (Decl)
import Unison.Hash (Hash)
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Reference (Reference, TermReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.ShortHash (ShortHash)
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Util.Cache qualified as Cache
import Unison.WatchKind qualified as UF
import UnliftIO (finally)
import UnliftIO qualified as UnliftIO
import UnliftIO.Concurrent qualified as UnliftIO
import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist)
import UnliftIO.STM

debug :: Bool
debug :: Bool
debug = Bool
False

init ::
  (HasCallStack, MonadUnliftIO m) =>
  Codebase.Init m Symbol Ann
init :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m) =>
Init m Symbol Ann
init = Transaction () -> Init m Symbol Ann
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m) =>
Transaction () -> Init m Symbol Ann
initWithSetup (() -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Like 'init', but allows passing in an action to be perform when a new codebase is created.
initWithSetup ::
  (HasCallStack, MonadUnliftIO m) =>
  -- Action to perform when a new codebase is created.
  -- It's run after the schema is created in the same transaction.
  Sqlite.Transaction () ->
  Codebase.Init m Symbol Ann
initWithSetup :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m) =>
Transaction () -> Init m Symbol Ann
initWithSetup Transaction ()
onCreate =
  Codebase.Init
    { $sel:withOpenCodebase:Init :: forall r.
DebugName
-> DebugName
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
withOpenCodebase = DebugName
-> DebugName
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
forall r.
DebugName
-> DebugName
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
forall (m :: * -> *) r.
MonadUnliftIO m =>
DebugName
-> DebugName
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
withCodebaseOrError,
      $sel:withCreatedCodebase:Init :: forall r.
DebugName
-> DebugName
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m (Either CreateCodebaseError r)
withCreatedCodebase = Transaction ()
-> DebugName
-> DebugName
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m (Either CreateCodebaseError r)
forall (m :: * -> *) r.
MonadUnliftIO m =>
Transaction ()
-> DebugName
-> DebugName
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m (Either CreateCodebaseError r)
createCodebaseOrError Transaction ()
onCreate,
      $sel:codebasePath:Init :: DebugName -> DebugName
codebasePath = DebugName -> DebugName
makeCodebaseDirPath
    }

-- | Create a codebase at the given location.
createCodebaseOrError ::
  (MonadUnliftIO m) =>
  Sqlite.Transaction () ->
  Codebase.DebugName ->
  CodebasePath ->
  CodebaseLockOption ->
  (Codebase m Symbol Ann -> m r) ->
  m (Either Codebase1.CreateCodebaseError r)
createCodebaseOrError :: forall (m :: * -> *) r.
MonadUnliftIO m =>
Transaction ()
-> DebugName
-> DebugName
-> CodebaseLockOption
-> (Codebase m Symbol Ann -> m r)
-> m (Either CreateCodebaseError r)
createCodebaseOrError Transaction ()
onCreate DebugName
debugName DebugName
path CodebaseLockOption
lockOption Codebase m Symbol Ann -> m r
action = do
  m Bool
-> m (Either CreateCodebaseError r)
-> m (Either CreateCodebaseError r)
-> m (Either CreateCodebaseError r)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
    (DebugName -> m Bool
forall (m :: * -> *). MonadIO m => DebugName -> m Bool
doesFileExist (DebugName -> m Bool) -> DebugName -> m Bool
forall a b. (a -> b) -> a -> b
$ DebugName -> DebugName
makeCodebasePath DebugName
path)
    (Either CreateCodebaseError r -> m (Either CreateCodebaseError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CreateCodebaseError r -> m (Either CreateCodebaseError r))
-> Either CreateCodebaseError r -> m (Either CreateCodebaseError r)
forall a b. (a -> b) -> a -> b
$ CreateCodebaseError -> Either CreateCodebaseError r
forall a b. a -> Either a b
Left CreateCodebaseError
Codebase1.CreateCodebaseAlreadyExists)
    do
      Bool -> DebugName -> m ()
forall (m :: * -> *). MonadIO m => Bool -> DebugName -> m ()
createDirectoryIfMissing Bool
True (DebugName -> DebugName
makeCodebaseDirPath DebugName
path)
      DebugName -> DebugName -> (Connection -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection (DebugName
debugName DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ DebugName
".createSchema") DebugName
path \Connection
conn -> do
        Connection -> JournalMode -> m ()
forall (m :: * -> *).
MonadIO m =>
Connection -> JournalMode -> m ()
Sqlite.trySetJournalMode Connection
conn JournalMode
Sqlite.JournalMode'WAL
        Connection -> Transaction () -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Connection -> Transaction a -> m a
Sqlite.runTransaction Connection
conn do
          Transaction ()
CodebaseOps.createSchema
          Transaction ()
onCreate

      DebugName
-> DebugName
-> LocalOrRemote
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
forall (m :: * -> *) r.
MonadUnliftIO m =>
DebugName
-> DebugName
-> LocalOrRemote
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
sqliteCodebase DebugName
debugName DebugName
path LocalOrRemote
Local CodebaseLockOption
lockOption MigrationStrategy
DontMigrate Codebase m Symbol Ann -> m r
action m (Either OpenCodebaseError r)
-> (Either OpenCodebaseError r -> m (Either CreateCodebaseError r))
-> m (Either CreateCodebaseError r)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left OpenCodebaseError
schemaVersion -> DebugName -> m (Either CreateCodebaseError r)
forall a. HasCallStack => DebugName -> a
error (DebugName
"Failed to open codebase with schema version: " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ OpenCodebaseError -> DebugName
forall a. Show a => a -> DebugName
show OpenCodebaseError
schemaVersion DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ DebugName
", which is unexpected because I just created this codebase.")
        Right r
result -> Either CreateCodebaseError r -> m (Either CreateCodebaseError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> Either CreateCodebaseError r
forall a b. b -> Either a b
Right r
result)

-- | Use the codebase in the provided path.
-- The codebase is automatically closed when the action completes or throws an exception.
withCodebaseOrError ::
  forall m r.
  (MonadUnliftIO m) =>
  Codebase.DebugName ->
  CodebasePath ->
  CodebaseLockOption ->
  MigrationStrategy ->
  (Codebase m Symbol Ann -> m r) ->
  m (Either Codebase1.OpenCodebaseError r)
withCodebaseOrError :: forall (m :: * -> *) r.
MonadUnliftIO m =>
DebugName
-> DebugName
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
withCodebaseOrError DebugName
debugName DebugName
dir CodebaseLockOption
lockOption MigrationStrategy
migrationStrategy Codebase m Symbol Ann -> m r
action = do
  DebugName -> m Bool
forall (m :: * -> *). MonadIO m => DebugName -> m Bool
doesFileExist (DebugName -> DebugName
makeCodebasePath DebugName
dir) m Bool
-> (Bool -> m (Either OpenCodebaseError r))
-> m (Either OpenCodebaseError r)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> Either OpenCodebaseError r -> m (Either OpenCodebaseError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpenCodebaseError -> Either OpenCodebaseError r
forall a b. a -> Either a b
Left OpenCodebaseError
Codebase1.OpenCodebaseDoesntExist)
    Bool
True -> DebugName
-> DebugName
-> LocalOrRemote
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
forall (m :: * -> *) r.
MonadUnliftIO m =>
DebugName
-> DebugName
-> LocalOrRemote
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
sqliteCodebase DebugName
debugName DebugName
dir LocalOrRemote
Local CodebaseLockOption
lockOption MigrationStrategy
migrationStrategy Codebase m Symbol Ann -> m r
action

-- 1) buffer up the component
-- 2) in the event that the component is complete, then what?
--  * can write component provided all of its dependency components are complete.
--    if dependency not complete,
--    register yourself to be written when that dependency is complete

-- | Run an action with a connection to the codebase, closing the connection on completion or
-- failure.
withConnection ::
  (MonadUnliftIO m) =>
  Codebase.DebugName ->
  CodebasePath ->
  (Sqlite.Connection -> m a) ->
  m a
withConnection :: forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
name DebugName
root Connection -> m a
action =
  DebugName -> DebugName -> (Connection -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
Sqlite.withConnection DebugName
name (DebugName -> DebugName
makeCodebasePath DebugName
root) Connection -> m a
action

sqliteCodebase ::
  forall m r.
  (MonadUnliftIO m) =>
  Codebase.DebugName ->
  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 :: forall (m :: * -> *) r.
MonadUnliftIO m =>
DebugName
-> DebugName
-> LocalOrRemote
-> CodebaseLockOption
-> MigrationStrategy
-> (Codebase m Symbol Ann -> m r)
-> m (Either OpenCodebaseError r)
sqliteCodebase DebugName
debugName DebugName
root LocalOrRemote
localOrRemote CodebaseLockOption
lockOption MigrationStrategy
migrationStrategy Codebase m Symbol Ann -> m r
action = m (Either OpenCodebaseError r) -> m (Either OpenCodebaseError r)
handleLockOption do
  -- The branchLoadCache ephemerally caches branches in memory, but doesn't prevent them from being GC'd.
  -- This is very useful when loading root branches because the cache shouldn't be limited in size.
  -- But this cache will automatically clean itself up and remove entries that are no longer reachable.
  -- If you load another branch, which shares namespaces with another branch that's in memory (and therefor in the cache)
  -- then those shared namespaces will be loaded from the cache and will be shared in memory.
  BranchCache Transaction
branchLoadCache <- m (BranchCache Transaction)
forall (m :: * -> *). MonadIO m => m (BranchCache Transaction)
newBranchCache
  -- The rootBranchCache is a semispace cache which keeps the most recent branch roots (e.g. project roots) alive in memory.
  -- Unlike the branchLoadCache, this cache is bounded in size and will evict older branches when it reaches its limit.
  -- The two work in tandem, so the rootBranchCache keeps relevant branches alive, and the branchLoadCache
  -- stores ALL the subnamespaces of those branches, deduping them when loading from the DB.
  Cache CausalHash (Branch m)
rootBranchCache <- Word -> m (Cache CausalHash (Branch m))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
  Reference -> Transaction ConstructorType
getDeclType <- Word
-> (Reference -> Transaction ConstructorType)
-> m (Reference -> Transaction ConstructorType)
forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word -> (a -> Transaction b) -> m (a -> Transaction b)
CodebaseOps.makeCachedTransaction Word
2048 Reference -> Transaction ConstructorType
CodebaseOps.getDeclType
  -- The v1 codebase interface has operations to read and write individual definitions
  -- whereas the v2 codebase writes them as complete components.  These two fields buffer
  -- the individual definitions until a complete component has been written.
  TVar (Map Hash TermBufferEntry)
termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- Map Hash TermBufferEntry -> m (TVar (Map Hash TermBufferEntry))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map Hash TermBufferEntry
forall k a. Map k a
Map.empty
  TVar (Map Hash DeclBufferEntry)
declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- Map Hash DeclBufferEntry -> m (TVar (Map Hash DeclBufferEntry))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map Hash DeclBufferEntry
forall k a. Map k a
Map.empty

  Either OpenCodebaseError ()
result <- (Connection -> m (Either OpenCodebaseError ()))
-> m (Either OpenCodebaseError ())
forall a. (Connection -> m a) -> m a
withConn \Connection
conn -> do
    Connection
-> Transaction CodebaseVersionStatus -> m CodebaseVersionStatus
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Connection -> Transaction a -> m a
Sqlite.runTransaction Connection
conn Transaction CodebaseVersionStatus
Migrations.checkCodebaseIsUpToDate m CodebaseVersionStatus
-> (CodebaseVersionStatus -> m (Either OpenCodebaseError ()))
-> m (Either OpenCodebaseError ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CodebaseVersionStatus
Migrations.CodebaseUpToDate -> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OpenCodebaseError () -> m (Either OpenCodebaseError ()))
-> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a b. (a -> b) -> a -> b
$ () -> Either OpenCodebaseError ()
forall a b. b -> Either a b
Right ()
      Migrations.CodebaseUnknownSchemaVersion SchemaVersion
sv -> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OpenCodebaseError () -> m (Either OpenCodebaseError ()))
-> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a b. (a -> b) -> a -> b
$ OpenCodebaseError -> Either OpenCodebaseError ()
forall a b. a -> Either a b
Left (SchemaVersion -> OpenCodebaseError
OpenCodebaseUnknownSchemaVersion SchemaVersion
sv)
      Migrations.CodebaseRequiresMigration SchemaVersion
fromSv SchemaVersion
toSv ->
        case MigrationStrategy
migrationStrategy of
          MigrationStrategy
DontMigrate -> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OpenCodebaseError () -> m (Either OpenCodebaseError ()))
-> Either OpenCodebaseError () -> m (Either OpenCodebaseError ())
forall a b. (a -> b) -> a -> b
$ OpenCodebaseError -> Either OpenCodebaseError ()
forall a b. a -> Either a b
Left (SchemaVersion -> SchemaVersion -> OpenCodebaseError
OpenCodebaseRequiresMigration SchemaVersion
fromSv SchemaVersion
toSv)
          MigrateAfterPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy -> do
            let shouldPrompt :: Bool
shouldPrompt = Bool
True
            LocalOrRemote
-> DebugName
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
forall (m :: * -> *).
MonadIO m =>
LocalOrRemote
-> DebugName
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
Migrations.ensureCodebaseIsUpToDate LocalOrRemote
localOrRemote DebugName
root Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Bool
shouldPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy Connection
conn
          MigrateAutomatically BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy -> do
            let shouldPrompt :: Bool
shouldPrompt = Bool
False
            LocalOrRemote
-> DebugName
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
forall (m :: * -> *).
MonadIO m =>
LocalOrRemote
-> DebugName
-> (Reference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
Migrations.ensureCodebaseIsUpToDate LocalOrRemote
localOrRemote DebugName
root Reference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Bool
shouldPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy Connection
conn

  case Either OpenCodebaseError ()
result of
    Left OpenCodebaseError
err -> Either OpenCodebaseError r -> m (Either OpenCodebaseError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OpenCodebaseError r -> m (Either OpenCodebaseError r))
-> Either OpenCodebaseError r -> m (Either OpenCodebaseError r)
forall a b. (a -> b) -> a -> b
$ OpenCodebaseError -> Either OpenCodebaseError r
forall a b. a -> Either a b
Left OpenCodebaseError
err
    Right () -> do
      let finalizer :: (MonadIO m) => m ()
          finalizer :: MonadIO m => m ()
finalizer = do
            Map Hash DeclBufferEntry
decls <- TVar (Map Hash DeclBufferEntry) -> m (Map Hash DeclBufferEntry)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map Hash DeclBufferEntry)
declBuffer
            Map Hash TermBufferEntry
terms <- TVar (Map Hash TermBufferEntry) -> m (Map Hash TermBufferEntry)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map Hash TermBufferEntry)
termBuffer
            let printBuffer :: DebugName -> a -> m ()
printBuffer DebugName
header a
b =
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
forall a. Monoid a => a
mempty
                      then DebugName -> IO ()
putStrLn DebugName
header IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DebugName -> IO ()
putStrLn DebugName
"" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
forall a. Show a => a -> IO ()
print a
b
                      else () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            DebugName -> Map Hash DeclBufferEntry -> m ()
forall {m :: * -> *} {a}.
(MonadIO m, Eq a, Monoid a, Show a) =>
DebugName -> a -> m ()
printBuffer DebugName
"Decls:" Map Hash DeclBufferEntry
decls
            DebugName -> Map Hash TermBufferEntry -> m ()
forall {m :: * -> *} {a}.
(MonadIO m, Eq a, Monoid a, Show a) =>
DebugName -> a -> m ()
printBuffer DebugName
"Terms:" Map Hash TermBufferEntry
terms

      (m (Either OpenCodebaseError r)
 -> m () -> m (Either OpenCodebaseError r))
-> m ()
-> m (Either OpenCodebaseError r)
-> m (Either OpenCodebaseError r)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Either OpenCodebaseError r)
-> m () -> m (Either OpenCodebaseError r)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally m ()
MonadIO m => m ()
finalizer do
        Id -> Transaction (Maybe (Term Symbol Ann))
getTerm <- Word
-> (Id -> Transaction (Maybe (Term Symbol Ann)))
-> m (Id -> Transaction (Maybe (Term Symbol Ann)))
forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word
-> (a -> Transaction (Maybe b)) -> m (a -> Transaction (Maybe b))
CodebaseOps.makeMaybeCachedTransaction Word
8192 ((Reference -> Transaction ConstructorType)
-> Id -> Transaction (Maybe (Term Symbol Ann))
CodebaseOps.getTerm Reference -> Transaction ConstructorType
getDeclType)
        Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl <- Word
-> (Id -> Transaction (Maybe (Type Symbol Ann)))
-> m (Id -> Transaction (Maybe (Type Symbol Ann)))
forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word
-> (a -> Transaction (Maybe b)) -> m (a -> Transaction (Maybe b))
CodebaseOps.makeMaybeCachedTransaction Word
8192 (Id -> Transaction (Maybe (Type Symbol Ann))
CodebaseOps.getTypeOfTermImpl)
        Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
getTypeDeclaration <- Word
-> (Id
    -> Transaction
         (Maybe
            (Either
               (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))))
-> m (Id
      -> Transaction
           (Maybe
              (Either
                 (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))))
forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word
-> (a -> Transaction (Maybe b)) -> m (a -> Transaction (Maybe b))
CodebaseOps.makeMaybeCachedTransaction Word
1024 Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
CodebaseOps.getTypeDeclaration

        let getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
            getTermComponentWithTypes :: Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes =
              (Reference -> Transaction ConstructorType)
-> Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
CodebaseOps.getTermComponentWithTypes Reference -> Transaction ConstructorType
getDeclType

            -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m ()
            -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies?

            -- option 1: tweak putTerm to incrementally notice the cycle length until each component is full
            -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function
            -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly)

            putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> Sqlite.Transaction ()
            putTerm :: Id -> Term Symbol Ann -> Type Symbol Ann -> Transaction ()
putTerm Id
id Term Symbol Ann
tm Type Symbol Ann
tp | Bool
debug Bool -> Bool -> Bool
&& DebugName -> Bool -> Bool
forall a. DebugName -> a -> a
trace (DebugName
"SqliteCodebase.putTerm " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ Id -> DebugName
forall a. Show a => a -> DebugName
show Id
id DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ DebugName
" " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ Term Symbol Ann -> DebugName
forall a. Show a => a -> DebugName
show Term Symbol Ann
tm DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ DebugName
" " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ Type Symbol Ann -> DebugName
forall a. Show a => a -> DebugName
show Type Symbol Ann
tp) Bool
False = Transaction ()
forall a. HasCallStack => a
undefined
            putTerm Id
id Term Symbol Ann
tm Type Symbol Ann
tp =
              TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
CodebaseOps.putTerm TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Id
id Term Symbol Ann
tm Type Symbol Ann
tp

            putTermComponent :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Sqlite.Transaction ()
            putTermComponent :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Transaction ()
putTermComponent =
              TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Hash
-> [(Term Symbol Ann, Type Symbol Ann)]
-> Transaction ()
CodebaseOps.putTermComponent TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer

            putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> Sqlite.Transaction ()
            putTypeDeclaration :: Id
-> Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)
-> Transaction ()
putTypeDeclaration =
              TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)
-> Transaction ()
CodebaseOps.putTypeDeclaration TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer

            putTypeDeclarationComponent :: Hash -> [Decl Symbol Ann] -> Sqlite.Transaction ()
            putTypeDeclarationComponent :: Hash
-> [Either
      (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)]
-> Transaction ()
putTypeDeclarationComponent =
              TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Hash
-> [Either
      (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)]
-> Transaction ()
CodebaseOps.putTypeDeclarationComponent TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer

            -- if this blows up on cromulent hashes, then switch from `hashToHashId`
            -- to one that returns Maybe.
            getBranchForHash :: CausalHash -> m (Maybe (Branch m))
            getBranchForHash :: CausalHash -> m (Maybe (Branch m))
getBranchForHash =
              Cache CausalHash (Branch m)
-> (CausalHash -> m (Maybe (Branch m)))
-> CausalHash
-> m (Maybe (Branch m))
forall (m :: * -> *) (g :: * -> *) k v.
(MonadIO m, Applicative g, Traversable g) =>
Cache k v -> (k -> m (g v)) -> k -> m (g v)
Cache.applyDefined Cache CausalHash (Branch m)
rootBranchCache \CausalHash
h -> do
                (Branch Transaction -> Branch m)
-> Maybe (Branch Transaction) -> Maybe (Branch m)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. Transaction a -> m a) -> Branch Transaction -> Branch m
forall (m :: * -> *) (n :: * -> *).
Functor m =>
(forall a. m a -> n a) -> Branch m -> Branch n
Branch.transform Transaction a -> m a
forall a. Transaction a -> m a
runTransaction) (Maybe (Branch Transaction) -> Maybe (Branch m))
-> m (Maybe (Branch Transaction)) -> m (Maybe (Branch m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transaction (Maybe (Branch Transaction))
-> m (Maybe (Branch Transaction))
forall a. Transaction a -> m a
runTransaction (BranchCache Transaction
-> (Reference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
CodebaseOps.getBranchForHash BranchCache Transaction
branchLoadCache Reference -> Transaction ConstructorType
getDeclType CausalHash
h)

            putBranch :: Branch m -> m ()
            putBranch :: Branch m -> m ()
putBranch Branch m
branch =
              ((forall a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. m a -> IO a
runInIO ->
                m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Cache CausalHash (Branch m) -> CausalHash -> Branch m -> m ()
forall (m :: * -> *) k v. MonadIO m => Cache k v -> k -> v -> m ()
Cache.insert Cache CausalHash (Branch m)
rootBranchCache (Branch m -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch m
branch) Branch m
branch
                  Transaction () -> m ()
forall a. Transaction a -> m a
runTransaction (Branch Transaction -> Transaction ()
CodebaseOps.putBranch ((forall a. m a -> Transaction a) -> Branch m -> Branch Transaction
forall (m :: * -> *) (n :: * -> *).
Functor m =>
(forall a. m a -> n a) -> Branch m -> Branch n
Branch.transform (IO a -> Transaction a
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO a -> Transaction a) -> (m a -> IO a) -> m a -> Transaction a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IO a
forall a. m a -> IO a
runInIO) Branch m
branch))

            preloadBranch :: CausalHash -> m ()
            preloadBranch :: CausalHash -> m ()
preloadBranch CausalHash
h = do
              m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> (m () -> m ThreadId) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
UnliftIO.forkIO (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                CausalHash -> m (Maybe (Branch m))
getBranchForHash CausalHash
h m (Maybe (Branch m)) -> (Maybe (Branch m) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe (Branch m)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Just Branch m
b -> do
                    Branch m -> m (Branch m)
forall (m :: * -> *) a. MonadIO m => a -> m a
UnliftIO.evaluate Branch m
b
                    pure ()

            getWatch :: UF.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term Symbol Ann))
            getWatch :: DebugName -> Id -> Transaction (Maybe (Term Symbol Ann))
getWatch =
              (Reference -> Transaction ConstructorType)
-> DebugName -> Id -> Transaction (Maybe (Term Symbol Ann))
CodebaseOps.getWatch Reference -> Transaction ConstructorType
getDeclType

            termsOfTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id)
            termsOfTypeImpl :: Reference -> Transaction (Set Id)
termsOfTypeImpl =
              (Reference -> Transaction ConstructorType)
-> Reference -> Transaction (Set Id)
CodebaseOps.termsOfTypeImpl Reference -> Transaction ConstructorType
getDeclType

            filterTermsByReferentIdHavingTypeImpl :: Reference -> Set Referent.Id -> Sqlite.Transaction (Set Referent.Id)
            filterTermsByReferentIdHavingTypeImpl :: Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferentIdHavingTypeImpl =
              (Reference -> Transaction ConstructorType)
-> Reference -> Set Id -> Transaction (Set Id)
CodebaseOps.filterReferentsHavingTypeImpl Reference -> Transaction ConstructorType
getDeclType

            filterTermsByReferenceIdHavingTypeImpl :: Reference -> Set TermReferenceId -> Sqlite.Transaction (Set TermReferenceId)
            filterTermsByReferenceIdHavingTypeImpl :: Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferenceIdHavingTypeImpl =
              Reference -> Set Id -> Transaction (Set Id)
CodebaseOps.filterReferencesHavingTypeImpl

            termsMentioningTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id)
            termsMentioningTypeImpl :: Reference -> Transaction (Set Id)
termsMentioningTypeImpl =
              (Reference -> Transaction ConstructorType)
-> Reference -> Transaction (Set Id)
CodebaseOps.termsMentioningTypeImpl Reference -> Transaction ConstructorType
getDeclType

            referentsByPrefix :: ShortHash -> Sqlite.Transaction (Set Referent.Id)
            referentsByPrefix :: ShortHash -> Transaction (Set Id)
referentsByPrefix =
              (Reference -> Transaction ConstructorType)
-> ShortHash -> Transaction (Set Id)
CodebaseOps.referentsByPrefix Reference -> Transaction ConstructorType
getDeclType

        let codebase :: Codebase m Symbol Ann
codebase =
              C.Codebase
                { Id -> Transaction (Maybe (Term Symbol Ann))
getTerm :: Id -> Transaction (Maybe (Term Symbol Ann))
$sel:getTerm:Codebase :: Id -> Transaction (Maybe (Term Symbol Ann))
getTerm,
                  Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl :: Id -> Transaction (Maybe (Type Symbol Ann))
$sel:getTypeOfTermImpl:Codebase :: Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl,
                  Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
getTypeDeclaration :: Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
$sel:getTypeDeclaration:Codebase :: Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
getTypeDeclaration,
                  Reference -> Transaction ConstructorType
getDeclType :: Reference -> Transaction ConstructorType
$sel:getDeclType:Codebase :: Reference -> Transaction ConstructorType
getDeclType,
                  Id -> Term Symbol Ann -> Type Symbol Ann -> Transaction ()
putTerm :: Id -> Term Symbol Ann -> Type Symbol Ann -> Transaction ()
$sel:putTerm:Codebase :: Id -> Term Symbol Ann -> Type Symbol Ann -> Transaction ()
putTerm,
                  Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Transaction ()
putTermComponent :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Transaction ()
$sel:putTermComponent:Codebase :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Transaction ()
putTermComponent,
                  Id
-> Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)
-> Transaction ()
putTypeDeclaration :: Id
-> Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)
-> Transaction ()
$sel:putTypeDeclaration:Codebase :: Id
-> Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)
-> Transaction ()
putTypeDeclaration,
                  Hash
-> [Either
      (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)]
-> Transaction ()
putTypeDeclarationComponent :: Hash
-> [Either
      (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)]
-> Transaction ()
$sel:putTypeDeclarationComponent:Codebase :: Hash
-> [Either
      (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)]
-> Transaction ()
putTypeDeclarationComponent,
                  Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes :: Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
$sel:getTermComponentWithTypes:Codebase :: Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes,
                  CausalHash -> m (Maybe (Branch m))
getBranchForHash :: CausalHash -> m (Maybe (Branch m))
$sel:getBranchForHash:Codebase :: CausalHash -> m (Maybe (Branch m))
getBranchForHash,
                  Branch m -> m ()
putBranch :: Branch m -> m ()
$sel:putBranch:Codebase :: Branch m -> m ()
putBranch,
                  DebugName -> Id -> Transaction (Maybe (Term Symbol Ann))
getWatch :: DebugName -> Id -> Transaction (Maybe (Term Symbol Ann))
$sel:getWatch:Codebase :: DebugName -> Id -> Transaction (Maybe (Term Symbol Ann))
getWatch,
                  Reference -> Transaction (Set Id)
termsOfTypeImpl :: Reference -> Transaction (Set Id)
$sel:termsOfTypeImpl:Codebase :: Reference -> Transaction (Set Id)
termsOfTypeImpl,
                  Reference -> Transaction (Set Id)
termsMentioningTypeImpl :: Reference -> Transaction (Set Id)
$sel:termsMentioningTypeImpl:Codebase :: Reference -> Transaction (Set Id)
termsMentioningTypeImpl,
                  Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferenceIdHavingTypeImpl :: Reference -> Set Id -> Transaction (Set Id)
$sel:filterTermsByReferenceIdHavingTypeImpl:Codebase :: Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferenceIdHavingTypeImpl,
                  Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferentIdHavingTypeImpl :: Reference -> Set Id -> Transaction (Set Id)
$sel:filterTermsByReferentIdHavingTypeImpl:Codebase :: Reference -> Set Id -> Transaction (Set Id)
filterTermsByReferentIdHavingTypeImpl,
                  $sel:termReferentsByPrefix:Codebase :: ShortHash -> Transaction (Set Id)
termReferentsByPrefix = ShortHash -> Transaction (Set Id)
referentsByPrefix,
                  $sel:withConnection:Codebase :: forall a. (Connection -> m a) -> m a
withConnection = (Connection -> m x) -> m x
forall a. (Connection -> m a) -> m a
withConn,
                  $sel:withConnectionIO:Codebase :: forall x. (Connection -> IO x) -> IO x
withConnectionIO = DebugName -> DebugName -> (Connection -> IO x) -> IO x
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
debugName DebugName
root,
                  CausalHash -> m ()
preloadBranch :: CausalHash -> m ()
$sel:preloadBranch:Codebase :: CausalHash -> m ()
preloadBranch
                }
        r -> Either OpenCodebaseError r
forall a b. b -> Either a b
Right (r -> Either OpenCodebaseError r)
-> m r -> m (Either OpenCodebaseError r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codebase m Symbol Ann -> m r
action Codebase m Symbol Ann
codebase
  where
    withConn :: (Sqlite.Connection -> m a) -> m a
    withConn :: forall a. (Connection -> m a) -> m a
withConn =
      DebugName -> DebugName -> (Connection -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
debugName DebugName
root

    runTransaction :: Sqlite.Transaction a -> m a
    runTransaction :: forall a. Transaction a -> m a
runTransaction Transaction a
action =
      (Connection -> m a) -> m a
forall a. (Connection -> m a) -> m a
withConn \Connection
conn -> Connection -> Transaction a -> m a
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Connection -> Transaction a -> m a
Sqlite.runTransaction Connection
conn Transaction a
action

    handleLockOption :: m (Either OpenCodebaseError r) -> m (Either OpenCodebaseError r)
handleLockOption m (Either OpenCodebaseError r)
ma = case CodebaseLockOption
lockOption of
      CodebaseLockOption
DontLock -> m (Either OpenCodebaseError r)
ma
      CodebaseLockOption
DoLock -> ((forall a. m a -> IO a) -> IO (Either OpenCodebaseError r))
-> m (Either OpenCodebaseError r)
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. m a -> IO a
runInIO ->
        DebugName
-> SharedExclusive
-> (FileLock -> IO (Either OpenCodebaseError r))
-> IO (Maybe (Either OpenCodebaseError r))
forall a.
DebugName -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)
withTryFileLock (DebugName -> DebugName
lockfilePath DebugName
root) SharedExclusive
Exclusive (\FileLock
_flock -> m (Either OpenCodebaseError r) -> IO (Either OpenCodebaseError r)
forall a. m a -> IO a
runInIO m (Either OpenCodebaseError r)
ma) IO (Maybe (Either OpenCodebaseError r))
-> (Maybe (Either OpenCodebaseError r)
    -> Either OpenCodebaseError r)
-> IO (Either OpenCodebaseError r)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Maybe (Either OpenCodebaseError r)
Nothing -> OpenCodebaseError -> Either OpenCodebaseError r
forall a b. a -> Either a b
Left OpenCodebaseError
OpenCodebaseFileLockFailed
          Just Either OpenCodebaseError r
x -> Either OpenCodebaseError r
x

data Entity m
  = B CausalHash (m (Branch m))
  | O Hash

instance Show (Entity m) where
  show :: Entity m -> DebugName
show (B CausalHash
h m (Branch m)
_) = DebugName
"B " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ Int -> DebugName -> DebugName
forall a. Int -> [a] -> [a]
take Int
10 (CausalHash -> DebugName
forall a. Show a => a -> DebugName
show CausalHash
h)
  show (O Hash
h) = DebugName
"O " DebugName -> DebugName -> DebugName
forall a. [a] -> [a] -> [a]
++ Int -> DebugName -> DebugName
forall a. Int -> [a] -> [a]
take Int
10 (Hash -> DebugName
forall a. Show a => a -> DebugName
show Hash
h)

-- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase
-- at the source to the destination.
-- Note: this does not copy the .unisonConfig file.
copyCodebase :: (MonadIO m) => CodebasePath -> CodebasePath -> m ()
copyCodebase :: forall (m :: * -> *). MonadIO m => DebugName -> DebugName -> m ()
copyCodebase DebugName
src DebugName
dest = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> DebugName -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> DebugName -> m ()
createDirectoryIfMissing Bool
True (DebugName -> DebugName
makeCodebaseDirPath DebugName
dest)
  DebugName -> DebugName -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection (DebugName
"copy-from:" DebugName -> DebugName -> DebugName
forall a. Semigroup a => a -> a -> a
<> DebugName
src) DebugName
src ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
srcConn -> do
    Connection -> DebugName -> IO ()
Sqlite.vacuumInto Connection
srcConn (DebugName -> DebugName
makeCodebasePath DebugName
dest)
  -- We need to reset the journal mode because vacuum-into clears it.
  DebugName -> DebugName -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection (DebugName
"copy-to:" DebugName -> DebugName -> DebugName
forall a. Semigroup a => a -> a -> a
<> DebugName
dest) DebugName
dest ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
destConn -> do
    Connection -> JournalMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
Connection -> JournalMode -> m ()
Sqlite.trySetJournalMode Connection
destConn JournalMode
Sqlite.JournalMode'WAL