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

import Data.Char qualified as Char
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 (..))
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.ConstructorType (ConstructorType)
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' (..), TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.UnconflictedLocalDefnsView (UnconflictedLocalDefnsView (..))
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Cache qualified as Cache
import Unison.Util.Defns (Defns (..))
import UnliftIO (finally)
import UnliftIO qualified as UnliftIO
import UnliftIO.Concurrent qualified as UnliftIO
import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist)
import UnliftIO.Environment (lookupEnv)
import UnliftIO.STM

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
  (Keyed BranchHash UnconflictedLocalDefnsView)
  (Either IncoherentDeclReasons DeclNameLookup)
branchDeclNameLookupCache <- Word
-> m (Cache
        (Keyed BranchHash UnconflictedLocalDefnsView)
        (Either IncoherentDeclReasons DeclNameLookup))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
  Cache
  (Keyed BranchHash (Set TypeReference)) (Map TypeReferenceId Int)
branchDeclNumConstructorsCache <- Word
-> m (Cache
        (Keyed BranchHash (Set TypeReference)) (Map TypeReferenceId Int))
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
  Cache
  (Keyed BranchHash UnconflictedLocalDefnsView) PartialDeclNameLookup
branchPartialDeclNameLookupCache <- Word
-> m (Cache
        (Keyed BranchHash UnconflictedLocalDefnsView)
        PartialDeclNameLookup)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
10
  Cache Hash [Decl Symbol Ann]
declComponentCache <- Word -> m (Cache Hash [Decl Symbol Ann])
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
8192
  Cache TypeReferenceId Int
declNumConstructorsCache <- Word -> m (Cache TypeReferenceId Int)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
8192
  Cache TypeReference ConstructorType
declTypeCache <- Word -> m (Cache TypeReference ConstructorType)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
2048
  Cache Hash [(Term Symbol Ann, Type Symbol Ann)]
termComponentWithTypesCache <- Word -> m (Cache Hash [(Term Symbol Ann, Type Symbol Ann)])
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
8192

  let getDeclType :: TypeReference -> Transaction ConstructorType
getDeclType = Cache TypeReference ConstructorType
-> (TypeReference -> Transaction ConstructorType)
-> TypeReference
-> Transaction ConstructorType
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache TypeReference ConstructorType
declTypeCache TypeReference -> 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

  DebugName
-> DebugName
-> LocalOrRemote
-> MigrationStrategy
-> (TypeReference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> m (Either OpenCodebaseError ())
forall (m :: * -> *).
MonadUnliftIO m =>
DebugName
-> DebugName
-> LocalOrRemote
-> MigrationStrategy
-> (TypeReference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> m (Either OpenCodebaseError ())
ensureMigrated DebugName
debugName DebugName
root LocalOrRemote
localOrRemote MigrationStrategy
migrationStrategy TypeReference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer m (Either OpenCodebaseError ())
-> (Either OpenCodebaseError () -> 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
    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
        let expectDeclNumConstructors :: TypeReferenceId -> Sqlite.Transaction Int
            expectDeclNumConstructors :: TypeReferenceId -> Transaction Int
expectDeclNumConstructors =
              Cache TypeReferenceId Int
-> (TypeReferenceId -> Transaction Int)
-> TypeReferenceId
-> Transaction Int
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache TypeReferenceId Int
declNumConstructorsCache TypeReferenceId -> Transaction Int
Operations.expectDeclNumConstructors

        let getBranchForHashTx :: CausalHash -> Sqlite.Transaction (Maybe (Branch Sqlite.Transaction))
            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
-> (TypeReference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
CodebaseOps.getBranchForHash BranchCache Transaction
branchLoadCache TypeReference -> Transaction ConstructorType
getDeclType)

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

        let 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
hash = 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
hash 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 ()

        let getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
            getTermComponentWithTypes :: Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes =
              Cache Hash [(Term Symbol Ann, Type Symbol Ann)]
-> (Hash
    -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)]))
-> Hash
-> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction
                Cache Hash [(Term Symbol Ann, Type Symbol Ann)]
