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

-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction
-- monad.
--
-- The Codebase record-of-functions wraps this functionality, and runs each transaction to IO, so that the operations'
-- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'.
module Unison.Codebase.SqliteCodebase.Operations where

import Data.Bitraversable (bitraverse)
import Data.Either.Extra ()
import Data.List qualified as List
import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.UUID.V4 qualified as UUID
import U.Codebase.HashTags (CausalHash (unCausalHash), PatchHash)
import U.Codebase.Reference qualified as C.Reference
import U.Codebase.Referent qualified as C.Referent
import U.Codebase.Sqlite.DbId (ObjectId)
import U.Codebase.Sqlite.DbId qualified as Db
import U.Codebase.Sqlite.ObjectType qualified as OT
import U.Codebase.Sqlite.Operations qualified as Ops
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.Project qualified as Project
import U.Codebase.Sqlite.ProjectBranch (ProjectBranchRow (..))
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import Unison.Builtin qualified as Builtins
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType qualified as CT
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as Decl
import Unison.Hash (Hash)
import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Project (defaultBranchName)
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.ShortHash (ShortHash)
import Unison.ShortHash qualified as ShortHash
import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite
import Unison.Sqlite.Transaction qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Util.Cache qualified as Cache
import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as UF
import UnliftIO.STM

createSchema :: Transaction ()
createSchema :: Transaction ()
createSchema = do
  Transaction ()
Q.runCreateSql
  Transaction ()
Q.addTempEntityTables
  Transaction ()
Q.addNamespaceStatsTables
  Transaction ()
Q.addReflogTable
  Transaction ()
Q.fixScopedNameLookupTables
  Transaction ()
Q.addProjectTables
  Transaction ()
Q.addMostRecentBranchTable
  Transaction ()
Q.addNameLookupMountTables
  Transaction ()
Q.addMostRecentNamespaceTable
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
Sqlite.execute Sql
insertSchemaVersionSql
  Transaction ()
Q.addSquashResultTable
  Transaction ()
Q.addCurrentProjectPathTable
  Transaction ()
Q.addProjectBranchReflogTable
  Transaction ()
Q.addProjectBranchCausalHashIdColumn
  Transaction ()
Q.addProjectBranchLastAccessedColumn
  Transaction ()
Q.addMergeBranchTables
  Transaction ()
Q.addUpdateBranchTable
  Transaction ()
Q.addDerivedDependentsByDependencyIndex
  Transaction ()
Q.addUpgradeBranchTable
  (CausalHash
_, CausalHashId
emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
emptyCausalHash
  (Project
_, ProjectBranchRow {ProjectId
projectId :: ProjectId
$sel:projectId:ProjectBranchRow :: ProjectBranchRow -> ProjectId
projectId, ProjectBranchId
branchId :: ProjectBranchId
$sel:branchId:ProjectBranchRow :: ProjectBranchRow -> ProjectBranchId
branchId}) <-
    ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranchRow)
insertProjectAndBranch ProjectName
scratchProjectName ProjectBranchName
scratchBranchName CausalHashId
emptyCausalHashId
  ProjectId -> ProjectBranchId -> [NameSegment] -> Transaction ()
Q.setCurrentProjectPath ProjectId
projectId ProjectBranchId
branchId []
  where
    scratchProjectName :: ProjectName
scratchProjectName = Text -> ProjectName
UnsafeProjectName Text
"scratch"
    scratchBranchName :: ProjectBranchName
scratchBranchName = ProjectBranchName
defaultBranchName
    currentSchemaVersion :: SchemaVersion
currentSchemaVersion = SchemaVersion
Q.currentSchemaVersion
    insertSchemaVersionSql :: Sql
insertSchemaVersionSql =
      [Sqlite.sql|
        INSERT INTO schema_version (version)
        VALUES (:currentSchemaVersion)
      |]

------------------------------------------------------------------------------------------------------------------------
-- Buffer entry

-- 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

-- an entry for a single hash
data BufferEntry a = BufferEntry
  { -- First, you are waiting for the cycle to fill up with all elements
    -- Then, you check: are all dependencies of the cycle in the db?
    --   If yes: write yourself to database and trigger check of dependents
    --   If no: just wait, do nothing
    forall a. BufferEntry a -> Maybe ConstructorId
beComponentTargetSize :: Maybe Word64,
    forall a. BufferEntry a -> Map ConstructorId a
beComponent :: Map Reference.Pos a,
    forall a. BufferEntry a -> Set Hash
beMissingDependencies :: Set Hash,
    forall a. BufferEntry a -> Set Hash
beWaitingDependents :: Set Hash
  }
  deriving (BufferEntry a -> BufferEntry a -> Bool
(BufferEntry a -> BufferEntry a -> Bool)
-> (BufferEntry a -> BufferEntry a -> Bool) -> Eq (BufferEntry a)
forall a. Eq a => BufferEntry a -> BufferEntry a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => BufferEntry a -> BufferEntry a -> Bool
== :: BufferEntry a -> BufferEntry a -> Bool
$c/= :: forall a. Eq a => BufferEntry a -> BufferEntry a -> Bool
/= :: BufferEntry a -> BufferEntry a -> Bool
Eq, Int -> BufferEntry a -> ShowS
[BufferEntry a] -> ShowS
BufferEntry a -> WatchKind
(Int -> BufferEntry a -> ShowS)
-> (BufferEntry a -> WatchKind)
-> ([BufferEntry a] -> ShowS)
-> Show (BufferEntry a)
forall a. Show a => Int -> BufferEntry a -> ShowS
forall a. Show a => [BufferEntry a] -> ShowS
forall a. Show a => BufferEntry a -> WatchKind
forall a.
(Int -> a -> ShowS) -> (a -> WatchKind) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BufferEntry a -> ShowS
showsPrec :: Int -> BufferEntry a -> ShowS
$cshow :: forall a. Show a => BufferEntry a -> WatchKind
show :: BufferEntry a -> WatchKind
$cshowList :: forall a. Show a => [BufferEntry a] -> ShowS
showList :: [BufferEntry a] -> ShowS
Show)

prettyBufferEntry :: (Show a) => Hash -> BufferEntry a -> String
prettyBufferEntry :: forall a. Show a => Hash -> BufferEntry a -> WatchKind
prettyBufferEntry (Hash
h :: Hash) BufferEntry {Maybe ConstructorId
Map ConstructorId a
Set Hash
$sel:beComponentTargetSize:BufferEntry :: forall a. BufferEntry a -> Maybe ConstructorId
$sel:beComponent:BufferEntry :: forall a. BufferEntry a -> Map ConstructorId a
$sel:beMissingDependencies:BufferEntry :: forall a. BufferEntry a -> Set Hash
$sel:beWaitingDependents:BufferEntry :: forall a. BufferEntry a -> Set Hash
beComponentTargetSize :: Maybe ConstructorId
beComponent :: Map ConstructorId a
beMissingDependencies :: Set Hash
beWaitingDependents :: Set Hash
..} =
  WatchKind
"BufferEntry "
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash -> WatchKind
forall a. Show a => a -> WatchKind
show Hash
h
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"\n"
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"  { beComponentTargetSize = "
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe ConstructorId -> WatchKind
forall a. Show a => a -> WatchKind
show Maybe ConstructorId
beComponentTargetSize
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"\n"
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"  , beComponent = "
    WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ if Map ConstructorId a -> Int
forall k a. Map k a -> Int
Map.size Map ConstructorId a
beComponent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
      then [(ConstructorId, a)] -> WatchKind
