{-# 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 Control.Comonad.Cofree qualified as Cofree
import Data.Bitraversable (bitraverse)
import Data.Either.Extra ()
import Data.Functor.Compose (Compose (..))
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.Branch qualified as V2Branch
import U.Codebase.Branch.Diff (TreeDiff (TreeDiff))
import U.Codebase.Branch.Diff qualified as BranchDiff
import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash), PatchHash)
import U.Codebase.Projects qualified as Projects
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.NameLookups (PathSegments (..), ReversedName (..))
import U.Codebase.Sqlite.NamedRef qualified as S
import U.Codebase.Sqlite.ObjectType qualified as OT
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
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 (ProjectBranch (..))
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.Path (Path)
import Unison.Codebase.Path qualified as Path
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.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Names (Names (Names))
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
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.Relation qualified as Rel
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
  (CausalHash
_, CausalHashId
emptyCausalHashId) <- Transaction (CausalHash, CausalHashId)
emptyCausalHash
  (Project
_, ProjectBranch {ProjectId
projectId :: ProjectId
$sel:projectId:ProjectBranch :: ProjectBranch -> ProjectId
projectId, ProjectBranchId
branchId :: ProjectBranchId
$sel:branchId:ProjectBranch :: ProjectBranch -> ProjectBranchId
branchId}) <- ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranch)
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 = Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main"
    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 :: (TypeReference -> Transaction ConstructorType)
-> Id -> Transaction (Maybe (Term Symbol Ann))
getTerm TypeReference -> 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
-> (TypeReference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (TypeReference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h TypeReference -> Transaction ConstructorType
doGetDeclType Term Symbol
term2)

getDeclType :: C.Reference.Reference -> Transaction CT.ConstructorType
getDeclType :: TypeReference -> Transaction ConstructorType
getDeclType = \case
  C.Reference.ReferenceBuiltin Text
t ->
    let err :: ConstructorType
err =
          WatchKind -> ConstructorType
forall a. HasCallStack => WatchKind -> a
error (WatchKind -> ConstructorType) -> WatchKind -> ConstructorType
forall a b. (a -> b) -> a -> b
$
            WatchKind
"I don't know about the builtin type ##"
              WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> WatchKind
forall a. Show a => a -> WatchKind
show Text
t
              WatchKind -> ShowS
forall a. [a] -> [a] -> [a]
++ WatchKind
", but I've been asked for it's ConstructorType."
     in ConstructorType -> Transaction ConstructorType
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorType -> Transaction ConstructorType)
-> (Maybe ConstructorType -> ConstructorType)
-> Maybe ConstructorType
-> Transaction ConstructorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorType -> Maybe ConstructorType -> ConstructorType
forall a. a -> Maybe a -> a
fromMaybe ConstructorType
err (Maybe ConstructorType -> Transaction ConstructorType)
-> Maybe ConstructorType -> Transaction ConstructorType
forall a b. (a -> b) -> a -> b
$
          TypeReference
-> Map TypeReference ConstructorType -> Maybe ConstructorType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> TypeReference
forall t h. t -> Reference' t h
Reference.Builtin Text
t) Map TypeReference ConstructorType
Builtins.builtinConstructorType
  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 :: (TypeReference -> Transaction ConstructorType)