termComponentWithTypesCache
                ((TypeReference -> Transaction ConstructorType)
-> Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
CodebaseOps.getTermComponentWithTypes TypeReference -> Transaction ConstructorType
getDeclType)

        let getTypeDeclarationComponent :: Hash -> Sqlite.Transaction (Maybe [Decl Symbol Ann])
            getTypeDeclarationComponent :: Hash -> Transaction (Maybe [Decl Symbol Ann])
getTypeDeclarationComponent =
              Cache Hash [Decl Symbol Ann]
-> (Hash -> Transaction (Maybe [Decl Symbol Ann]))
-> Hash
-> Transaction (Maybe [Decl Symbol Ann])
forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
CodebaseOps.makeMaybeCachedTransaction
                Cache Hash [Decl Symbol Ann]
declComponentCache
                Hash -> Transaction (Maybe [Decl Symbol Ann])
CodebaseOps.getDeclComponent

        let codebase :: Codebase m Symbol Ann
codebase =
              C.Codebase
                { $sel:getTerm:Codebase :: TypeReferenceId -> Transaction (Maybe (Term Symbol Ann))
getTerm =
                    \(Reference.Id Hash
hash Pos
pos) -> do
                      Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes Hash
hash Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
-> (Maybe [(Term Symbol Ann, Type Symbol Ann)]
    -> Maybe (Term Symbol Ann))
-> Transaction (Maybe (Term Symbol Ann))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                        Just [(Term Symbol Ann, Type Symbol Ann)]
component -> Term Symbol Ann -> Maybe (Term Symbol Ann)
forall a. a -> Maybe a
Just ((Term Symbol Ann, Type Symbol Ann) -> Term Symbol Ann
forall a b. (a, b) -> a
fst ([(Term Symbol Ann, Type Symbol Ann)]
-> Pos -> (Term Symbol Ann, Type Symbol Ann)
forall a. HasCallStack => [a] -> Pos -> a
Reference.getComponentElem [(Term Symbol Ann, Type Symbol Ann)]
component Pos
pos))
                        Maybe [(Term Symbol Ann, Type Symbol Ann)]
Nothing -> Maybe (Term Symbol Ann)
forall a. Maybe a
Nothing,
                  $sel:getTypeOfTermImpl:Codebase :: TypeReferenceId -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl =
                    \(Reference.Id Hash
hash Pos
pos) -> do
                      Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes Hash
hash Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
-> (Maybe [(Term Symbol Ann, Type Symbol Ann)]
    -> Maybe (Type Symbol Ann))
-> Transaction (Maybe (Type Symbol Ann))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                        Just [(Term Symbol Ann, Type Symbol Ann)]
component -> Type Symbol Ann -> Maybe (Type Symbol Ann)
forall a. a -> Maybe a
Just ((Term Symbol Ann, Type Symbol Ann) -> Type Symbol Ann
forall a b. (a, b) -> b
snd ([(Term Symbol Ann, Type Symbol Ann)]
-> Pos -> (Term Symbol Ann, Type Symbol Ann)
forall a. HasCallStack => [a] -> Pos -> a
Reference.getComponentElem [(Term Symbol Ann, Type Symbol Ann)]
component Pos
pos))
                        Maybe [(Term Symbol Ann, Type Symbol Ann)]
Nothing -> Maybe (Type Symbol Ann)
forall a. Maybe a
Nothing,
                  $sel:getTypeDeclaration:Codebase :: TypeReferenceId -> Transaction (Maybe (Decl Symbol Ann))
getTypeDeclaration =
                    \(Reference.Id Hash
hash Pos
pos) -> do
                      Hash -> Transaction (Maybe [Decl Symbol Ann])
getTypeDeclarationComponent Hash
hash Transaction (Maybe [Decl Symbol Ann])
-> (Maybe [Decl Symbol Ann] -> Maybe (Decl Symbol Ann))
-> Transaction (Maybe (Decl Symbol Ann))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                        Just [Decl Symbol Ann]
component -> Decl Symbol Ann -> Maybe (Decl Symbol Ann)
forall a. a -> Maybe a
Just ([Decl Symbol Ann] -> Pos -> Decl Symbol Ann
forall a. HasCallStack => [a] -> Pos -> a
Reference.getComponentElem [Decl Symbol Ann]
component Pos
pos)
                        Maybe [Decl Symbol Ann]
Nothing -> Maybe (Decl Symbol Ann)
forall a. Maybe a
Nothing,
                  Hash -> Transaction (Maybe [Decl Symbol Ann])
getTypeDeclarationComponent :: Hash -> Transaction (Maybe [Decl Symbol Ann])
$sel:getTypeDeclarationComponent:Codebase :: Hash -> Transaction (Maybe [Decl Symbol Ann])
getTypeDeclarationComponent,
                  TypeReference -> Transaction ConstructorType
getDeclType :: TypeReference -> Transaction ConstructorType
$sel:getDeclType:Codebase :: TypeReference -> Transaction ConstructorType
getDeclType,
                  TypeReferenceId -> Transaction Int
expectDeclNumConstructors :: TypeReferenceId -> Transaction Int
$sel:expectDeclNumConstructors:Codebase :: TypeReferenceId -> Transaction Int
expectDeclNumConstructors,
                  $sel:putTerm:Codebase :: TypeReferenceId
-> Term Symbol Ann -> Type Symbol Ann -> Transaction ()
putTerm = TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> TypeReferenceId
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
CodebaseOps.putTerm TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer,
                  $sel:putTermComponent:Codebase :: 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,
                  $sel:putTypeDeclaration:Codebase :: TypeReferenceId -> Decl Symbol Ann -> Transaction ()
putTypeDeclaration = TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> TypeReferenceId
-> Decl Symbol Ann
-> Transaction ()
CodebaseOps.putTypeDeclaration TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer,
                  $sel:putTypeDeclarationComponent:Codebase :: Hash -> [Decl Symbol Ann] -> Transaction ()
putTypeDeclarationComponent = TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Hash
-> [Decl Symbol Ann]
-> Transaction ()
CodebaseOps.putTypeDeclarationComponent TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer,
                  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,
                  $sel:getBranchDeclNumConstructors:Codebase :: BranchHash
-> Set TypeReference -> Transaction (Map TypeReferenceId Int)
getBranchDeclNumConstructors =
                    \BranchHash
namespaceHash Set TypeReference
refs -> Keyed BranchHash (Set TypeReference)
-> Transaction (Map TypeReferenceId Int)
getBranchDeclNumConstructors0 (BranchHash
-> Set TypeReference -> Keyed BranchHash (Set TypeReference)
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash Set TypeReference
refs),
                  $sel:getBranchPartialDeclNameLookup:Codebase :: BranchHash
-> UnconflictedLocalDefnsView -> Transaction PartialDeclNameLookup
getBranchPartialDeclNameLookup =
                    let get :: Keyed BranchHash UnconflictedLocalDefnsView -> Sqlite.Transaction PartialDeclNameLookup
                        get :: Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
get =
                          Cache
  (Keyed BranchHash UnconflictedLocalDefnsView) PartialDeclNameLookup
-> (Keyed BranchHash UnconflictedLocalDefnsView
    -> Transaction PartialDeclNameLookup)
-> Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache
  (Keyed BranchHash UnconflictedLocalDefnsView) PartialDeclNameLookup
branchPartialDeclNameLookupCache \Keyed BranchHash UnconflictedLocalDefnsView
k -> do
                            Map TypeReferenceId Int
numConstructors <-
                              Keyed BranchHash (Set TypeReference)
-> Transaction (Map TypeReferenceId Int)
getBranchDeclNumConstructors0
                                (BranchHash
-> Set TypeReference -> Keyed BranchHash (Set TypeReference)
forall k v. k -> v -> Keyed k v
Keyed Keyed BranchHash UnconflictedLocalDefnsView
k.key (BiMultimap TypeReference Name -> Set TypeReference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom Keyed BranchHash UnconflictedLocalDefnsView
k.value.defns.types))
                            pure (Nametree (DefnsF (Map NameSegment) Referent TypeReference)
-> Map TypeReferenceId Int -> PartialDeclNameLookup
lenientCheckDeclCoherency Keyed BranchHash UnconflictedLocalDefnsView
k.value.nametree Map TypeReferenceId Int
numConstructors)
                     in \BranchHash
namespaceHash UnconflictedLocalDefnsView
unconflictedView -> Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
get (BranchHash
-> UnconflictedLocalDefnsView
-> Keyed BranchHash UnconflictedLocalDefnsView
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash UnconflictedLocalDefnsView
unconflictedView),
                  $sel:getBranchDeclNameLookup:Codebase :: BranchHash
-> UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
getBranchDeclNameLookup =
                    let get ::
                          Keyed BranchHash UnconflictedLocalDefnsView ->
                          Sqlite.Transaction (Either IncoherentDeclReasons DeclNameLookup)
                        get :: Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
get =
                          Cache
  (Keyed BranchHash UnconflictedLocalDefnsView)
  (Either IncoherentDeclReasons DeclNameLookup)
-> (Keyed BranchHash UnconflictedLocalDefnsView
    -> Transaction (Either IncoherentDeclReasons DeclNameLookup))
-> Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
CodebaseOps.makeCachedTransaction Cache
  (Keyed BranchHash UnconflictedLocalDefnsView)
  (Either IncoherentDeclReasons DeclNameLookup)
branchDeclNameLookupCache \Keyed BranchHash UnconflictedLocalDefnsView
k -> do
                            Map TypeReferenceId Int
numConstructors <-
                              Keyed BranchHash (Set TypeReference)
-> Transaction (Map TypeReferenceId Int)
getBranchDeclNumConstructors0
                                (BranchHash
-> Set TypeReference -> Keyed BranchHash (Set TypeReference)
forall k v. k -> v -> Keyed k v
Keyed Keyed BranchHash UnconflictedLocalDefnsView
k.key (BiMultimap TypeReference Name -> Set TypeReference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom Keyed BranchHash UnconflictedLocalDefnsView
k.value.defns.types))
                            pure (Nametree (DefnsF (Map NameSegment) Referent TypeReference)
-> Map TypeReferenceId Int
-> Either IncoherentDeclReasons DeclNameLookup
checkAllDeclCoherency Keyed BranchHash UnconflictedLocalDefnsView
k.value.nametree Map TypeReferenceId Int
numConstructors)
                     in \BranchHash
namespaceHash UnconflictedLocalDefnsView
unconflictedView -> Keyed BranchHash UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
get (BranchHash
-> UnconflictedLocalDefnsView
-> Keyed BranchHash UnconflictedLocalDefnsView
forall k v. k -> v -> Keyed k v
Keyed BranchHash
namespaceHash UnconflictedLocalDefnsView
unconflictedView),
                  Branch m -> m ()
putBranch :: Branch m -> m ()
$sel:putBranch:Codebase :: Branch m -> m ()
putBranch,
                  $sel:putBranchTx:Codebase :: Branch Transaction -> Transaction ()
putBranchTx = \Branch Transaction
branch -> do
                    IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Cache CausalHash (Branch Transaction)
-> CausalHash -> Branch Transaction -> IO ()
forall (m :: * -> *) k v. MonadIO m => Cache k v -> k -> v -> m ()
Cache.insert Cache CausalHash (Branch Transaction)
rootBranchCacheTx (Branch Transaction -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch Transaction
branch) Branch Transaction
branch)
                    Branch Transaction -> Transaction ()