forall a. Show a => a -> WatchKind
show ([(ConstructorId, a)] -> WatchKind)
-> [(ConstructorId, a)] -> WatchKind
forall a b. (a -> b) -> a -> b
$ Map ConstructorId a -> [(ConstructorId, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ConstructorId a
beComponent
      else
        [(ConstructorId, a)]
-> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
forall (f :: * -> *) a.
(Foldable f, Show a) =>
f a -> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
mkString (Map ConstructorId a -> [(ConstructorId, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ConstructorId a
beComponent) (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"\n      [ ") WatchKind
"      , " (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"]\n")
          WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"  , beMissingDependencies ="
          WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ if Set Hash -> Int
forall a. Set a -> Int
Set.size Set Hash
beMissingDependencies Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            then [Hash] -> WatchKind
forall a. Show a => a -> WatchKind
show ([Hash] -> WatchKind) -> [Hash] -> WatchKind
forall a b. (a -> b) -> a -> b
$ Set Hash -> [Hash]
forall a. Set a -> [a]
Set.toList Set Hash
beMissingDependencies
            else
              [Hash]
-> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
forall (f :: * -> *) a.
(Foldable f, Show a) =>
f a -> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
mkString (Set Hash -> [Hash]
forall a. Set a -> [a]
Set.toList Set Hash
beMissingDependencies) (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"\n      [ ") WatchKind
"      , " (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"]\n")
                WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"  , beWaitingDependents ="
                WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ if Set Hash -> Int
forall a. Set a -> Int
Set.size Set Hash
beWaitingDependents Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
                  then [Hash] -> WatchKind
forall a. Show a => a -> WatchKind
show ([Hash] -> WatchKind) -> [Hash] -> WatchKind
forall a b. (a -> b) -> a -> b
$ Set Hash -> [Hash]
forall a. Set a -> [a]
Set.toList Set Hash
beWaitingDependents
                  else
                    [Hash]
-> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
forall (f :: * -> *) a.
(Foldable f, Show a) =>
f a -> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
mkString (Set Hash -> [Hash]
forall a. Set a -> [a]
Set.toList Set Hash
beWaitingDependents) (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"\n      [ ") WatchKind
"      , " (WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
"]\n")
                      WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
"  }"
  where
    mkString :: (Foldable f, Show a) => f a -> Maybe String -> String -> Maybe String -> String
    mkString :: forall (f :: * -> *) a.
(Foldable f, Show a) =>
f a -> Maybe WatchKind -> WatchKind -> Maybe WatchKind -> WatchKind
mkString f a
as Maybe WatchKind
start WatchKind
middle Maybe WatchKind
end =
      WatchKind -> Maybe WatchKind -> WatchKind
forall a. a -> Maybe a -> a
fromMaybe WatchKind
"" Maybe WatchKind
start WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind -> [WatchKind] -> WatchKind
forall a. [a] -> [[a]] -> [a]
List.intercalate WatchKind
middle (a -> WatchKind
forall a. Show a => a -> WatchKind
show (a -> WatchKind) -> [a] -> [WatchKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
as) WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind -> Maybe WatchKind -> WatchKind
forall a. a -> Maybe a -> a
fromMaybe WatchKind
"" Maybe WatchKind
end

type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann)

type DeclBufferEntry = BufferEntry (Decl Symbol Ann)

getBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer :: forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer TVar (Map Hash (BufferEntry a))
tv Hash
h = do
  (Hash -> Map Hash (BufferEntry a) -> Maybe (BufferEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash
h (Map Hash (BufferEntry a) -> Maybe (BufferEntry a))
-> IO (Map Hash (BufferEntry a)) -> IO (Maybe (BufferEntry a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Hash (BufferEntry a)) -> IO (Map Hash (BufferEntry a))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map Hash (BufferEntry a))
tv) IO (Maybe (BufferEntry a))
-> (Maybe (BufferEntry a) -> BufferEntry a) -> IO (BufferEntry a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just BufferEntry a
e -> BufferEntry a
e
    Maybe (BufferEntry a)
Nothing -> Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
forall a.
Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
BufferEntry Maybe ConstructorId
forall a. Maybe a
Nothing Map ConstructorId a
forall k a. Map k a
Map.empty Set Hash
forall a. Set a
Set.empty Set Hash
forall a. Set a
Set.empty

putBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer :: forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer TVar (Map Hash (BufferEntry a))
tv Hash
h BufferEntry a
e =
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map Hash (BufferEntry a))
-> (Map Hash (BufferEntry a) -> Map Hash (BufferEntry a)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map Hash (BufferEntry a))
tv (Hash
-> BufferEntry a
-> Map Hash (BufferEntry a)
-> Map Hash (BufferEntry a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Hash
h BufferEntry a
e)

removeBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
removeBuffer :: forall a. TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
removeBuffer TVar (Map Hash (BufferEntry a))
tv Hash
h =
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map Hash (BufferEntry a))
-> (Map Hash (BufferEntry a) -> Map Hash (BufferEntry a)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map Hash (BufferEntry a))
tv (Hash -> Map Hash (BufferEntry a) -> Map Hash (BufferEntry a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Hash
h)

addBufferDependent :: Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
addBufferDependent :: forall a. Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
addBufferDependent Hash
dependent TVar (Map Hash (BufferEntry a))
tv Hash
dependency = do
  BufferEntry a
be <- TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer TVar (Map Hash (BufferEntry a))
tv Hash
dependency
  TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer TVar (Map Hash (BufferEntry a))
tv Hash
dependency BufferEntry a
be {beWaitingDependents = Set.insert dependent $ beWaitingDependents be}

tryFlushBuffer ::
  forall a.
  (Show a) =>
  TVar (Map Hash (BufferEntry a)) ->
  (Hash -> [a] -> Transaction ()) ->
  (Hash -> Transaction ()) ->
  Hash ->
  Transaction ()
tryFlushBuffer :: forall a.
Show a =>
TVar (Map Hash (BufferEntry a))
-> (Hash -> [a] -> Transaction ())
-> (Hash -> Transaction ())
-> Hash
-> Transaction ()
tryFlushBuffer TVar (Map Hash (BufferEntry a))
buf Hash -> [a] -> Transaction ()
saveComponent Hash -> Transaction ()
tryWaiting Hash
h =
  -- skip if it has already been flushed
  Transaction Bool -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Hash -> Transaction Bool
Ops.objectExistsForHash Hash
h) do
    BufferEntry Maybe ConstructorId
size Map ConstructorId a
comp (Hash -> Set Hash -> Set Hash
forall a. Ord a => a -> Set a -> Set a
Set.delete Hash
h -> Set Hash
missing) Set Hash
waiting <- IO (BufferEntry a) -> Transaction (BufferEntry a)
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer TVar (Map Hash (BufferEntry a))
buf Hash
h)
    case Maybe ConstructorId
size of
      Just ConstructorId
size -> do
        [Hash]
missing' <- (Hash -> Transaction Bool) -> [Hash] -> Transaction [Hash]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Transaction Bool -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Transaction Bool -> Transaction Bool)
-> (Hash -> Transaction Bool) -> Hash -> Transaction Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction Bool
Ops.objectExistsForHash) (Set Hash -> [Hash]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Hash
missing)
        if [Hash] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Hash]
missing' Bool -> Bool -> Bool
&& ConstructorId
size ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map ConstructorId a -> Int
forall a. Map ConstructorId a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map ConstructorId a
comp)
          then do
            Hash -> [a] -> Transaction ()
saveComponent Hash
h (Map ConstructorId a -> [a]
forall a. Map ConstructorId a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map ConstructorId a
comp)
            IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
forall a. TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
removeBuffer TVar (Map Hash (BufferEntry a))
buf Hash
h)
            (Hash -> Transaction ()) -> Set Hash -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Hash -> Transaction ()
tryWaiting Set Hash
waiting
          else IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO do
            TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer TVar (Map Hash (BufferEntry a))
buf Hash
h (BufferEntry a -> IO ()) -> BufferEntry a -> IO ()
forall a b. (a -> b) -> a -> b
$
              Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
