{-# 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.Foldable qualified as Foldable
import Data.Map qualified as Map
import Data.Set qualified as Set
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
import U.Codebase.HashTags (BranchHash, CausalHash)
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Codebase (Codebase, CodebasePath)
import Unison.Codebase qualified as Codebase1
import Unison.Codebase.Branch (Branch (..), UnconflictedBranchView (..))
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.DeclCoherencyCheck (IncoherentDeclReasons, checkAllDeclCoherency, lenientCheckDeclCoherency)
import Unison.DeclNameLookup (DeclNameLookup)
import Unison.Hash (Hash)
import Unison.Parser.Ann (Ann)
import Unison.PartialDeclNameLookup (PartialDeclNameLookup)
import Unison.Prelude
import Unison.Reference (Reference, Reference' (..), TermReferenceId, TypeReference, TypeReferenceId)
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.BiMultimap qualified as BiMultimap
import Unison.Util.Cache qualified as Cache
import Unison.Util.Defns (Defns (..))
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
  Cache CausalHash (Branch Transaction)
rootBranchCacheTx <- Word -> m (Cache CausalHash (Branch Transaction))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
  Cache Reference ConstructorType
declTypeCache <- Word -> m (Cache Reference ConstructorType)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
2048
  let getDeclType :: Reference -> Transaction ConstructorType
getDeclType = Cache Reference ConstructorType
-> (Reference -> Transaction ConstructorType)
-> Reference
-> Transaction ConstructorType
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache Reference ConstructorType
declTypeCache 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
        Cache Id (Term Symbol Ann)
termCache <- Word -> m (Cache Id (Term Symbol Ann))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
8192
        let getTerm :: Id -> Transaction (Maybe (Term Symbol Ann))
getTerm = Cache Id (Term Symbol Ann)
-> (Id -> Transaction (Maybe (Term Symbol Ann)))
-> Id
-> Transaction (Maybe (Term Symbol Ann))
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction Cache Id (Term Symbol Ann)
termCache ((Reference -> Transaction ConstructorType)
-> Id -> Transaction (Maybe (Term Symbol Ann))
CodebaseOps.getTerm Reference -> Transaction ConstructorType
getDeclType)
        Cache Id (Type Symbol Ann)
typeOfTermCache <- Word -> m (Cache Id (Type Symbol Ann))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
8192
        let getTypeOfTermImpl :: Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl = Cache Id (Type Symbol Ann)
-> (Id -> Transaction (Maybe (Type Symbol Ann)))
-> Id
-> Transaction (Maybe (Type Symbol Ann))
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction Cache Id (Type Symbol Ann)
typeOfTermCache Id -> Transaction (Maybe (Type Symbol Ann))
CodebaseOps.getTypeOfTermImpl
        Cache
  Id
  (Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))
typeDeclarationCache <- Word
-> m (Cache
        Id
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
1024
        let getTypeDeclaration :: Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
getTypeDeclaration = Cache
  Id
  (Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))
-> (Id
    -> Transaction
         (Maybe
            (Either
               (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))))
-> Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction Cache
  Id
  (Either
     (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann))
typeDeclarationCache Id
-> Transaction
     (Maybe
        (Either
           (EffectDeclaration Symbol Ann) (DataDeclaration Symbol Ann)))
CodebaseOps.getTypeDeclaration
        Cache Id Int
declNumConstructorsCache <- Word -> m (Cache Id Int)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
1024
        let expectDeclNumConstructors :: Id -> Transaction Int
expectDeclNumConstructors = Cache Id Int -> (Id -> Transaction Int) -> Id -> Transaction Int
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache Id Int
declNumConstructorsCache Id -> Transaction Int
Operations.expectDeclNumConstructors
        let getBranchForHashTx :: CausalHash -> Transaction (Maybe (Branch Transaction))
getBranchForHashTx = Cache CausalHash (Branch Transaction)
-> (CausalHash -> Transaction (Maybe (Branch Transaction)))
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction Cache CausalHash (Branch Transaction)
rootBranchCacheTx (BranchCache Transaction
-> (Reference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
CodebaseOps.getBranchForHash BranchCache Transaction
branchLoadCache Reference -> Transaction ConstructorType
getDeclType)

        Cache (Keyed BranchHash (Set Reference)) (Map Id Int)
branchDeclNumConstructorsCache <- Word -> m (Cache (Keyed BranchHash (Set Reference)) (Map Id Int))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
        let getBranchDeclNumConstructors0 :: Keyed BranchHash (Set TypeReference) -> Sqlite.Transaction (Map TypeReferenceId Int)
            getBranchDeclNumConstructors0 :: Keyed BranchHash (Set Reference) -> Transaction (Map Id Int)
getBranchDeclNumConstructors0 =
              Cache (Keyed BranchHash (Set Reference)) (Map Id Int)
-> (Keyed BranchHash (Set Reference) -> Transaction (Map Id Int))
-> Keyed BranchHash (Set Reference)
-> Transaction (Map Id Int)
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache (Keyed BranchHash (Set Reference)) (Map Id Int)
branchDeclNumConstructorsCache \Keyed BranchHash (Set Reference)
k ->
                Keyed BranchHash (Set Reference)
k.value
                  Set Reference -> (Set Reference -> [Reference]) -> [Reference]
forall a b. a -> (a -> b) -> b
& Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList
                  [Reference]
-> ([Reference] -> Transaction (Map Id Int))
-> Transaction (Map Id Int)
forall a b. a -> (a -> b) -> b
& (Map Id Int -> Reference -> Transaction (Map Id Int))
-> Map Id Int -> [Reference] -> Transaction (Map Id Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Foldable.foldlM
                    ( \Map Id Int
acc -> \case
                        ReferenceBuiltin Text
_ -> Map Id Int -> Transaction (Map Id Int)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Id Int
acc
                        ReferenceDerived Id
ref -> do
                          Int
num <- Id -> Transaction Int
expectDeclNumConstructors Id
ref
                          Map Id Int -> Transaction (Map Id Int)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Id Int -> Transaction (Map Id Int))
-> Map Id Int -> Transaction (Map Id Int)
forall a b. (a -> b) -> a -> b
$! Id -> Int -> Map Id Int -> Map Id Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
ref Int
num Map Id Int
acc
                    )
                    Map Id Int
forall k a. Map k a
Map.empty

        let getBranchDeclNumConstructors :: BranchHash -> Set TypeReference -> Sqlite.Transaction (Map TypeReferenceId Int)
            getBranchDeclNumConstructors :: BranchHash -> Set Reference -> Transaction (Map Id Int)
getBranchDeclNumConstructors BranchHash
namespaceHash Set Reference
refs =
              Keyed BranchHash (Set Reference) -> Transaction (Map Id Int)
getBranchDeclNumConstructors0 (BranchHash -> Set Reference -> Keyed BranchHash (Set Reference)
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash Set Reference
refs)

        Cache
  (Keyed BranchHash UnconflictedBranchView) PartialDeclNameLookup
branchPartialDeclNameLookupCache <- Word
-> m (Cache
        (Keyed BranchHash UnconflictedBranchView) PartialDeclNameLookup)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
        let getBranchPartialDeclNameLookup ::
              BranchHash ->
              UnconflictedBranchView ->
              Sqlite.Transaction PartialDeclNameLookup
            getBranchPartialDeclNameLookup :: BranchHash
-> UnconflictedBranchView -> Transaction PartialDeclNameLookup
getBranchPartialDeclNameLookup =
              let get :: Keyed BranchHash UnconflictedBranchView -> Sqlite.Transaction PartialDeclNameLookup
                  get :: Keyed BranchHash UnconflictedBranchView
-> Transaction PartialDeclNameLookup
get =
                    Cache
  (Keyed BranchHash UnconflictedBranchView) PartialDeclNameLookup
-> (Keyed BranchHash UnconflictedBranchView
    -> Transaction PartialDeclNameLookup)
-> Keyed BranchHash UnconflictedBranchView
-> Transaction PartialDeclNameLookup
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache
  (Keyed BranchHash UnconflictedBranchView) PartialDeclNameLookup
branchPartialDeclNameLookupCache \Keyed BranchHash UnconflictedBranchView
k -> do
                      Map Id Int
numConstructors <- Keyed BranchHash (Set Reference) -> Transaction (Map Id Int)
getBranchDeclNumConstructors0 (BranchHash -> Set Reference -> Keyed BranchHash (Set Reference)
forall k v. k -> v -> Keyed k v
Keyed Keyed BranchHash UnconflictedBranchView
k.key (BiMultimap Reference Name -> Set Reference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom Keyed BranchHash UnconflictedBranchView
k.value.defns.types))
                      pure (Nametree (DefnsF (Map NameSegment) Referent Reference)
-> Map Id Int -> PartialDeclNameLookup
lenientCheckDeclCoherency Keyed BranchHash UnconflictedBranchView
k.value.nametree Map Id Int
numConstructors)
               in \BranchHash
namespaceHash UnconflictedBranchView
unconflictedView -> Keyed BranchHash UnconflictedBranchView
-> Transaction PartialDeclNameLookup
get (BranchHash
-> UnconflictedBranchView
-> Keyed BranchHash UnconflictedBranchView
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash UnconflictedBranchView
unconflictedView)

        Cache
  (Keyed BranchHash UnconflictedBranchView)
  (Either IncoherentDeclReasons DeclNameLookup)
branchDeclNameLookupCache <- Word
-> m (Cache
        (Keyed BranchHash UnconflictedBranchView)
        (Either IncoherentDeclReasons DeclNameLookup))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
        let getBranchDeclNameLookup ::
              BranchHash ->
              UnconflictedBranchView ->
              Sqlite.Transaction (Either IncoherentDeclReasons DeclNameLookup)
            getBranchDeclNameLookup :: BranchHash
-> UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
getBranchDeclNameLookup =
              let get ::
                    Keyed BranchHash UnconflictedBranchView ->
                    Sqlite.Transaction (Either IncoherentDeclReasons DeclNameLookup)
                  get :: Keyed BranchHash UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
get =
                    Cache
  (Keyed BranchHash UnconflictedBranchView)
  (Either IncoherentDeclReasons DeclNameLookup)
-> (Keyed BranchHash UnconflictedBranchView
    -> Transaction (Either IncoherentDeclReasons DeclNameLookup))
-> Keyed BranchHash UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache
  (Keyed BranchHash UnconflictedBranchView)
  (Either IncoherentDeclReasons DeclNameLookup)
branchDeclNameLookupCache \Keyed BranchHash UnconflictedBranchView
k -> do
                      Map Id Int
numConstructors <- Keyed BranchHash (Set Reference) -> Transaction (Map Id Int)
getBranchDeclNumConstructors0 (BranchHash -> Set Reference -> Keyed BranchHash (Set Reference)
forall k v. k -> v -> Keyed k v
Keyed Keyed BranchHash UnconflictedBranchView
k.key (BiMultimap Reference Name -> Set Reference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom Keyed BranchHash UnconflictedBranchView
k.value.defns.types))
                      pure (Nametree (DefnsF (Map NameSegment) Referent Reference)
-> Map Id Int -> Either IncoherentDeclReasons DeclNameLookup
checkAllDeclCoherency Keyed BranchHash UnconflictedBranchView
k.value.nametree Map Id Int
numConstructors)
               in \BranchHash
namespaceHash UnconflictedBranchView
unconflictedView -> Keyed BranchHash UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
get (BranchHash
-> UnconflictedBranchView
-> Keyed BranchHash UnconflictedBranchView
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash UnconflictedBranchView
unconflictedView)

        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 CausalHash
hash =
              Transaction (Maybe (Branch m)) -> m (Maybe (Branch m))
forall a. Transaction a -> m a
runTransaction ((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))
-> Transaction (Maybe (Branch Transaction))
-> Transaction (Maybe (Branch m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CausalHash -> Transaction (Maybe (Branch Transaction))
getBranchForHashTx CausalHash
hash))

            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 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 -> Transaction Int
expectDeclNumConstructors :: Id -> Transaction Int
$sel:expectDeclNumConstructors:Codebase :: Id -> Transaction Int
expectDeclNumConstructors,
                  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,
                  CausalHash -> Transaction (Maybe (Branch Transaction))
getBranchForHashTx :: CausalHash -> Transaction (Maybe (Branch Transaction))
$sel:getBranchForHashTx:Codebase :: CausalHash -> Transaction (Maybe (Branch Transaction))
getBranchForHashTx,
                  BranchHash -> Set Reference -> Transaction (Map Id Int)
getBranchDeclNumConstructors :: BranchHash -> Set Reference -> Transaction (Map Id Int)
$sel:getBranchDeclNumConstructors:Codebase :: BranchHash -> Set Reference -> Transaction (Map Id Int)
getBranchDeclNumConstructors,
                  BranchHash
-> UnconflictedBranchView -> Transaction PartialDeclNameLookup
getBranchPartialDeclNameLookup :: BranchHash
-> UnconflictedBranchView -> Transaction PartialDeclNameLookup
$sel:getBranchPartialDeclNameLookup:Codebase :: BranchHash
-> UnconflictedBranchView -> Transaction PartialDeclNameLookup
getBranchPartialDeclNameLookup,
                  BranchHash
-> UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
getBranchDeclNameLookup :: BranchHash
-> UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
$sel:getBranchDeclNameLookup:Codebase :: BranchHash
-> UnconflictedBranchView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
getBranchDeclNameLookup,
                  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

-- A `Keyed k v` is just a pair `(k, v)`, but where `k` implies `v` (i.e. it's a hash of `v` or similar), and so `k`
-- can be used as the key in a map or set without requiring `Eq` or `Ord` on `v`.
--
-- Motivating use case: a cache of `PartialDeclNameLookup`, keyed by namespace hash id.
data Keyed k v = Keyed
  { forall k v. Keyed k v -> k
key :: k,
    forall k v. Keyed k v -> v
value :: v
  }
  deriving stock ((forall x. Keyed k v -> Rep (Keyed k v) x)
-> (forall x. Rep (Keyed k v) x -> Keyed k v)
-> Generic (Keyed k v)
forall x. Rep (Keyed k v) x -> Keyed k v
forall x. Keyed k v -> Rep (Keyed k v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k v x. Rep (Keyed k v) x -> Keyed k v
forall k v x. Keyed k v -> Rep (Keyed k v) x
$cfrom :: forall k v x. Keyed k v -> Rep (Keyed k v) x
from :: forall x. Keyed k v -> Rep (Keyed k v) x
$cto :: forall k v x. Rep (Keyed k v) x -> Keyed k v
to :: forall x. Rep (Keyed k v) x -> Keyed k v
Generic)

instance (Eq k) => Eq (Keyed k v) where
  Keyed k
x v
_ == :: Keyed k v -> Keyed k v -> Bool
== Keyed k
y v
_ = k
x k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
y

instance (Ord k) => Ord (Keyed k v) where
  Keyed k
x v
_ <= :: Keyed k v -> Keyed k v -> Bool
<= Keyed k
y v
_ = k
x k -> k -> Bool
forall a. Ord a => a -> a -> Bool
<= k
y