CodebaseOps.putBranch Branch Transaction
branch,
                  $sel:getWatch:Codebase :: DebugName
-> TypeReferenceId -> Transaction (Maybe (Term Symbol Ann))
getWatch = (TypeReference -> Transaction ConstructorType)
-> DebugName
-> TypeReferenceId
-> Transaction (Maybe (Term Symbol Ann))
CodebaseOps.getWatch TypeReference -> Transaction ConstructorType
getDeclType,
                  $sel:termsOfTypeImpl:Codebase :: TypeReference -> Transaction (Set Id)
termsOfTypeImpl = (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Transaction (Set Id)
CodebaseOps.termsOfTypeImpl TypeReference -> Transaction ConstructorType
getDeclType,
                  $sel:termsMentioningTypeImpl:Codebase :: TypeReference -> Transaction (Set Id)
termsMentioningTypeImpl = (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Transaction (Set Id)
CodebaseOps.termsMentioningTypeImpl TypeReference -> Transaction ConstructorType
getDeclType,
                  $sel:filterTermsByReferenceIdHavingTypeImpl:Codebase :: TypeReference
-> Set TypeReferenceId -> Transaction (Set TypeReferenceId)
filterTermsByReferenceIdHavingTypeImpl = TypeReference
-> Set TypeReferenceId -> Transaction (Set TypeReferenceId)
CodebaseOps.filterReferencesHavingTypeImpl,
                  $sel:filterTermsByReferentIdHavingTypeImpl:Codebase :: TypeReference -> Set Id -> Transaction (Set Id)
filterTermsByReferentIdHavingTypeImpl = (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Set Id -> Transaction (Set Id)
CodebaseOps.filterReferentsHavingTypeImpl TypeReference -> Transaction ConstructorType
getDeclType,
                  $sel:termReferentsByPrefix:Codebase :: ShortHash -> Transaction (Set Id)
termReferentsByPrefix = (TypeReference -> Transaction ConstructorType)
-> ShortHash -> Transaction (Set Id)
CodebaseOps.referentsByPrefix TypeReference -> Transaction ConstructorType
getDeclType,
                  $sel:withConnection:Codebase :: forall x. (Connection -> m x) -> m x
withConnection = DebugName -> DebugName -> (Connection -> m x) -> m x
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
debugName DebugName
root,
                  $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
    runTransaction :: Sqlite.Transaction a -> m a
    runTransaction :: forall a. Transaction a -> m a
runTransaction Transaction a
action =
      DebugName -> DebugName -> (Connection -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
debugName DebugName
root \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

ensureMigrated ::
  (MonadUnliftIO m) =>
  Codebase.DebugName ->
  CodebasePath ->
  LocalOrRemote ->
  MigrationStrategy ->
  (Reference -> Sqlite.Transaction ConstructorType) ->
  TVar (Map Hash CodebaseOps.TermBufferEntry) ->
  TVar (Map Hash CodebaseOps.DeclBufferEntry) ->
  m (Either OpenCodebaseError ())
ensureMigrated :: forall (m :: * -> *).
MonadUnliftIO m =>
DebugName
-> DebugName
-> LocalOrRemote
-> MigrationStrategy
-> (TypeReference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> m (Either OpenCodebaseError ())
ensureMigrated DebugName
debugName DebugName
root LocalOrRemote
localOrRemote MigrationStrategy
migrationStrategy TypeReference -> Transaction ConstructorType
getDeclType TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer = do
  DebugName
-> DebugName
-> (Connection -> m (Either OpenCodebaseError ()))
-> m (Either OpenCodebaseError ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
DebugName -> DebugName -> (Connection -> m a) -> m a
withConnection DebugName
debugName DebugName
root \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
            Bool
shouldPrompt <-
              DebugName -> m (Maybe DebugName)
forall (m :: * -> *). MonadIO m => DebugName -> m (Maybe DebugName)
lookupEnv DebugName
"UNISON_MIGRATION" m (Maybe DebugName) -> (Maybe DebugName -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just ((Char -> Char) -> DebugName -> DebugName
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
Char.toLower -> DebugName
"auto") -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                Maybe DebugName
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            Bool
-> BackupStrategy
-> VacuumStrategy
-> m (Either OpenCodebaseError ())
doMigrate Bool
shouldPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy
          MigrateAutomatically BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy -> Bool
-> BackupStrategy
-> VacuumStrategy
-> m (Either OpenCodebaseError ())
doMigrate Bool
False BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy
        where
          doMigrate :: Bool
-> BackupStrategy
-> VacuumStrategy
-> m (Either OpenCodebaseError ())
doMigrate Bool
shouldPrompt BackupStrategy
backupStrategy VacuumStrategy
vacuumStrategy =
            LocalOrRemote
-> DebugName
-> (TypeReference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
forall (m :: * -> *).
MonadIO m =>
LocalOrRemote
-> DebugName
-> (TypeReference -> Transaction ConstructorType)
-> TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Bool
-> BackupStrategy
-> VacuumStrategy
-> Connection
-> m (Either OpenCodebaseError ())
Migrations.ensureCodebaseIsUpToDate
              LocalOrRemote
localOrRemote
              DebugName
root
              TypeReference -> Transaction ConstructorType
getDeclType
              TVar (Map Hash TermBufferEntry)
termBuffer
              TVar (Map Hash DeclBufferEntry)
declBuffer
              Bool
shouldPrompt
              BackupStrategy
backupStrategy
              VacuumStrategy
vacuumStrategy
              Connection
conn

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