forall a.
Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
BufferEntry (ConstructorId -> Maybe ConstructorId
forall a. a -> Maybe a
Just ConstructorId
size) Map ConstructorId a
comp ([Hash] -> Set Hash
forall a. Ord a => [a] -> Set a
Set.fromList [Hash]
missing') Set Hash
waiting
      Maybe ConstructorId
Nothing ->
        -- it's never even been added, so there's nothing to do.
        () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

------------------------------------------------------------------------------------------------------------------------
-- Operations

getTerm ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  Reference.Id ->
  Transaction (Maybe (Term Symbol Ann))
getTerm :: (Reference -> Transaction ConstructorType)
-> Id -> Transaction (Maybe (Term Symbol Ann))
getTerm Reference -> Transaction ConstructorType
doGetDeclType (Reference.Id Hash
h ConstructorId
i) =
  MaybeT Transaction (Term Symbol Ann)
-> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    Term Symbol
term2 <- Id -> MaybeT Transaction (Term Symbol)
Ops.loadTermByReference (Hash -> ConstructorId -> Id
forall h. h -> ConstructorId -> Id' h
C.Reference.Id Hash
h ConstructorId
i)
    Transaction (Term Symbol Ann)
-> MaybeT Transaction (Term Symbol Ann)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hash
-> (Reference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (Reference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h Reference -> Transaction ConstructorType
doGetDeclType Term Symbol
term2)

getDeclType :: C.Reference.Reference -> Transaction CT.ConstructorType
getDeclType :: Reference -> Transaction ConstructorType
getDeclType = \case
  C.Reference.ReferenceBuiltin Text
t -> ConstructorType -> Transaction ConstructorType
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ConstructorType
Builtins.expectBuiltinConstructorType Text
t)
  C.Reference.ReferenceDerived Id
i -> Id -> Transaction ConstructorType
expectDeclTypeById Id
i

expectDeclTypeById :: C.Reference.Id -> Transaction CT.ConstructorType
expectDeclTypeById :: Id -> Transaction ConstructorType
expectDeclTypeById = (DeclType -> ConstructorType)
-> Transaction DeclType -> Transaction ConstructorType
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeclType -> ConstructorType
Cv.decltype2to1 (Transaction DeclType -> Transaction ConstructorType)
-> (Id -> Transaction DeclType)
-> Id
-> Transaction ConstructorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Transaction DeclType
Ops.expectDeclTypeById

getTypeOfTermImpl :: Reference.Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl :: Id -> Transaction (Maybe (Type Symbol Ann))
getTypeOfTermImpl (Reference.Id Hash
h ConstructorId
i) =
  MaybeT Transaction (Type Symbol Ann)
-> Transaction (Maybe (Type Symbol Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    Type Symbol
type2 <- Id -> MaybeT Transaction (Type Symbol)
Ops.loadTypeOfTermByTermReference (Hash -> ConstructorId -> Id
forall h. h -> ConstructorId -> Id' h
C.Reference.Id Hash
h ConstructorId
i)
    pure (Type Symbol -> Type Symbol Ann
Cv.ttype2to1 Type Symbol
type2)

getTermComponentWithTypes ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  Hash ->
  Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes :: (Reference -> Transaction ConstructorType)
-> Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes Reference -> Transaction ConstructorType
doGetDeclType Hash
h =
  MaybeT Transaction [(Term Symbol Ann, Type Symbol Ann)]
-> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    [(Term Symbol, Type Symbol)]
tms <- Hash -> MaybeT Transaction [(Term Symbol, Type Symbol)]
Ops.loadTermComponent Hash
h
    [(Term Symbol, Type Symbol)]
-> ((Term Symbol, Type Symbol)
    -> MaybeT Transaction (Term Symbol Ann, Type Symbol Ann))
-> MaybeT Transaction [(Term Symbol Ann, Type Symbol Ann)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Term Symbol, Type Symbol)]
tms ((Term Symbol -> MaybeT Transaction (Term Symbol Ann))
-> (Type Symbol -> MaybeT Transaction (Type Symbol Ann))
-> (Term Symbol, Type Symbol)
-> MaybeT Transaction (Term Symbol Ann, Type Symbol Ann)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (Transaction (Term Symbol Ann)
-> MaybeT Transaction (Term Symbol Ann)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Term Symbol Ann)
 -> MaybeT Transaction (Term Symbol Ann))
-> (Term Symbol -> Transaction (Term Symbol Ann))
-> Term Symbol
-> MaybeT Transaction (Term Symbol Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash
-> (Reference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (Reference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h Reference -> Transaction ConstructorType
doGetDeclType) (Type Symbol Ann -> MaybeT Transaction (Type Symbol Ann)
forall a. a -> MaybeT Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type Symbol Ann -> MaybeT Transaction (Type Symbol Ann))
-> (Type Symbol -> Type Symbol Ann)
-> Type Symbol
-> MaybeT Transaction (Type Symbol Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type Symbol -> Type Symbol Ann
Cv.ttype2to1))

getTypeDeclaration :: Reference.Id -> Transaction (Maybe (Decl Symbol Ann))
getTypeDeclaration :: Id -> Transaction (Maybe (Decl Symbol Ann))
getTypeDeclaration (Reference.Id Hash
h ConstructorId
i) =
  MaybeT Transaction (Decl Symbol Ann)
-> Transaction (Maybe (Decl Symbol Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    Decl Symbol
decl2 <- Id -> MaybeT Transaction (Decl Symbol)
Ops.loadDeclByReference (Hash -> ConstructorId -> Id
forall h. h -> ConstructorId -> Id' h
C.Reference.Id Hash
h ConstructorId
i)
    pure (Hash -> Decl Symbol -> Decl Symbol Ann
Cv.decl2to1 Hash
h Decl Symbol
decl2)

getDeclComponent :: Hash -> Transaction (Maybe [Decl Symbol Ann])
getDeclComponent :: Hash -> Transaction (Maybe [Decl Symbol Ann])
getDeclComponent Hash
h =
  MaybeT Transaction [Decl Symbol Ann]
-> Transaction (Maybe [Decl Symbol Ann])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    [Decl Symbol]
decl2 <- Hash -> MaybeT Transaction [Decl Symbol]
Ops.loadDeclComponent Hash
h
    pure ((Decl Symbol -> Decl Symbol Ann)
-> [Decl Symbol] -> [Decl Symbol Ann]
forall a b. (a -> b) -> [a] -> [b]
map (Hash -> Decl Symbol -> Decl Symbol Ann
Cv.decl2to1 Hash
h) [Decl Symbol]
decl2)

-- | Like 'getDeclComponent', for when the decl component is known to exist in the codebase.
expectDeclComponent :: (HasCallStack) => Hash -> Transaction [Decl Symbol Ann]
expectDeclComponent :: HasCallStack => Hash -> Transaction [Decl Symbol Ann]
expectDeclComponent Hash
hash =
  Hash -> Transaction (Maybe [Decl Symbol Ann])
getDeclComponent Hash
hash Transaction (Maybe [Decl Symbol Ann])
-> (Maybe [Decl Symbol Ann] -> [Decl Symbol Ann])
-> Transaction [Decl Symbol Ann]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe [Decl Symbol Ann]
Nothing -> WatchKind -> [Decl Symbol Ann]
forall a. HasCallStack => WatchKind -> a
error (WatchKind -> ShowS
reportBug WatchKind
"E101611" (WatchKind
"decl component " WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash -> WatchKind
forall a. Show a => a -> WatchKind
show Hash
hash WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
" not found"))
    Just [Decl Symbol Ann]
decls -> [Decl Symbol Ann]
decls

putTermComponent ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  -- | The hash of the term component.
  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 ()
putTermComponent TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h [(Term Symbol Ann, Type Symbol Ann)]
component =
  Transaction Bool -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Hash -> Transaction Bool
Ops.objectExistsForHash Hash
h) do
    [(Id, (Term Symbol Ann, Type Symbol Ann))]
-> ((Id, (Term Symbol Ann, Type Symbol Ann)) -> Transaction ())
-> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Hash
-> [(Term Symbol Ann, Type Symbol Ann)]
-> [(Id, (Term Symbol Ann, Type Symbol Ann))]
forall a. Hash -> [a] -> [(Id, a)]
Reference.componentFor Hash
h [(Term Symbol Ann, Type Symbol Ann)]
component) \(Id
ref, (Term Symbol Ann
tm, Type Symbol Ann
tp)) -> do
      TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
putTerm_ TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Id
ref Term Symbol Ann
tm Type Symbol Ann
tp
      TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
tryFlushTermBuffer TVar (Map Hash TermBufferEntry)
termBuffer Hash
h

putTerm ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  Reference.Id ->
  Term Symbol Ann ->
  Type Symbol Ann ->
  Transaction ()
putTerm :: TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
putTerm TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer ref :: Id
ref@(Reference.Id Hash
h ConstructorId
_) Term Symbol Ann
tm Type Symbol Ann
tp =
  Transaction Bool -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Hash -> Transaction Bool
Ops.objectExistsForHash Hash
h) do
    TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
putTerm_ TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Id
ref Term Symbol Ann
tm Type Symbol Ann
tp
    TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
tryFlushTermBuffer TVar (Map Hash TermBufferEntry)
termBuffer Hash
h

putTerm_ ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  Reference.Id ->
  Term Symbol Ann ->
  Type Symbol Ann ->
  Transaction ()
putTerm_ :: TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Term Symbol Ann
-> Type Symbol Ann
-> Transaction ()
putTerm_ TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer (Reference.Id Hash
h ConstructorId
i) Term Symbol Ann
tm Type Symbol Ann
tp = do
  BufferEntry Maybe ConstructorId
size Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
comp Set Hash
missing Set Hash
waiting <- IO TermBufferEntry -> Transaction TermBufferEntry
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (TVar (Map Hash TermBufferEntry) -> Hash -> IO TermBufferEntry
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer TVar (Map Hash TermBufferEntry)
termBuffer Hash
h)
  let termDependencies :: [Reference]
termDependencies = Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference]) -> Set Reference -> [Reference]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Set Reference
forall v vt at ap a.
(Ord v, Ord vt) =>
Term2 vt at ap v a -> Set Reference
Term.termDependencies Term Symbol Ann
tm
  -- update the component target size if we encounter any higher self-references
  let size' :: Maybe ConstructorId
size' = Maybe ConstructorId -> Maybe ConstructorId -> Maybe ConstructorId
forall a. Ord a => a -> a -> a
max Maybe ConstructorId
size (ConstructorId -> Maybe ConstructorId
forall a. a -> Maybe a
Just (ConstructorId -> Maybe ConstructorId)
-> ConstructorId -> Maybe ConstructorId
forall a b. (a -> b) -> a -> b
$ ConstructorId
biggestSelfReference ConstructorId -> ConstructorId -> ConstructorId
forall a. Num a => a -> a -> a
+ ConstructorId
1)
        where
          biggestSelfReference :: ConstructorId