-> Hash -> Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
getTermComponentWithTypes TypeReference -> 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
-> (TypeReference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (TypeReference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h TypeReference -> 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 :: [TypeReference]
termDependencies = Set TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList (Set TypeReference -> [TypeReference])
-> Set TypeReference -> [TypeReference]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Set TypeReference
forall v vt at ap a.
(Ord v, Ord vt) =>
Term2 vt at ap v a -> Set TypeReference
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' <- [TypeReference]
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 <- [TypeReference]
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 TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList (Set TypeReference -> [TypeReference])
-> Set TypeReference -> [TypeReference]
forall a b. (a -> b) -> a -> b
$ Term Symbol Ann -> Set TypeReference
forall v vt at ap a.
(Ord v, Ord vt) =>
Term2 vt at ap v a -> Set TypeReference
Term.typeDependencies Term Symbol Ann
tm]
        [Hash] -> [Hash] -> [Hash]
forall a. [a] -> [a] -> [a]
++ [Hash
h | Reference.Derived Hash
h ConstructorId
_i <- Set TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList (Set TypeReference -> [TypeReference])
-> Set TypeReference -> [TypeReference]
forall a b. (a -> b) -> a -> b
$ Type Symbol Ann -> Set TypeReference
forall v a. Ord v => Type v a -> Set TypeReference
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 :: TypeReference
typeForIndexing = Type Symbol Ann -> TypeReference
forall v a. Var v => Type v a -> TypeReference
Hashing.typeToReference Type Symbol Ann
tp
          typeMentionsForIndexing :: Set TypeReference
typeMentionsForIndexing = Type Symbol Ann -> Set TypeReference
forall v a. Var v => Type v a -> Set TypeReference
Hashing.typeToReferenceMentions Type Symbol Ann
tp
      Id' ObjectId ObjectId -> TypeReference -> Transaction ()
Ops.addTypeToIndexForTerm Id' ObjectId ObjectId
self (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
typeForIndexing)
      Id' ObjectId ObjectId -> Set TypeReference -> Transaction ()
Ops.addTypeMentionsToIndexForTerm Id' ObjectId ObjectId
self ((TypeReference -> TypeReference)
-> Set TypeReference -> Set TypeReference
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TypeReference -> TypeReference
Cv.reference1to2 Set TypeReference
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 :: [TypeReference]
declDependencies = Set TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList (Set TypeReference -> [TypeReference])
-> Set TypeReference -> [TypeReference]
forall a b. (a -> b) -> a -> b
$ Decl Symbol Ann -> Set TypeReference
forall v a. Ord v => Decl v a -> Set TypeReference
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' <- [TypeReference]
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 <- [TypeReference]
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
-> (TypeReference -> Transaction ConstructorType)
-> CausalHash
-> Transaction (Maybe (Branch Transaction))
getBranchForHash BranchCache Transaction
branchCache TypeReference -> 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
-> (TypeReference -> Transaction ConstructorType)
-> CausalBranch Transaction
-> Transaction (Branch Transaction)
forall (m :: * -> *).
Monad m =>
BranchCache m
-> (TypeReference -> m ConstructorType)
-> CausalBranch m
-> m (Branch m)
Cv.causalbranch2to1 BranchCache Transaction
branchCache TypeReference -> 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 -> TypeReference -> Transaction (Set Id)
dependentsImpl DependentsSelector
selector TypeReference
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 -> TypeReference -> Transaction (Set Id)
Ops.dependents DependentsSelector
selector (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
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 :: (TypeReference -> Transaction ConstructorType)
-> WatchKind -> Id -> Transaction (Maybe (Term Symbol Ann))
getWatch TypeReference -> 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
-> (TypeReference -> Transaction ConstructorType)
-> Term Symbol
-> Transaction (Term Symbol Ann)
forall (m :: * -> *).
Monad m =>
Hash
-> (TypeReference -> m ConstructorType)
-> Term Symbol
-> m (Term Symbol Ann)
Cv.term2to1 Hash
h TypeReference -> 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 :: (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Transaction (Set Id)
termsOfTypeImpl TypeReference -> Transaction ConstructorType
doGetDeclType TypeReference
r =
  TypeReference -> Transaction (Set Id)
Ops.termsHavingType (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
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 ((TypeReference -> Transaction ConstructorType)
-> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(TypeReference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 TypeReference -> 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 :: (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Transaction (Set Id)
termsMentioningTypeImpl TypeReference -> Transaction ConstructorType
doGetDeclType TypeReference
r =
  TypeReference -> Transaction (Set Id)
Ops.termsMentioningType (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
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 ((TypeReference -> Transaction ConstructorType)
-> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(TypeReference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 TypeReference -> Transaction ConstructorType
doGetDeclType)

filterReferencesHavingTypeImpl :: Reference -> Set Reference.Id -> Transaction (Set Reference.Id)
filterReferencesHavingTypeImpl :: TypeReference -> Set Id -> Transaction (Set Id)
filterReferencesHavingTypeImpl TypeReference
typRef Set Id
termRefs =
  TypeReference -> [Id] -> Transaction [Id]
Ops.filterTermsByReferenceHavingType (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
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 :: (TypeReference -> Transaction ConstructorType)
-> TypeReference -> Set Id -> Transaction (Set Id)
filterReferentsHavingTypeImpl TypeReference -> Transaction ConstructorType
doGetDeclType TypeReference
typRef Set Id
termRefs =
  TypeReference -> [Id] -> Transaction [Id]
Ops.filterTermsByReferentHavingType (TypeReference -> TypeReference
Cv.reference1to2 TypeReference
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 ((TypeReference -> Transaction ConstructorType)
-> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(TypeReference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 TypeReference -> 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 :: (TypeReference -> Transaction ConstructorType)
-> ShortHash -> Transaction (Set Id)
referentsByPrefix TypeReference -> 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 TypeReference -> 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 ((TypeReference -> Transaction ConstructorType)
-> Id -> Transaction Id
forall (m :: * -> *).
Applicative m =>
(TypeReference -> m ConstructorType) -> Id -> m Id
Cv.referentid2to1 TypeReference -> 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

-- | Construct a 'ScopedNames' which can produce names which are relative to the provided
-- Path.
--
-- NOTE: this method requires an up-to-date name lookup index
namesAtPath ::
  BranchHash ->
  -- Include names from the project which contains this path.
  Path ->
  Transaction Names
namesAtPath :: BranchHash -> Path -> Transaction Names
namesAtPath BranchHash
bh Path
path = do
  let namesRoot :: PathSegments
namesRoot = [Text] -> PathSegments
PathSegments ([Text] -> PathSegments)
-> (Path -> [Text]) -> Path -> PathSegments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> [Text]
forall a b. Coercible a b => a -> b
coerce ([NameSegment] -> [Text])
-> (Path -> [NameSegment]) -> Path -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
Path.toList (Path -> PathSegments) -> Path -> PathSegments
forall a b. (a -> b) -> a -> b
$ Path
path
  namesPerspective :: NamesPerspective
namesPerspective@Ops.NamesPerspective {PathSegments
relativePerspective :: PathSegments
$sel:relativePerspective:NamesPerspective :: NamesPerspective -> PathSegments
relativePerspective} <- BranchHash -> PathSegments -> Transaction NamesPerspective
Ops.namesPerspectiveForRootAndPath BranchHash
bh PathSegments
namesRoot
  let relativePath :: Path
relativePath = [NameSegment] -> Path
Path.fromList ([NameSegment] -> Path) -> [NameSegment] -> Path
forall a b. (a -> b) -> a -> b
$ PathSegments -> [NameSegment]
forall a b. Coercible a b => a -> b
coerce PathSegments
relativePerspective
  NamesInPerspective {[NamedRef (Referent, Maybe ConstructorType)]
termNamesInPerspective :: [NamedRef (Referent, Maybe ConstructorType)]
$sel:termNamesInPerspective:NamesInPerspective :: NamesInPerspective -> [NamedRef (Referent, Maybe ConstructorType)]
termNamesInPerspective, [NamedRef TypeReference]
typeNamesInPerspective :: [NamedRef TypeReference]
$sel:typeNamesInPerspective:NamesInPerspective :: NamesInPerspective -> [NamedRef TypeReference]
typeNamesInPerspective} <- NamesPerspective -> Transaction NamesInPerspective
Ops.allNamesInPerspective NamesPerspective
namesPerspective
  let termsInPath :: [(Name, Referent)]
termsInPath = [NamedRef (Referent, Maybe ConstructorType)] -> [(Name, Referent)]
forall {f :: * -> *}.
Functor f =>
f (NamedRef (Referent, Maybe ConstructorType))
-> f (Name, Referent)
convertTerms [NamedRef (Referent, Maybe ConstructorType)]
termNamesInPerspective
  let typesInPath :: [(Name, TypeReference)]
typesInPath = [NamedRef TypeReference] -> [(Name, TypeReference)]
forall {f :: * -> *}.
Functor f =>
f (NamedRef TypeReference) -> f (Name, TypeReference)
convertTypes [NamedRef TypeReference]
typeNamesInPerspective
  let relativeScopedNames :: Names
relativeScopedNames =
        case Path
relativePath of
          Path
Path.Empty -> (Names {$sel:terms:Names :: Relation Name Referent
terms = [(Name, Referent)] -> Relation Name Referent
forall a b. (Ord a, Ord b) => [(a, b)] -> Relation a b
Rel.fromList [(Name, Referent)]
termsInPath, $sel:types:Names :: Relation Name TypeReference
types = [(Name, TypeReference)] -> Relation Name TypeReference
forall a b. (Ord a, Ord b) => [(a, b)] -> Relation a b
Rel.fromList [(Name, TypeReference)]
typesInPath})
          Path
p ->
            let reversedPathSegments :: [NameSegment]
reversedPathSegments = [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse ([NameSegment] -> [NameSegment])
-> (Path -> [NameSegment]) -> Path -> [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
Path.toList (Path -> [NameSegment]) -> Path -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Path
p
                relativeTerms :: [(Name, Referent)]
relativeTerms = ((Name, Referent) -> Maybe (Name, Referent))
-> [(Name, Referent)] -> [(Name, Referent)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe ([NameSegment] -> (Name, Referent) -> Maybe (Name, Referent)
forall r. [NameSegment] -> (Name, r) -> Maybe (Name, r)
stripPathPrefix [NameSegment]
reversedPathSegments) [(Name, Referent)]
termsInPath
                relativeTypes :: [(Name, TypeReference)]
relativeTypes = ((Name, TypeReference) -> Maybe (Name, TypeReference))
-> [(Name, TypeReference)] -> [(Name, TypeReference)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe ([NameSegment]
-> (Name, TypeReference) -> Maybe (Name, TypeReference)
forall r. [NameSegment] -> (Name, r) -> Maybe (Name, r)
stripPathPrefix [NameSegment]
reversedPathSegments) [(Name, TypeReference)]
typesInPath
             in (Names {$sel:terms:Names :: Relation Name Referent
terms = [(Name, Referent)] -> Relation Name Referent
forall a b. (Ord a, Ord b) => [(a, b)] -> Relation a b
Rel.fromList [(Name, Referent)]
relativeTerms, $sel:types:Names :: Relation Name TypeReference
types = [(Name, TypeReference)] -> Relation Name TypeReference
forall a b. (Ord a, Ord b) => [(a, b)] -> Relation a b
Rel.fromList [(Name, TypeReference)]
relativeTypes})
  Names -> Transaction Names
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Names -> Transaction Names) -> Names -> Transaction Names
forall a b. (a -> b) -> a -> b
$ Names
relativeScopedNames
  where
    convertTypes :: f (NamedRef TypeReference) -> f (Name, TypeReference)
convertTypes f (NamedRef TypeReference)
names =
      f (NamedRef TypeReference)
names f (NamedRef TypeReference)
-> (NamedRef TypeReference -> (Name, TypeReference))
-> f (Name, TypeReference)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(S.NamedRef {ReversedName
reversedSegments :: ReversedName
$sel:reversedSegments:NamedRef :: forall ref. NamedRef ref -> ReversedName
reversedSegments, TypeReference
ref :: TypeReference
$sel:ref:NamedRef :: forall ref. NamedRef ref -> ref
ref}) ->
        (NonEmpty NameSegment -> Name
Name.fromReverseSegments (ReversedName -> NonEmpty NameSegment
forall a b. Coercible a b => a -> b
coerce ReversedName
reversedSegments), TypeReference -> TypeReference
Cv.reference2to1 TypeReference
ref)
    convertTerms :: f (NamedRef (Referent, Maybe ConstructorType))
-> f (Name, Referent)
convertTerms f (NamedRef (Referent, Maybe ConstructorType))
names =
      f (NamedRef (Referent, Maybe ConstructorType))
names f (NamedRef (Referent, Maybe ConstructorType))
-> (NamedRef (Referent, Maybe ConstructorType) -> (Name, Referent))
-> f (Name, Referent)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(S.NamedRef {ReversedName
$sel:reversedSegments:NamedRef :: forall ref. NamedRef ref -> ReversedName
reversedSegments :: ReversedName
reversedSegments, $sel:ref:NamedRef :: forall ref. NamedRef ref -> ref
ref = (Referent
ref, Maybe ConstructorType
ct)}) ->
        let v1ref :: Referent
v1ref = ConstructorType -> Referent -> Referent
Cv.referent2to1UsingCT (ConstructorType -> Maybe ConstructorType -> ConstructorType
forall a. a -> Maybe a -> a
fromMaybe (WatchKind -> ConstructorType
forall a. HasCallStack => WatchKind -> a
error WatchKind
"Required constructor type for constructor but it was null") Maybe ConstructorType
ct) Referent
ref
         in (NonEmpty NameSegment -> Name
Name.fromReverseSegments (ReversedName -> NonEmpty NameSegment
forall a b. Coercible a b => a -> b
coerce ReversedName
reversedSegments), Referent
v1ref)

    -- If the given prefix matches the given name, the prefix is stripped and it's collected
    -- on the left, otherwise it's left as-is and collected on the right.
    -- >>> stripPathPrefix ["b", "a"] ("a.b.c", ())
    -- ([(c,())])
    stripPathPrefix :: [NameSegment] -> (Name, r) -> Maybe (Name, r)
    stripPathPrefix :: forall r. [NameSegment] -> (Name, r) -> Maybe (Name, r)
stripPathPrefix [NameSegment]
reversedPathSegments (Name
n, r
ref) =
      case Name -> [NameSegment] -> Maybe Name
Name.stripReversedPrefix Name
n [NameSegment]
reversedPathSegments of
        Maybe Name
Nothing -> Maybe (Name, r)
forall a. Maybe a
Nothing
        Just Name
stripped -> (Name, r) -> Maybe (Name, r)
forall a. a -> Maybe a
Just (Name -> Name
Name.makeRelative Name
stripped, r
ref)

-- | Add an index for the provided branch hash if one doesn't already exist.
ensureNameLookupForBranchHash ::
  (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
  -- | An optional branch which we may already have an index for.
  -- This should be a branch which is relatively similar to the branch we're creating a name
  -- lookup for, e.g. a recent ancestor of the new branch. The more similar it is, the faster
  -- the less work we'll need to do.
  Maybe BranchHash ->
  BranchHash ->
  Sqlite.Transaction ()
ensureNameLookupForBranchHash :: (TypeReference -> Transaction ConstructorType)
-> Maybe BranchHash -> BranchHash -> Transaction ()
ensureNameLookupForBranchHash TypeReference -> Transaction ConstructorType
getDeclType Maybe BranchHash
mayFromBranchHash BranchHash
toBranchHash = do
  BranchHash -> Transaction Bool
Ops.checkBranchHashNameLookupExists BranchHash
toBranchHash Transaction Bool -> (Bool -> Transaction ()) -> 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
    Bool
True -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
False -> do
      (Branch Transaction
fromBranch, Maybe BranchHash
mayExistingLookupBH) <- case Maybe BranchHash
mayFromBranchHash of
        Maybe BranchHash
Nothing -> (Branch Transaction, Maybe BranchHash)
-> Transaction (Branch Transaction, Maybe BranchHash)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch Transaction
forall (m :: * -> *). Branch m
V2Branch.empty, Maybe BranchHash
forall a. Maybe a
Nothing)
        Just BranchHash
fromBH -> do
          BranchHash -> Transaction Bool
Ops.checkBranchHashNameLookupExists BranchHash
fromBH Transaction Bool
-> (Bool -> Transaction (Branch Transaction, Maybe BranchHash))
-> Transaction (Branch Transaction, Maybe BranchHash)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> (,BranchHash -> Maybe BranchHash
forall a. a -> Maybe a
Just BranchHash
fromBH) (Branch Transaction -> (Branch Transaction, Maybe BranchHash))
-> Transaction (Branch Transaction)
-> Transaction (Branch Transaction, Maybe BranchHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BranchHash -> Transaction (Branch Transaction)
Ops.expectBranchByBranchHash BranchHash
fromBH
            Bool
False -> do
              -- TODO: We can probably infer a good starting branch by crawling through
              -- history looking for a Branch Hash we already have an index for.
              (Branch Transaction, Maybe BranchHash)
-> Transaction (Branch Transaction, Maybe BranchHash)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch Transaction
forall (m :: * -> *). Branch m
V2Branch.empty, Maybe BranchHash
forall a. Maybe a
Nothing)
      Branch Transaction
toBranch <- BranchHash -> Transaction (Branch Transaction)
Ops.expectBranchByBranchHash BranchHash
toBranchHash
      [(PathSegments, BranchHash)]
depMounts <- Branch Transaction -> Transaction [(Path, BranchHash)]
Projects.inferDependencyMounts Branch Transaction
toBranch Transaction [(Path, BranchHash)]
-> ([(Path, BranchHash)] -> [(PathSegments, BranchHash)])
-> Transaction [(PathSegments, BranchHash)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Path, BranchHash) -> (PathSegments, BranchHash))
-> [(Path, BranchHash)] -> [(PathSegments, BranchHash)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Path -> PathSegments)
-> (Path, BranchHash) -> (PathSegments, BranchHash)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @PathSegments ([NameSegment] -> PathSegments)
-> (Path -> [NameSegment]) -> Path -> PathSegments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
Path.toList))
      let depMountPaths :: [Path]
depMountPaths = ([NameSegment] -> Path
Path.fromList ([NameSegment] -> Path)
-> (PathSegments -> [NameSegment]) -> PathSegments -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegments -> [NameSegment]
forall a b. Coercible a b => a -> b
coerce) (PathSegments -> Path)
-> ((PathSegments, BranchHash) -> PathSegments)
-> (PathSegments, BranchHash)
-> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathSegments, BranchHash) -> PathSegments
forall a b. (a, b) -> a
fst ((PathSegments, BranchHash) -> Path)
-> [(PathSegments, BranchHash)] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PathSegments, BranchHash)]
depMounts
      TreeDiff Transaction
treeDiff <- [Path] -> TreeDiff Transaction -> TreeDiff Transaction
forall (m :: * -> *).
Applicative m =>
[Path] -> TreeDiff m -> TreeDiff m
ignoreDepMounts [Path]
depMountPaths (TreeDiff Transaction -> TreeDiff Transaction)
-> Transaction (TreeDiff Transaction)
-> Transaction (TreeDiff Transaction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Branch Transaction
-> Branch Transaction -> Transaction (TreeDiff Transaction)
BranchDiff.diffBranches Branch Transaction
fromBranch Branch Transaction
toBranch
      let namePrefix :: Maybe a
namePrefix = Maybe a
forall a. Maybe a
Nothing
      Maybe BranchHash
-> BranchHash
-> ((([NamedRef (Referent, Maybe ConstructorType)],
      [NamedRef Referent])
     -> ([NamedRef TypeReference], [NamedRef TypeReference])
     -> Transaction ())
    -> Transaction ())
-> Transaction ()
Ops.buildNameLookupForBranchHash
        Maybe BranchHash
mayExistingLookupBH
        BranchHash
toBranchHash
        ( \([NamedRef (Referent, Maybe ConstructorType)], [NamedRef Referent])
-> ([NamedRef TypeReference], [NamedRef TypeReference])
-> Transaction ()
save -> do
            Maybe Name
-> TreeDiff Transaction
-> (Maybe Name -> NameChanges -> Transaction ())
-> Transaction ()
forall (m :: * -> *) r.
(Monad m, Monoid r) =>
Maybe Name
-> TreeDiff m -> (Maybe Name -> NameChanges -> m r) -> m r
BranchDiff.streamNameChanges Maybe Name
forall a. Maybe a
namePrefix TreeDiff Transaction
treeDiff \Maybe Name
_prefix (BranchDiff.NameChanges {[(Name, Referent)]
termNameAdds :: [(Name, Referent)]
$sel:termNameAdds:NameChanges :: NameChanges -> [(Name, Referent)]
termNameAdds, [(Name, Referent)]
termNameRemovals :: [(Name, Referent)]
$sel:termNameRemovals:NameChanges :: NameChanges -> [(Name, Referent)]
termNameRemovals, [(Name, TypeReference)]
typeNameAdds :: [(Name, TypeReference)]
$sel:typeNameAdds:NameChanges :: NameChanges -> [(Name, TypeReference)]
typeNameAdds, [(Name, TypeReference)]
typeNameRemovals :: [(Name, TypeReference)]
$sel:typeNameRemovals:NameChanges :: NameChanges -> [(Name, TypeReference)]
typeNameRemovals}) -> do
              [NamedRef (Referent, Maybe ConstructorType)]
termNameAddsWithCT <- do
                [(Name, Referent)]
-> ((Name, Referent)
    -> Transaction (NamedRef (Referent, Maybe ConstructorType)))
-> Transaction [NamedRef (Referent, Maybe ConstructorType)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Name, Referent)]
termNameAdds \(Name
name, Referent
ref) -> do
                  (Referent, Maybe ConstructorType)
refWithCT <- Referent -> Transaction (Referent, Maybe ConstructorType)
addReferentCT Referent
ref
                  pure $ (Name, (Referent, Maybe ConstructorType))
-> NamedRef (Referent, Maybe ConstructorType)
forall ref. (Name, ref) -> NamedRef ref
toNamedRef (Name
name, (Referent, Maybe ConstructorType)
refWithCT)
              ([NamedRef (Referent, Maybe ConstructorType)], [NamedRef Referent])
-> ([NamedRef TypeReference], [NamedRef TypeReference])
-> Transaction ()
save ([NamedRef (Referent, Maybe ConstructorType)]
termNameAddsWithCT, (Name, Referent) -> NamedRef Referent
forall ref. (Name, ref) -> NamedRef ref
toNamedRef ((Name, Referent) -> NamedRef Referent)
-> [(Name, Referent)] -> [NamedRef Referent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Referent)]
termNameRemovals) ((Name, TypeReference) -> NamedRef TypeReference
forall ref. (Name, ref) -> NamedRef ref
toNamedRef ((Name, TypeReference) -> NamedRef TypeReference)
-> [(Name, TypeReference)] -> [NamedRef TypeReference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, TypeReference)]
typeNameAdds, (Name, TypeReference) -> NamedRef TypeReference
forall ref. (Name, ref) -> NamedRef ref
toNamedRef ((Name, TypeReference) -> NamedRef TypeReference)
-> [(Name, TypeReference)] -> [NamedRef TypeReference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, TypeReference)]
typeNameRemovals)
        )
      -- Ensure all of our dependencies have name lookups too.
      [(PathSegments, BranchHash)]
-> ((PathSegments, BranchHash) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(PathSegments, BranchHash)]
depMounts \(PathSegments
_path, BranchHash
depBranchHash) -> do
        -- TODO: see if we can find a way to infer a good fromHash for dependencies
        (TypeReference -> Transaction ConstructorType)
-> Maybe BranchHash -> BranchHash -> Transaction ()
ensureNameLookupForBranchHash TypeReference -> Transaction ConstructorType
getDeclType Maybe BranchHash
forall a. Maybe a
Nothing BranchHash
depBranchHash
      BranchHash -> [(PathSegments, BranchHash)] -> Transaction ()
Ops.associateNameLookupMounts BranchHash
toBranchHash [(PathSegments, BranchHash)]
depMounts
  where
    alterTreeDiffAtPath :: (Functor m) => Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
    alterTreeDiffAtPath :: forall (m :: * -> *).
Functor m =>
Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
alterTreeDiffAtPath Path
path TreeDiff m -> TreeDiff m
f (TreeDiff Cofree (Compose (Map NameSegment) m) DefinitionDiffs
cfr) =
      case Path
path of
        Path
Path.Empty -> TreeDiff m -> TreeDiff m
f (Cofree (Compose (Map NameSegment) m) DefinitionDiffs -> TreeDiff m
forall (m :: * -> *).
Cofree (Compose (Map NameSegment) m) DefinitionDiffs -> TreeDiff m
TreeDiff Cofree (Compose (Map NameSegment) m) DefinitionDiffs
cfr)
        (NameSegment
segment Path.:< Path
rest) ->
          let (DefinitionDiffs
a Cofree.:< (Compose Map
  NameSegment
  (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
rest')) = Cofree (Compose (Map NameSegment) m) DefinitionDiffs
cfr
           in Cofree (Compose (Map NameSegment) m) DefinitionDiffs -> TreeDiff m
forall (m :: * -> *).
Cofree (Compose (Map NameSegment) m) DefinitionDiffs -> TreeDiff m
TreeDiff (DefinitionDiffs
a DefinitionDiffs
-> Compose
     (Map NameSegment)
     m
     (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
-> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
Cofree.:< Map
  NameSegment
  (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
-> Compose
     (Map NameSegment)
     m
     (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
 -> m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
-> NameSegment
-> Map
     NameSegment
     (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
-> Map
     NameSegment
     (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Cofree (Compose (Map NameSegment) m) DefinitionDiffs
 -> Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
-> m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
-> m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TreeDiff m -> TreeDiff m)
-> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
-> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
forall a b. Coercible a b => a -> b
coerce ((TreeDiff m -> TreeDiff m)
 -> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
 -> Cofree (Compose (Map NameSegment) m) DefinitionDiffs)
-> (TreeDiff m -> TreeDiff m)
-> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
-> Cofree (Compose (Map NameSegment) m) DefinitionDiffs
forall a b. (a -> b) -> a -> b
$ Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
forall (m :: * -> *).
Functor m =>
Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
alterTreeDiffAtPath Path
rest TreeDiff m -> TreeDiff m
f)) NameSegment
segment Map
  NameSegment
  (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs))
rest'))
    -- Delete portions of the diff which are covered by dependency mounts.
    ignoreDepMounts :: (Applicative m) => [Path] -> TreeDiff m -> TreeDiff m
    ignoreDepMounts :: forall (m :: * -> *).
Applicative m =>
[Path] -> TreeDiff m -> TreeDiff m
ignoreDepMounts [Path]
depMounts TreeDiff m
treeDiff =
      (TreeDiff m -> Path -> TreeDiff m)
-> TreeDiff m -> [Path] -> TreeDiff m
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TreeDiff m
acc Path
path -> Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
forall (m :: * -> *).
Functor m =>
Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m
alterTreeDiffAtPath Path
path (TreeDiff m -> TreeDiff m -> TreeDiff m
forall a b. a -> b -> a
const TreeDiff m
forall a. Monoid a => a
mempty) TreeDiff m
acc) TreeDiff m
treeDiff [Path]
depMounts
    toNamedRef :: (Name, ref) -> S.NamedRef ref
    toNamedRef :: forall ref. (Name, ref) -> NamedRef ref
toNamedRef (Name
name, ref
ref) = S.NamedRef {$sel:reversedSegments:NamedRef :: ReversedName
reversedSegments = NonEmpty NameSegment -> ReversedName
forall a b. Coercible a b => a -> b
coerce (NonEmpty NameSegment -> ReversedName)
-> NonEmpty NameSegment -> ReversedName
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty NameSegment
Name.reverseSegments Name
name, $sel:ref:NamedRef :: ref
ref = ref
ref}
    addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
    addReferentCT :: Referent -> Transaction (Referent, Maybe ConstructorType)
addReferentCT Referent
referent = case Referent
referent of
      C.Referent.Ref {} -> (Referent, Maybe ConstructorType)
-> Transaction (Referent, Maybe ConstructorType)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referent
referent, Maybe ConstructorType
forall a. Maybe a
Nothing)
      C.Referent.Con TypeReference
ref ConstructorId
_conId -> do
        ConstructorType
ct <- TypeReference -> Transaction ConstructorType
getDeclType TypeReference
ref
        pure (Referent
referent, ConstructorType -> Maybe ConstructorType
forall a. a -> Maybe a
Just (ConstructorType -> Maybe ConstructorType)
-> ConstructorType -> Maybe ConstructorType
forall a b. (a -> b) -> a -> b
$ ConstructorType -> ConstructorType
Cv.constructorType1to2 ConstructorType
ct)

-- | Regenerate the name lookup index for the given branch hash from scratch.
-- This shouldn't be necessary in normal operation, but it's useful to fix name lookups if
-- they somehow get corrupt, or during local testing and debugging.
regenerateNameLookup ::
  (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
  BranchHash ->
  Sqlite.Transaction ()
regenerateNameLookup :: (TypeReference -> Transaction ConstructorType)
-> BranchHash -> Transaction ()
regenerateNameLookup TypeReference -> Transaction ConstructorType
getDeclType BranchHash
bh = do
  BranchHash -> Transaction Bool
Ops.checkBranchHashNameLookupExists BranchHash
bh Transaction Bool -> (Bool -> Transaction ()) -> 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
    Bool
True -> do
      BranchHashId
bhId <- BranchHash -> Transaction BranchHashId
Q.expectBranchHashId BranchHash
bh
      BranchHashId -> Transaction ()
Q.deleteNameLookup BranchHashId
bhId
      (TypeReference -> Transaction ConstructorType)
-> Maybe BranchHash -> BranchHash -> Transaction ()
ensureNameLookupForBranchHash TypeReference -> Transaction ConstructorType
getDeclType Maybe BranchHash
forall a. Maybe a
Nothing BranchHash
bh
    Bool
False -> (TypeReference -> Transaction ConstructorType)
-> Maybe BranchHash -> BranchHash -> Transaction ()
ensureNameLookupForBranchHash TypeReference -> Transaction ConstructorType
getDeclType Maybe BranchHash
forall a. Maybe a
Nothing BranchHash
bh

-- | Given a transaction, return a transaction that first checks a semispace cache of the given size.
--
-- The transaction should probably be read-only, as we (of course) don't hit SQLite on a cache hit.
makeCachedTransaction :: (Ord a, MonadIO m) => Word -> (a -> Sqlite.Transaction b) -> m (a -> Sqlite.Transaction b)
makeCachedTransaction :: forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word -> (a -> Transaction b) -> m (a -> Transaction b)
makeCachedTransaction Word
size a -> Transaction b
action = do
  Cache a b
cache <- Word -> m (Cache a b)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
size
  pure \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, MonadIO m) =>
  Word ->
  (a -> Sqlite.Transaction (Maybe b)) ->
  m (a -> Sqlite.Transaction (Maybe b))
makeMaybeCachedTransaction :: forall a (m :: * -> *) b.
(Ord a, MonadIO m) =>
Word
-> (a -> Transaction (Maybe b)) -> m (a -> Transaction (Maybe b))
makeMaybeCachedTransaction Word
size a -> Transaction (Maybe b)
action = do
  Cache a b
cache <- Word -> m (Cache a b)
forall (m :: * -> *) k v.
(MonadIO m, Ord k) =>
Word -> m (Cache k v)
Cache.semispaceCache Word
size
  pure \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, ProjectBranch)
insertProjectAndBranch :: ProjectName
-> ProjectBranchName
-> CausalHashId
-> Transaction (Project, ProjectBranch)
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 :: ProjectBranch
projectBranch =
        ProjectBranch
          { ProjectId
$sel:projectId:ProjectBranch :: ProjectId
projectId :: ProjectId
projectId,
            ProjectBranchId
$sel:branchId:ProjectBranch :: ProjectBranchId
branchId :: ProjectBranchId
branchId,
            $sel:name:ProjectBranch :: ProjectBranchName
name = ProjectBranchName
branchName,
            $sel:parentBranchId:ProjectBranch :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
forall a. Maybe a
Nothing
          }
  HasCallStack =>
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Q.insertProjectBranch
    Text
"Project Created"
    CausalHashId
chId
    ProjectBranch
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}, ProjectBranch {ProjectId
$sel:projectId:ProjectBranch :: ProjectId
projectId :: ProjectId
projectId, $sel:name:ProjectBranch :: ProjectBranchName
name = ProjectBranchName
branchName, ProjectBranchId
$sel:branchId:ProjectBranch :: ProjectBranchId
branchId :: ProjectBranchId
branchId, $sel:parentBranchId:ProjectBranch :: 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)