biggestSelfReference =
            NonEmpty ConstructorId -> ConstructorId
forall a. Ord a => NonEmpty a -> a
maximum1 (NonEmpty ConstructorId -> ConstructorId)
-> NonEmpty ConstructorId -> ConstructorId
forall a b. (a -> b) -> a -> b
$
              ConstructorId
i ConstructorId -> [ConstructorId] -> NonEmpty ConstructorId
forall a. a -> [a] -> NonEmpty a
:| [ConstructorId
i' | Reference.Derived Hash
h' ConstructorId
i' <- [Reference]
termDependencies, Hash
h Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
h']
  let comp' :: Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
comp' = ConstructorId
-> (Term Symbol Ann, Type Symbol Ann)
-> Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
-> Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ConstructorId
i (Term Symbol Ann
tm, Type Symbol Ann
tp) Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
comp
  -- for the component element that's been passed in, add its dependencies to missing'
  [Hash]
missingTerms' <-
    (Hash -> Transaction Bool) -> [Hash] -> Transaction [Hash]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
      ((Bool -> Bool) -> Transaction Bool -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Transaction Bool -> Transaction Bool)
-> (Hash -> Transaction Bool) -> Hash -> Transaction Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction Bool
Ops.objectExistsForHash)
      [Hash
h | Reference.Derived Hash
h ConstructorId
_i <- [Reference]
termDependencies]
  [Hash]
missingTypes' <-
    (Hash -> Transaction Bool) -> [Hash] -> Transaction [Hash]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Transaction Bool -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Transaction Bool -> Transaction Bool)
-> (Hash -> Transaction Bool) -> Hash -> Transaction Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction Bool
Ops.objectExistsForHash) ([Hash] -> Transaction [Hash]) -> [Hash] -> Transaction [Hash]
forall a b. (a -> b) -> a -> b
$
      [Hash
h | Reference.Derived Hash
h ConstructorId
_i <- Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference]) -> Set Reference -> [Reference]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Set Reference
forall v vt at ap a.
(Ord v, Ord vt) =>
Term2 vt at ap v a -> Set Reference
Term.typeDependencies Term Symbol Ann
tm]
        [Hash] -> [Hash] -> [Hash]
forall a. [a] -> [a] -> [a]
++ [Hash
h | Reference.Derived Hash
h ConstructorId
_i <- Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference]) -> Set Reference -> [Reference]
forall a b. (a -> b) -> a -> b
$ Type Symbol Ann -> Set Reference
forall v a. Ord v => Type v a -> Set Reference
Type.dependencies Type Symbol Ann
tp]
  let missing' :: Set Hash
missing' = Set Hash
missing Set Hash -> Set Hash -> Set Hash
forall a. Semigroup a => a -> a -> a
<> [Hash] -> Set Hash
forall a. Ord a => [a] -> Set a
Set.fromList ([Hash]
missingTerms' [Hash] -> [Hash] -> [Hash]
forall a. Semigroup a => a -> a -> a
<> [Hash]
missingTypes')
  IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO do
    -- notify each of the dependencies that h depends on them.
    (Hash -> IO ()) -> [Hash] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Hash -> TVar (Map Hash TermBufferEntry) -> Hash -> IO ()
forall a. Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
addBufferDependent Hash
h TVar (Map Hash TermBufferEntry)
termBuffer) [Hash]
missingTerms'
    (Hash -> IO ()) -> [Hash] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Hash -> TVar (Map Hash DeclBufferEntry) -> Hash -> IO ()
forall a. Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
addBufferDependent Hash
h TVar (Map Hash DeclBufferEntry)
declBuffer) [Hash]
missingTypes'
    TVar (Map Hash TermBufferEntry) -> Hash -> TermBufferEntry -> IO ()
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer TVar (Map Hash TermBufferEntry)
termBuffer Hash
h (Maybe ConstructorId
-> Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
-> Set Hash
-> Set Hash
-> TermBufferEntry
forall a.
Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
BufferEntry Maybe ConstructorId
size' Map ConstructorId (Term Symbol Ann, Type Symbol Ann)
comp' Set Hash
missing' Set Hash
waiting)

tryFlushTermBuffer :: TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
tryFlushTermBuffer :: TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
tryFlushTermBuffer TVar (Map Hash TermBufferEntry)
termBuffer =
  let loop :: Hash -> Transaction ()
loop Hash
h =
        TVar (Map Hash TermBufferEntry)
-> (Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Transaction ())
-> (Hash -> Transaction ())
-> Hash
-> Transaction ()
forall a.
Show a =>
TVar (Map Hash (BufferEntry a))
-> (Hash -> [a] -> Transaction ())
-> (Hash -> Transaction ())
-> Hash
-> Transaction ()
tryFlushBuffer
          TVar (Map Hash TermBufferEntry)
termBuffer
          (\Hash
h2 [(Term Symbol Ann, Type Symbol Ann)]
component -> Transaction ObjectId -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction ObjectId -> Transaction ())
-> Transaction ObjectId -> Transaction ()
forall a b. (a -> b) -> a -> b
$ HashHandle
-> Maybe ByteString
-> Hash
-> [(Term Symbol, Type Symbol)]
-> Transaction ObjectId
Q.saveTermComponent HashHandle
v2HashHandle Maybe ByteString
forall a. Maybe a
Nothing Hash
h2 (Hash
-> [(Term Symbol Ann, Type Symbol Ann)]
-> [(Term Symbol, Type Symbol)]
forall a.
Hash
-> [(Term Symbol Ann, Type Symbol a)]
-> [(Term Symbol, Type Symbol)]
Cv.termComponent1to2 Hash
h [(Term Symbol Ann, Type Symbol Ann)]
component))
          Hash -> Transaction ()
loop
          Hash
h
   in Hash -> Transaction ()
loop

addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction ()
addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction ()
addDeclComponentTypeIndex ObjectId
oId [[Type Symbol Ann]]
ctorss =
  [([Type Symbol Ann], ConstructorId)]
-> (([Type Symbol Ann], ConstructorId) -> Transaction ())
-> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([[Type Symbol Ann]]
ctorss [[Type Symbol Ann]]
-> [ConstructorId] -> [([Type Symbol Ann], ConstructorId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [ConstructorId
0 ..]) \([Type Symbol Ann]
ctors, ConstructorId
i) ->
    [(Type Symbol Ann, ConstructorId)]
-> ((Type Symbol Ann, ConstructorId) -> Transaction ())
-> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Type Symbol Ann]
ctors [Type Symbol Ann]
-> [ConstructorId] -> [(Type Symbol Ann, ConstructorId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [ConstructorId
0 ..]) \(Type Symbol Ann
tp, ConstructorId
j) -> do
      let self :: Id' ObjectId ObjectId
self = Id' ObjectId -> ConstructorId -> Id' ObjectId ObjectId
forall hTm hTp. Id' hTp -> ConstructorId -> Id' hTm hTp
C.Referent.ConId (ObjectId -> ConstructorId -> Id' ObjectId
forall h. h -> ConstructorId -> Id' h
C.Reference.Id ObjectId
oId ConstructorId
i) ConstructorId
j
          typeForIndexing :: Reference
typeForIndexing = Type Symbol Ann -> Reference
forall v a. Var v => Type v a -> Reference
Hashing.typeToReference Type Symbol Ann
tp
          typeMentionsForIndexing :: Set Reference
typeMentionsForIndexing = Type Symbol Ann -> Set Reference
forall v a. Var v => Type v a -> Set Reference
Hashing.typeToReferenceMentions Type Symbol Ann
tp
      Id' ObjectId ObjectId -> Reference -> Transaction ()
Ops.addTypeToIndexForTerm Id' ObjectId ObjectId
self (Reference -> Reference
Cv.reference1to2 Reference
typeForIndexing)
      Id' ObjectId ObjectId -> Set Reference -> Transaction ()
Ops.addTypeMentionsToIndexForTerm Id' ObjectId ObjectId
self ((Reference -> Reference) -> Set Reference -> Set Reference
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Reference -> Reference
Cv.reference1to2 Set Reference
typeMentionsForIndexing)

putTypeDeclarationComponent ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  Hash ->
  [Decl Symbol Ann] ->
  Transaction ()
putTypeDeclarationComponent :: TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Hash
-> [Decl Symbol Ann]
-> Transaction ()
putTypeDeclarationComponent TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h [Decl Symbol Ann]
decls =
  Transaction Bool -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Hash -> Transaction Bool
Ops.objectExistsForHash Hash
h) do
    [(Id, Decl Symbol Ann)]
-> ((Id, Decl Symbol Ann) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Hash -> [Decl Symbol Ann] -> [(Id, Decl Symbol Ann)]
forall a. Hash -> [a] -> [(Id, a)]
Reference.componentFor Hash
h [Decl Symbol Ann]
decls) \(Id
ref, Decl Symbol Ann
decl) ->
      TVar (Map Hash DeclBufferEntry)
-> Id -> Decl Symbol Ann -> Transaction ()
putTypeDeclaration_ TVar (Map Hash DeclBufferEntry)
declBuffer Id
ref Decl Symbol Ann
decl
    TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry) -> Hash -> Transaction ()
tryFlushDeclBuffer TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h

putTypeDeclaration ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  Reference.Id ->
  Decl Symbol Ann ->
  Transaction ()
putTypeDeclaration :: TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry)
-> Id
-> Decl Symbol Ann
-> Transaction ()
putTypeDeclaration TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer ref :: Id
ref@(Reference.Id Hash
h ConstructorId
_) Decl Symbol Ann
decl = do
  Transaction Bool -> Transaction () -> Transaction ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Hash -> Transaction Bool
Ops.objectExistsForHash Hash
h) do
    TVar (Map Hash DeclBufferEntry)
-> Id -> Decl Symbol Ann -> Transaction ()
putTypeDeclaration_ TVar (Map Hash DeclBufferEntry)
declBuffer Id
ref Decl Symbol Ann
decl
    TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry) -> Hash -> Transaction ()
tryFlushDeclBuffer TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h

putTypeDeclaration_ ::
  TVar (Map Hash DeclBufferEntry) ->
  Reference.Id ->
  Decl Symbol Ann ->
  Transaction ()
putTypeDeclaration_ :: TVar (Map Hash DeclBufferEntry)
-> Id -> Decl Symbol Ann -> Transaction ()
putTypeDeclaration_ TVar (Map Hash DeclBufferEntry)
declBuffer (Reference.Id Hash
h ConstructorId
i) Decl Symbol Ann
decl = do
  BufferEntry Maybe ConstructorId
size Map ConstructorId (Decl Symbol Ann)
comp Set Hash
missing Set Hash
waiting <- IO DeclBufferEntry -> Transaction DeclBufferEntry
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (TVar (Map Hash DeclBufferEntry) -> Hash -> IO DeclBufferEntry
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a)
getBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h)
  let declDependencies :: [Reference]
declDependencies = Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference]) -> Set Reference -> [Reference]
forall a b. (a -> b) -> a -> b
$ Decl Symbol Ann -> Set Reference
forall v a. Ord v => Decl v a -> Set Reference
Decl.declTypeDependencies Decl Symbol Ann
decl
  let size' :: Maybe ConstructorId
size' = Maybe ConstructorId -> Maybe ConstructorId -> Maybe ConstructorId
forall a. Ord a => a -> a -> a
max Maybe ConstructorId
size (ConstructorId -> Maybe ConstructorId
forall a. a -> Maybe a
Just (ConstructorId -> Maybe ConstructorId)
-> ConstructorId -> Maybe ConstructorId
forall a b. (a -> b) -> a -> b
$ ConstructorId
biggestSelfReference ConstructorId -> ConstructorId -> ConstructorId
forall a. Num a => a -> a -> a
+ ConstructorId
1)
        where
          biggestSelfReference :: ConstructorId
biggestSelfReference =
            NonEmpty ConstructorId -> ConstructorId
forall a. Ord a => NonEmpty a -> a
maximum1 (NonEmpty ConstructorId -> ConstructorId)
-> NonEmpty ConstructorId -> ConstructorId
forall a b. (a -> b) -> a -> b
$
              ConstructorId
i ConstructorId -> [ConstructorId] -> NonEmpty ConstructorId
forall a. a -> [a] -> NonEmpty a
:| [ConstructorId
i' | Reference.Derived Hash
h' ConstructorId
i' <- [Reference]
declDependencies, Hash
h Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
h']
  let comp' :: Map ConstructorId (Decl Symbol Ann)
comp' = ConstructorId
-> Decl Symbol Ann
-> Map ConstructorId (Decl Symbol Ann)
-> Map ConstructorId (Decl Symbol Ann)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ConstructorId
i Decl Symbol Ann
decl Map ConstructorId (Decl Symbol Ann)
comp
  [Hash]
moreMissing <-
    (Hash -> Transaction Bool) -> [Hash] -> Transaction [Hash]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Transaction Bool -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Transaction Bool -> Transaction Bool)
-> (Hash -> Transaction Bool) -> Hash -> Transaction Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction Bool
Ops.objectExistsForHash) ([Hash] -> Transaction [Hash]) -> [Hash] -> Transaction [Hash]
forall a b. (a -> b) -> a -> b
$
      [Hash
h | Reference.Derived Hash
h ConstructorId
_i <- [Reference]
declDependencies]
  let missing' :: Set Hash
missing' = Set Hash
missing Set Hash -> Set Hash -> Set Hash
forall a. Semigroup a => a -> a -> a
<> [Hash] -> Set Hash
forall a. Ord a => [a] -> Set a
Set.fromList [Hash]
moreMissing
  IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO do
    (Hash -> IO ()) -> [Hash] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Hash -> TVar (Map Hash DeclBufferEntry) -> Hash -> IO ()
forall a. Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO ()
addBufferDependent Hash
h TVar (Map Hash DeclBufferEntry)
declBuffer) [Hash]
moreMissing
    TVar (Map Hash DeclBufferEntry) -> Hash -> DeclBufferEntry -> IO ()
forall a.
TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO ()
putBuffer TVar (Map Hash DeclBufferEntry)
declBuffer Hash
h (Maybe ConstructorId
-> Map ConstructorId (Decl Symbol Ann)
-> Set Hash
-> Set Hash
-> DeclBufferEntry
forall a.
Maybe ConstructorId
-> Map ConstructorId a -> Set Hash -> Set Hash -> BufferEntry a
BufferEntry Maybe ConstructorId
size' Map ConstructorId (Decl Symbol Ann)
comp' Set Hash
missing' Set Hash
waiting)

tryFlushDeclBuffer ::
  TVar (Map Hash TermBufferEntry) ->
  TVar (Map Hash DeclBufferEntry) ->
  Hash ->
  Transaction ()
tryFlushDeclBuffer :: TVar (Map Hash TermBufferEntry)
-> TVar (Map Hash DeclBufferEntry) -> Hash -> Transaction ()
tryFlushDeclBuffer TVar (Map Hash TermBufferEntry)
termBuffer TVar (Map Hash DeclBufferEntry)
declBuffer =
  let loop :: Hash -> Transaction ()
loop Hash
h =
        TVar (Map Hash DeclBufferEntry)
-> (Hash -> [Decl Symbol Ann] -> Transaction ())
-> (Hash -> Transaction ())
-> Hash
-> Transaction ()
forall a.
Show a =>
TVar (Map Hash (BufferEntry a))
-> (Hash -> [a] -> Transaction ())
-> (Hash -> Transaction ())
-> Hash
-> Transaction ()
tryFlushBuffer
          TVar (Map Hash DeclBufferEntry)
declBuffer
          ( \Hash
h2 [Decl Symbol Ann]
component ->
              Transaction ObjectId -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction ObjectId -> Transaction ())
-> Transaction ObjectId -> Transaction ()
forall a b. (a -> b) -> a -> b
$
                HashHandle
-> Maybe ByteString
-> Hash
-> [Decl Symbol]
-> Transaction ObjectId
Q.saveDeclComponent
                  HashHandle
v2HashHandle
                  Maybe ByteString
forall a. Maybe a
Nothing
                  Hash
h2
                  ((Decl Symbol Ann -> Decl Symbol)
-> [Decl Symbol Ann] -> [Decl Symbol]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Hash -> Decl Symbol Ann -> Decl Symbol
forall a. Hash -> Decl Symbol a -> Decl Symbol
Cv.decl1to2 Hash
h) [Decl Symbol Ann]
component)
          )
          (\Hash
h -> TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
tryFlushTermBuffer TVar (Map Hash TermBufferEntry)
termBuffer Hash
h Transaction () -> Transaction () -> Transaction ()
forall a b. Transaction a -> Transaction b -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Hash -> Transaction ()
loop Hash
h)
          Hash
h
   in Hash -> Transaction ()
loop

-- if this blows up on cromulent hashes, then switch from `hashToHashId`
-- to one that returns Maybe.
getBranchForHash ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  BranchCache Sqlite.Transaction ->
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  CausalHash ->
  Transaction (Maybe (Branch Transaction))
getBranchForHash :: BranchCache Transaction
-> (Reference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
getBranchForHash BranchCache Transaction
branchCache Reference -> Transaction ConstructorType
doGetDeclType CausalHash
h = do
  CausalHash -> Transaction (Maybe (CausalBranch Transaction))
Ops.loadCausalBranchByCausalHash CausalHash
h Transaction (Maybe (CausalBranch Transaction))
-> (Maybe (CausalBranch Transaction)
    -> Transaction (Maybe (Branch Transaction)))
-> Transaction (Maybe (Branch Transaction))
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (CausalBranch Transaction)
Nothing -> Maybe (Branch Transaction)
-> Transaction (Maybe (Branch Transaction))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Branch Transaction)
forall a. Maybe a
Nothing
    Just CausalBranch Transaction
causal2 -> do
      Branch Transaction
branch1 <- BranchCache Transaction
-> (Reference -> Transaction ConstructorType)
-> CausalBranch Transaction
-> Transaction (Branch Transaction)
forall (m :: * -> *).
Monad m =>
BranchCache m
-> (Reference -> m ConstructorType)
-> CausalBranch m
-> m (Branch m)
Cv.causalbranch2to1 BranchCache Transaction
branchCache Reference -> Transaction ConstructorType
doGetDeclType CausalBranch Transaction
causal2
      pure (Branch Transaction -> Maybe (Branch Transaction)
forall a. a -> Maybe a
Just Branch Transaction
branch1)

putBranch :: Branch Transaction -> Transaction ()
putBranch :: Branch Transaction -> Transaction ()
putBranch =
  Transaction (BranchObjectId, CausalHashId) -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction (BranchObjectId, CausalHashId) -> Transaction ())
-> (Branch Transaction
    -> Transaction (BranchObjectId, CausalHashId))
-> Branch Transaction
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashHandle
-> CausalBranch Transaction
-> Transaction (BranchObjectId, CausalHashId)
Ops.saveBranch HashHandle
v2HashHandle (CausalBranch Transaction
 -> Transaction (BranchObjectId, CausalHashId))
-> (Branch Transaction -> CausalBranch Transaction)
-> Branch Transaction
-> Transaction (BranchObjectId, CausalHashId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch Transaction -> CausalBranch Transaction
forall (m :: * -> *). Monad m => Branch m -> CausalBranch m
Cv.causalbranch1to2

-- | Check whether the given branch exists in the codebase.
branchExists :: CausalHash -> Transaction Bool
branchExists :: CausalHash -> Transaction Bool
branchExists CausalHash
h =
  Hash -> Transaction (Maybe HashId)
Q.loadHashIdByHash (CausalHash -> Hash
unCausalHash CausalHash
h) Transaction (Maybe HashId)
-> (Maybe HashId -> Transaction Bool) -> Transaction Bool
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe HashId
Nothing -> Bool -> Transaction Bool
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just HashId
hId -> HashId -> Transaction Bool
Q.isCausalHash HashId
hId

getPatch :: PatchHash -> Transaction (Maybe Patch)
getPatch :: PatchHash -> Transaction (Maybe Patch)
getPatch PatchHash
h =
  MaybeT Transaction Patch -> Transaction (Maybe Patch)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    PatchObjectId
patchId <- Transaction (Maybe PatchObjectId)
-> MaybeT Transaction PatchObjectId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (PatchHash -> Transaction (Maybe PatchObjectId)
Q.loadPatchObjectIdForPrimaryHash PatchHash
h)
    Patch
patch <- Transaction Patch -> MaybeT Transaction Patch
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PatchObjectId -> Transaction Patch
Ops.expectPatch PatchObjectId
patchId)
    pure (Patch -> Patch
Cv.patch2to1 Patch
patch)

-- | Put a patch into the codebase.
--
-- Note that 'putBranch' may also put patches.
putPatch :: PatchHash -> Patch -> Transaction ()
putPatch :: PatchHash -> Patch -> Transaction ()
putPatch PatchHash
h Patch
p =
  Transaction PatchObjectId -> Transaction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Transaction PatchObjectId -> Transaction ())
-> Transaction PatchObjectId -> Transaction ()
forall a b. (a -> b) -> a -> b
$ HashHandle -> PatchHash -> Patch -> Transaction PatchObjectId
Ops.savePatch HashHandle
v2HashHandle PatchHash
h (Patch -> Patch
Cv.patch1to2 Patch
p)

-- | Check whether the given patch exists in the codebase.
patchExists :: PatchHash -> Transaction Bool
patchExists :: PatchHash -> Transaction Bool
patchExists PatchHash
h = (Maybe PatchObjectId -> Bool)
-> Transaction (Maybe PatchObjectId) -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe PatchObjectId -> Bool
forall a. Maybe a -> Bool
isJust (Transaction (Maybe PatchObjectId) -> Transaction Bool)
-> Transaction (Maybe PatchObjectId) -> Transaction Bool
forall a b. (a -> b) -> a -> b
$ PatchHash -> Transaction (Maybe PatchObjectId)
Q.loadPatchObjectIdForPrimaryHash PatchHash
h

dependentsImpl :: Q.DependentsSelector -> Reference -> Transaction (Set Reference.Id)
dependentsImpl :: DependentsSelector -> Reference -> Transaction (Set Id)
dependentsImpl DependentsSelector
selector Reference
r =
  (Id -> Id) -> Set Id -> Set Id
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Id -> Id
Cv.referenceid2to1
    (Set Id -> Set Id) -> Transaction (Set Id) -> Transaction (Set Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DependentsSelector -> Reference -> Transaction (Set Id)
Ops.dependents DependentsSelector
selector (Reference -> Reference
Cv.reference1to2 Reference
r)

dependentsOfComponentImpl :: Hash -> Transaction (Set Reference.Id)
dependentsOfComponentImpl :: Hash -> Transaction (Set Id)
dependentsOfComponentImpl Hash
h =
  (Id -> Id) -> Set Id -> Set Id
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Id -> Id
Cv.referenceid2to1 (Set Id -> Set Id) -> Transaction (Set Id) -> Transaction (Set Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash -> Transaction (Set Id)
Ops.dependentsOfComponent Hash
h

-- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be
-- retrieved by @getWatch k r@.
watches :: UF.WatchKind -> Transaction [Reference.Id]
watches :: WatchKind -> Transaction [Id]
watches WatchKind
w =
  WatchKind -> Transaction [Id]
Ops.listWatches (WatchKind -> WatchKind
Cv.watchKind1to2 WatchKind
w) Transaction [Id] -> ([Id] -> [Id]) -> Transaction [Id]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Id
Cv.referenceid2to1

getWatch ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  UF.WatchKind ->
  Reference.Id ->
  Transaction (Maybe (Term Symbol Ann))
getWatch :: (Reference -> Transaction ConstructorType)
-> WatchKind -> Id -> Transaction (Maybe (Term Symbol Ann))
getWatch Reference -> Transaction ConstructorType
doGetDeclType WatchKind
k r :: Id
r@(Reference.Id Hash
h ConstructorId
_i) =
  if WatchKind -> [WatchKind] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem WatchKind
k [WatchKind]
standardWatchKinds
    then MaybeT Transaction (Term Symbol Ann)
-> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      Term Symbol
watch <- WatchKind -> Id -> MaybeT Transaction (Term Symbol)
Ops.loadWatch (WatchKind -> WatchKind
Cv.watchKind1to2 WatchKind
k) (Id -> Id
Cv.referenceid1to2 Id
r)
      Transaction (Term Symbol Ann)
-> MaybeT Transaction (Term Symbol Ann)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hash
-> (Reference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (Reference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h Reference -> Transaction ConstructorType
doGetDeclType Term Symbol
watch)
    else Maybe (Term Symbol Ann) -> Transaction (Maybe (Term Symbol Ann))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term Symbol Ann)
forall a. Maybe a
Nothing

-- | @putWatch k r t@ puts a watch of kind @k@, with hash-of-expression @r@ and decompiled result @t@ into the
-- codebase.
--
-- For example, in the watch expression below, @k@ is 'WK.Regular', @r@ is the hash of @x@, and @t@ is @7@.
--
-- @
-- > x = 3 + 4
--   ⧩
--   7
-- @
putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> Transaction ()
putWatch :: WatchKind -> Id -> Term Symbol Ann -> Transaction ()
putWatch WatchKind
k r :: Id
r@(Reference.Id Hash
h ConstructorId
_i) Term Symbol Ann
tm =
  Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WatchKind -> [WatchKind] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem WatchKind
k [WatchKind]
standardWatchKinds) do
    WatchKind -> Id -> Term Symbol -> Transaction ()
Ops.saveWatch
      (WatchKind -> WatchKind
Cv.watchKind1to2 WatchKind
k)
      (Id -> Id
Cv.referenceid1to2 Id
r)
      (Hash -> Term Symbol Ann -> Term Symbol
Cv.term1to2 Hash
h Term Symbol Ann
tm)

standardWatchKinds :: [UF.WatchKind]
standardWatchKinds :: [WatchKind]
standardWatchKinds = [WatchKind
forall a. (Eq a, IsString a) => a
UF.RegularWatch, WatchKind
forall a. (Eq a, IsString a) => a
UF.TestWatch]

termsOfTypeImpl ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  Reference ->
  Transaction (Set Referent.Id)
termsOfTypeImpl :: (Reference -> Transaction ConstructorType)
-> Reference -> Transaction (Set Id)
termsOfTypeImpl Reference -> Transaction ConstructorType
doGetDeclType Reference
r =
  Reference -> Transaction (Set Id)
Ops.termsHavingType (Reference -> Reference
Cv.reference1to2 Reference
r)
    Transaction (Set Id)
-> (Set Id -> Transaction (Set Id)) -> Transaction (Set Id)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Id -> Transaction Id) -> Set Id -> Transaction (Set Id)
forall (f :: * -> *) b a.
(Applicative f, Ord b) =>
(a -> f b) -> Set a -> f (Set b)
Set.traverse ((Reference -> Transaction ConstructorType) -> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(Reference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 Reference -> Transaction ConstructorType
doGetDeclType)

termsMentioningTypeImpl ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  Reference ->
  Transaction (Set Referent.Id)
termsMentioningTypeImpl :: (Reference -> Transaction ConstructorType)
-> Reference -> Transaction (Set Id)
termsMentioningTypeImpl Reference -> Transaction ConstructorType
doGetDeclType Reference
r =
  Reference -> Transaction (Set Id)
Ops.termsMentioningType (Reference -> Reference
Cv.reference1to2 Reference
r)
    Transaction (Set Id)
-> (Set Id -> Transaction (Set Id)) -> Transaction (Set Id)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Id -> Transaction Id) -> Set Id -> Transaction (Set Id)
forall (f :: * -> *) b a.
(Applicative f, Ord b) =>
(a -> f b) -> Set a -> f (Set b)
Set.traverse ((Reference -> Transaction ConstructorType) -> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(Reference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 Reference -> Transaction ConstructorType
doGetDeclType)

filterReferencesHavingTypeImpl :: Reference -> Set Reference.Id -> Transaction (Set Reference.Id)
filterReferencesHavingTypeImpl :: Reference -> Set Id -> Transaction (Set Id)
filterReferencesHavingTypeImpl Reference
typRef Set Id
termRefs =
  Reference -> [Id] -> Transaction [Id]
Ops.filterTermsByReferenceHavingType (Reference -> Reference
Cv.reference1to2 Reference
typRef) (Id -> Id
Cv.referenceid1to2 (Id -> Id) -> [Id] -> [Id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Id -> [Id]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Id
termRefs)
    Transaction [Id] -> ([Id] -> [Id]) -> Transaction [Id]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Id
Cv.referenceid2to1
    Transaction [Id] -> ([Id] -> Set Id) -> Transaction (Set Id)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Id] -> Set Id
forall a. Ord a => [a] -> Set a
Set.fromList

filterReferentsHavingTypeImpl ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  Reference ->
  Set Referent.Id ->
  Transaction (Set Referent.Id)
filterReferentsHavingTypeImpl :: (Reference -> Transaction ConstructorType)
-> Reference -> Set Id -> Transaction (Set Id)
filterReferentsHavingTypeImpl Reference -> Transaction ConstructorType
doGetDeclType Reference
typRef Set Id
termRefs =
  Reference -> [Id] -> Transaction [Id]
Ops.filterTermsByReferentHavingType (Reference -> Reference
Cv.reference1to2 Reference
typRef) (Id -> Id
Cv.referentid1to2 (Id -> Id) -> [Id] -> [Id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Id -> [Id]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Id
termRefs)
    Transaction [Id] -> ([Id] -> Transaction [Id]) -> Transaction [Id]
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Id -> Transaction Id) -> [Id] -> Transaction [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Reference -> Transaction ConstructorType) -> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(Reference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 Reference -> Transaction ConstructorType
doGetDeclType)
    Transaction [Id] -> ([Id] -> Set Id) -> Transaction (Set Id)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Id] -> Set Id
forall a. Ord a => [a] -> Set a
Set.fromList

-- | The number of base32 characters needed to distinguish any two references in the codebase.
hashLength :: Transaction Int
hashLength :: Transaction Int
hashLength = Int -> Transaction Int
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
10

-- | The number of base32 characters needed to distinguish any two branch in the codebase.
branchHashLength :: Transaction Int
branchHashLength :: Transaction Int
branchHashLength = Int -> Transaction Int
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
10

defnReferencesByPrefix :: OT.ObjectType -> ShortHash -> Transaction (Set Reference.Id)
defnReferencesByPrefix :: ObjectType -> ShortHash -> Transaction (Set Id)
defnReferencesByPrefix ObjectType
_ (ShortHash.Builtin Text
_) = Set Id -> Transaction (Set Id)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Id
forall a. Monoid a => a
mempty
defnReferencesByPrefix ObjectType
ot (ShortHash.ShortHash Text
prefix Maybe ConstructorId
cycle Maybe ConstructorId
_cid) = do
  Set Id
refs <- do
    ObjectType
-> Text -> Maybe ConstructorId -> Transaction [Id' ObjectId]
Ops.componentReferencesByPrefix ObjectType
ot Text
prefix Maybe ConstructorId
cycle
      Transaction [Id' ObjectId]
-> ([Id' ObjectId] -> Transaction [Id]) -> Transaction [Id]
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Id' ObjectId -> Transaction Id)
-> [Id' ObjectId] -> Transaction [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ObjectId -> Transaction Hash) -> Id' ObjectId -> Transaction Id
forall h h' (f :: * -> *).
Functor f =>
(h -> f h') -> Id' h -> f (Id' h')
C.Reference.idH ObjectId -> Transaction Hash
Q.expectPrimaryHashByObjectId)
      Transaction [Id]
-> ([Id] -> Transaction (Set Id)) -> Transaction (Set Id)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set Id -> Transaction (Set Id)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Id -> Transaction (Set Id))
-> ([Id] -> Set Id) -> [Id] -> Transaction (Set Id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Id] -> Set Id
forall a. Ord a => [a] -> Set a
Set.fromList
  pure $ (Id -> Id) -> Set Id -> Set Id
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Id -> Id
Cv.referenceid2to1 Set Id
refs

termReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id)
termReferencesByPrefix :: ShortHash -> Transaction (Set Id)
termReferencesByPrefix = ObjectType -> ShortHash -> Transaction (Set Id)
defnReferencesByPrefix ObjectType
OT.TermComponent

-- | Get the set of type declarations whose hash matches the given prefix.
typeReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id)
typeReferencesByPrefix :: ShortHash -> Transaction (Set Id)
typeReferencesByPrefix = ObjectType -> ShortHash -> Transaction (Set Id)
defnReferencesByPrefix ObjectType
OT.DeclComponent

referentsByPrefix ::
  -- | A 'getDeclType'-like lookup, possibly backed by a cache.
  (C.Reference.Reference -> Transaction CT.ConstructorType) ->
  ShortHash ->
  Transaction (Set Referent.Id)
referentsByPrefix :: (Reference -> Transaction ConstructorType)
-> ShortHash -> Transaction (Set Id)
referentsByPrefix Reference -> Transaction ConstructorType
_doGetDeclType ShortHash.Builtin {} = Set Id -> Transaction (Set Id)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Id
forall a. Monoid a => a
mempty
referentsByPrefix Reference -> Transaction ConstructorType
doGetDeclType (ShortHash.ShortHash Text
prefix Maybe ConstructorId
cycle Maybe ConstructorId
cid) = do
  [Id]
termReferents <-
    Text -> Maybe ConstructorId -> Transaction [Id]
Ops.termReferentsByPrefix Text
prefix Maybe ConstructorId
cycle
      Transaction [Id] -> ([Id] -> Transaction [Id]) -> Transaction [Id]
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Id -> Transaction Id) -> [Id] -> Transaction [Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Reference -> Transaction ConstructorType) -> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(Reference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 Reference -> Transaction ConstructorType
doGetDeclType)
  [(Hash, ConstructorId, DeclType, [ConstructorId])]
declReferents' <- Text
-> Maybe ConstructorId
-> Maybe ConstructorId
-> Transaction [(Hash, ConstructorId, DeclType, [ConstructorId])]
Ops.declReferentsByPrefix Text
prefix Maybe ConstructorId
cycle Maybe ConstructorId
cid
  let declReferents :: [Id]
declReferents =
        [ ConstructorReferenceId -> ConstructorType -> Id
Referent.ConId (Id -> ConstructorId -> ConstructorReferenceId
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference (Hash -> ConstructorId -> Id
forall h. h -> ConstructorId -> Id' h
Reference.Id Hash
h ConstructorId
pos) (ConstructorId -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
cid)) (DeclType -> ConstructorType
Cv.decltype2to1 DeclType
ct)
          | (Hash
h, ConstructorId
pos, DeclType
ct, [ConstructorId]
cids) <- [(Hash, ConstructorId, DeclType, [ConstructorId])]
declReferents',
            ConstructorId
cid <- [ConstructorId]
cids
        ]
  Set Id -> Transaction (Set Id)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Id -> Transaction (Set Id))
-> ([Id] -> Set Id) -> [Id] -> Transaction (Set Id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Id] -> Set Id
forall a. Ord a => [a] -> Set a
Set.fromList ([Id] -> Transaction (Set Id)) -> [Id] -> Transaction (Set Id)
forall a b. (a -> b) -> a -> b
$ [Id]
termReferents [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
<> [Id]
declReferents

-- | Get the set of branches whose hash matches the given prefix.
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash)
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash)
causalHashesByPrefix ShortCausalHash
sh = do
  -- given that a Branch is shallow, it's really `CausalHash` that you'd
  -- refer to to specify a full namespace w/ history.
  -- but do we want to be able to refer to a namespace without its history?
  ShortCausalHash -> Transaction (Set CausalHash)
Ops.causalHashesByPrefix (ShortCausalHash -> ShortCausalHash
Cv.sch1to2 ShortCausalHash
sh)

-- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide
termExists, declExists :: Hash -> Transaction Bool
termExists :: Hash -> Transaction Bool
termExists = (Maybe ObjectId -> Bool)
-> Transaction (Maybe ObjectId) -> Transaction Bool
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ObjectId -> Bool
forall a. Maybe a -> Bool
isJust (Transaction (Maybe ObjectId) -> Transaction Bool)
-> (Hash -> Transaction (Maybe ObjectId))
-> Hash
-> Transaction Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction (Maybe ObjectId)
Q.loadObjectIdForPrimaryHash
declExists :: Hash -> Transaction Bool
declExists = Hash -> Transaction Bool
termExists

-- `before b1 b2` is undefined if `b2` not in the codebase
before :: CausalHash -> CausalHash -> Transaction Bool
before :: CausalHash -> CausalHash -> Transaction Bool
before CausalHash
h1 CausalHash
h2 =
  Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool)
-> Transaction (Maybe Bool) -> Transaction Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CausalHash -> CausalHash -> Transaction (Maybe Bool)
Ops.before CausalHash
h1 CausalHash
h2

-- | Given a transaction, return a transaction that first checks a given semispace cache.
--
-- The transaction should probably be read-only, as we (of course) don't hit SQLite on a cache hit.
makeCachedTransaction :: (Ord a) => Cache.Cache a b -> (a -> Sqlite.Transaction b) -> a -> Sqlite.Transaction b
makeCachedTransaction :: forall a b.
Ord a =>
Cache a b -> (a -> Transaction b) -> a -> Transaction b
makeCachedTransaction Cache a b
cache a -> Transaction b
action a
x = do
  Connection
conn <- Transaction Connection
Sqlite.unsafeGetConnection
  IO b -> Transaction b
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Cache a b -> (a -> IO b) -> a -> IO b
forall (m :: * -> *) k v.
MonadIO m =>
Cache k v -> (k -> m v) -> k -> m v
Cache.apply Cache a b
cache (\a
x -> Transaction b -> Connection -> IO b
forall a. Transaction a -> Connection -> IO a
Sqlite.unsafeUnTransaction (a -> Transaction b
action a
x) Connection
conn) a
x)

-- | Like 'makeCachedTransaction', but for when the transaction returns a Maybe; only cache the Justs.
makeMaybeCachedTransaction ::
  (Ord a) =>
  Cache.Cache a b ->
  (a -> Sqlite.Transaction (Maybe b)) ->
  a ->
  Sqlite.Transaction (Maybe b)
makeMaybeCachedTransaction :: forall a b.
Ord a =>
Cache a b
-> (a -> Transaction (Maybe b)) -> a -> Transaction (Maybe b)
makeMaybeCachedTransaction Cache a b
cache a -> Transaction (Maybe b)
action a
x = do
  Connection
conn <- Transaction Connection
Sqlite.unsafeGetConnection
  IO (Maybe b) -> Transaction (Maybe b)
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Cache a b -> (a -> IO (Maybe b)) -> a -> IO (Maybe b)
forall (m :: * -> *) (g :: * -> *) k v.
(MonadIO m, Applicative g, Traversable g) =>
Cache k v -> (k -> m (g v)) -> k -> m (g v)
Cache.applyDefined Cache a b
cache (\a
x -> Transaction (Maybe b) -> Connection -> IO (Maybe b)
forall a. Transaction a -> Connection -> IO a
Sqlite.unsafeUnTransaction (a -> Transaction (Maybe b)
action a
x) Connection
conn) a
x)

-- | Creates a project by name if one doesn't already exist, creates a branch in that project, then returns the project
-- and branch ids. Fails if a branch by that name already exists in the project.
insertProjectAndBranch ::
  ProjectName ->
  ProjectBranchName ->
  Db.CausalHashId ->
  Sqlite.Transaction (Project, ProjectBranchRow)
insertProjectAndBranch :: ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranchRow)
insertProjectAndBranch ProjectName
projectName ProjectBranchName
branchName CausalHashId
chId = do
  ProjectId
projectId <- Transaction (Maybe ProjectId)
-> Transaction ProjectId -> Transaction ProjectId
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
whenNothingM ((Project -> ProjectId) -> Maybe Project -> Maybe ProjectId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Project -> ProjectId
Project.projectId (Maybe Project -> Maybe ProjectId)
-> Transaction (Maybe Project) -> Transaction (Maybe ProjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectName -> Transaction (Maybe Project)
Q.loadProjectByName ProjectName
projectName) do
    ProjectId
projectId <- IO ProjectId -> Transaction ProjectId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectId
Db.ProjectId (UUID -> ProjectId) -> IO UUID -> IO ProjectId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
    ProjectId -> ProjectName -> Transaction ()
Q.insertProject ProjectId
projectId ProjectName
projectName
    pure ProjectId
projectId
  ProjectBranchId
branchId <- IO ProjectBranchId -> Transaction ProjectBranchId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectBranchId
Db.ProjectBranchId (UUID -> ProjectBranchId) -> IO UUID -> IO ProjectBranchId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
  let projectBranch :: ProjectBranchRow
projectBranch =
        ProjectBranchRow
          { ProjectId
$sel:projectId:ProjectBranchRow :: ProjectId
projectId :: ProjectId
projectId,
            ProjectBranchId
$sel:branchId:ProjectBranchRow :: ProjectBranchId
branchId :: ProjectBranchId
branchId,
            $sel:name:ProjectBranchRow :: ProjectBranchName
name = ProjectBranchName
branchName,
            $sel:parentBranchId:ProjectBranchRow :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
forall a. Maybe a
Nothing
          }
  HasCallStack =>
Text -> CausalHashId -> ProjectBranchRow -> Transaction ()
Text -> CausalHashId -> ProjectBranchRow -> Transaction ()
Q.insertProjectBranch
    Text
"Project Created"
    CausalHashId
chId
    ProjectBranchRow
projectBranch
  ProjectId -> ProjectBranchId -> Transaction ()
Q.setMostRecentBranch ProjectId
projectId ProjectBranchId
branchId
  pure
    ( Project {$sel:name:Project :: ProjectName
name = ProjectName
projectName, ProjectId
projectId :: ProjectId
$sel:projectId:Project :: ProjectId
projectId},
      ProjectBranchRow {ProjectId
$sel:projectId:ProjectBranchRow :: ProjectId
projectId :: ProjectId
projectId, $sel:name:ProjectBranchRow :: ProjectBranchName
name = ProjectBranchName
branchName, ProjectBranchId
$sel:branchId:ProjectBranchRow :: ProjectBranchId
branchId :: ProjectBranchId
branchId, $sel:parentBranchId:ProjectBranchRow :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
forall a. Maybe a
Nothing}
    )

-- | Often we need to assign something to an empty causal, this ensures the empty causal
-- exists in the codebase and returns its hash.
emptyCausalHash :: Sqlite.Transaction (CausalHash, Db.CausalHashId)
emptyCausalHash :: Transaction (CausalHash, CausalHashId)
emptyCausalHash = do
  let emptyBranch :: Branch m
emptyBranch = Branch m
forall (m :: * -> *). Branch m
Branch.empty
  Branch Transaction -> Transaction ()
putBranch Branch Transaction
forall (m :: * -> *). Branch m
emptyBranch
  let causalHash :: CausalHash
causalHash = Branch Any -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch Any
forall (m :: * -> *). Branch m
emptyBranch
  CausalHashId
causalHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash CausalHash
causalHash
  pure (CausalHash
causalHash, CausalHashId
causalHashId)