{-# LANGUAGE TemplateHaskell #-}

-- | Some naming conventions used in this module:
--
-- * @32@: the base32 representation of a hash
-- * @expect@: retrieve something that's known to exist
-- * @load@: retrieve something that's not known to exist (so the return type is a Maybe, or another container that
--     could be empty)
-- * @save@: idempotent (on conflict do nothing) insert, and return the id of the thing (usually)
module U.Codebase.Sqlite.Queries
  ( -- * text table
    saveText,
    saveTexts,
    loadTextId,
    expectTextId,
    expectText,
    expectTextCheck,

    -- ** name segments
    saveNameSegment,
    expectNameSegment,

    -- * hash table
    saveHash,
    saveHashes,
    saveHashHash,
    loadHashId,
    expectHash,
    expectHash32,
    expectBranchHash,
    expectBranchHashId,
    loadHashIdByHash,
    expectHashIdByHash,
    saveCausalHash,
    expectCausalHash,
    expectBranchHashForCausalHash,
    saveBranchHash,

    -- * hash_object table
    saveHashObject,
    expectHashIdsForObject,
    hashIdWithVersionForObject,
    loadObjectIdForPrimaryHashId,
    expectObjectIdForPrimaryHashId,
    loadObjectIdForPrimaryHash,
    expectObjectIdForPrimaryHash,
    loadPatchObjectIdForPrimaryHash,
    loadObjectIdForAnyHash,
    loadObjectIdForAnyHashId,
    expectObjectIdForAnyHashId,
    recordObjectRehash,

    -- * object table
    saveObject,
    isObjectHash,
    expectObject,
    expectPrimaryHashByObjectId,
    expectPrimaryHashIdForObject,
    expectObjectWithHashIdAndType,
    expectDeclObject,
    loadDeclObject,
    expectNamespaceObject,
    loadNamespaceObject,
    expectPatchObject,
    loadPatchObject,
    loadTermObject,
    expectTermObject,

    -- * namespace_statistics table
    saveNamespaceStats,
    loadNamespaceStatsByHashId,

    -- * causals

    -- ** causal table
    saveCausal,
    isCausalHash,
    causalExistsByHash32,
    expectCausal,
    loadCausalHashIdByCausalHash,
    expectCausalHashIdByCausalHash,
    expectCausalValueHashId,
    loadCausalByCausalHash,
    expectCausalByCausalHash,
    loadBranchObjectIdByCausalHashId,
    loadBranchObjectIdByBranchHashId,
    expectBranchObjectIdByCausalHashId,
    expectBranchObjectIdByBranchHashId,
    tryGetSquashResult,
    saveSquashResult,

    -- ** causal_parent table
    saveCausalParents,
    loadCausalParents,
    loadCausalParentsByHash,
    before,
    lca,

    -- * watch table
    saveWatch,
    loadWatch,
    loadWatchesByWatchKind,
    loadWatchKindsByReference,
    clearWatches,

    -- * projects
    projectExists,
    doProjectsExist,
    projectExistsByName,
    loadProject,
    loadProjectByName,
    expectProject,
    loadAllProjects,
    loadAllProjectsBeginningWith,
    insertProject,
    renameProject,
    deleteProject,

    -- ** project branches
    projectBranchExistsByName,
    loadProjectBranchByName,
    loadProjectBranchByNames,
    expectProjectBranch,
    loadAllProjectBranchesBeginningWith,
    loadAllProjectBranchInfo,
    loadProjectAndBranchNames,
    loadAllProjectBranchNamePairs,
    loadProjectBranch,
    insertProjectBranch,
    renameProjectBranch,
    deleteProjectBranch,
    setProjectBranchHead,
    expectProjectBranchHead,
    setMostRecentBranch,
    loadMostRecentBranch,

    -- ** remote projects
    loadRemoteProject,
    ensureRemoteProject,
    expectRemoteProjectName,
    setRemoteProjectName,
    loadRemoteProjectBranch,
    loadDefaultMergeTargetForLocalProjectBranch,

    -- ** remote project branches
    loadRemoteBranch,
    ensureRemoteProjectBranch,
    expectRemoteProjectBranchName,
    setRemoteProjectBranchName,
    insertBranchRemoteMapping,
    ensureBranchRemoteMapping,
    deleteBranchRemoteMapping,

    -- * indexes

    -- ** dependents index
    addToDependentsIndex,
    DependentsSelector (..),
    getDependentsForDependency,
    getDependentsForDependencyComponent,
    getDependenciesForDependent,
    getDependencyIdsForDependent,
    getDependenciesBetweenTerms,
    getDirectDependenciesOfScope,
    getDirectDependentsWithinScope,
    getTransitiveDependentsWithinScope,

    -- ** type index
    addToTypeIndex,
    getReferentsByType,
    getTypeReferenceForReferent,
    getTypeReferencesForComponent,
    filterTermsByReferenceHavingType,
    filterTermsByReferentHavingType,

    -- ** type mentions index
    addToTypeMentionsIndex,
    getReferentsByTypeMention,
    getTypeMentionsReferencesForComponent,

    -- * hash prefix lookup
    objectIdByBase32Prefix,
    namespaceHashIdByBase32Prefix,
    causalHashIdByBase32Prefix,

    -- * Name Lookup
    copyScopedNameLookup,
    insertScopedTermNames,
    insertScopedTypeNames,
    removeScopedTermNames,
    removeScopedTypeNames,
    termNamesWithinNamespace,
    typeNamesWithinNamespace,
    termNamesForRefWithinNamespace,
    typeNamesForRefWithinNamespace,
    recursiveTermNameSearch,
    recursiveTypeNameSearch,
    termRefsForExactName,
    typeRefsForExactName,
    checkBranchHashNameLookupExists,
    trackNewBranchHashNameLookup,
    deleteNameLookup,
    termNamesBySuffix,
    typeNamesBySuffix,
    longestMatchingTermNameForSuffixification,
    longestMatchingTypeNameForSuffixification,
    associateNameLookupMounts,
    listNameLookupMounts,
    deleteNameLookupsExceptFor,
    fuzzySearchTerms,
    fuzzySearchTypes,

    -- * Reflog
    getDeprecatedRootReflog,
    appendProjectBranchReflog,
    getProjectReflog,
    getProjectBranchReflog,
    getGlobalReflog,

    -- * garbage collection
    garbageCollectObjectsWithoutHashes,
    garbageCollectWatchesWithoutObjects,

    -- * sync temp entities
    EntityLocation (..),
    entityExists,
    entityLocation,
    expectEntity,
    syncToTempEntity,
    insertTempEntity,
    saveTempEntityInMain,
    expectTempEntity,
    deleteTempEntity,
    clearTempEntityTables,

    -- * elaborate hashes
    elaborateHashes,

    -- * current project path
    expectCurrentProjectPath,
    setCurrentProjectPath,

    -- * migrations
    runCreateSql,
    addTempEntityTables,
    addReflogTable,
    addNamespaceStatsTables,
    addProjectTables,
    addMostRecentBranchTable,
    fixScopedNameLookupTables,
    addNameLookupMountTables,
    addMostRecentNamespaceTable,
    addSquashResultTable,
    addSquashResultTableIfNotExists,
    cdToProjectRoot,
    addCurrentProjectPathTable,
    addProjectBranchReflogTable,
    addProjectBranchCausalHashIdColumn,

    -- ** schema version
    currentSchemaVersion,
    expectSchemaVersion,
    setSchemaVersion,

    -- ** helpers for various migrations
    countObjects,
    countCausals,
    countWatches,
    getCausalsWithoutBranchObjects,
    removeHashObjectsByHashingVersion,

    -- * db misc
    addTypeMentionsToIndexForTerm,
    addTypeToIndexForTerm,
    c2xTerm,
    localIdsToLookups,
    s2cDecl,
    s2cTermWithType,
    saveDeclComponent,
    saveReferenceH,
    saveSyncEntity,
    saveTermComponent,
    schemaVersion,
    x2cTType,
    x2cTerm,
    x2cDecl,
    checkBranchExistsForCausalHash,

    -- * Types
    NamespaceText,
    TextPathSegments,
    JsonParseFailure (..),
  )
where

import Control.Lens (Lens')
import Control.Lens qualified as Lens
import Control.Monad.Extra ((||^))
import Control.Monad.State (MonadState, evalStateT)
import Control.Monad.Writer (MonadWriter, runWriterT)
import Control.Monad.Writer qualified as Writer
import Data.Aeson qualified as Aeson
import Data.Aeson.Text qualified as Aeson
import Data.Bitraversable (bitraverse)
import Data.Bytes.Put (runPutS)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.List.Extra qualified as List
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as Nel
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Map.NonEmpty (NEMap)
import Data.Map.NonEmpty qualified as NEMap
import Data.Maybe qualified as Maybe
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Time qualified as Time
import Data.Vector qualified as Vector
import GHC.Stack (callStack)
import Network.URI (URI)
import U.Codebase.Branch.Type (NamespaceStats (..))
import U.Codebase.Decl qualified as C
import U.Codebase.Decl qualified as C.Decl
import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
import U.Codebase.Reference (Reference' (..))
import U.Codebase.Reference qualified as C (Reference)
import U.Codebase.Reference qualified as C.Reference
import U.Codebase.Referent qualified as C.Referent
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.Branch.Format qualified as NamespaceFormat
import U.Codebase.Sqlite.Causal qualified as Causal
import U.Codebase.Sqlite.Causal qualified as Sqlite.Causal
import U.Codebase.Sqlite.DbId
  ( BranchHashId (..),
    BranchObjectId (..),
    CausalHashId (..),
    HashId (..),
    HashVersion,
    ObjectId (..),
    PatchObjectId (..),
    ProjectBranchId (..),
    ProjectId (..),
    RemoteProjectBranchId,
    RemoteProjectId (..),
    SchemaVersion,
    TextId,
  )
import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat
import U.Codebase.Sqlite.Decl.Format qualified as S.Decl
import U.Codebase.Sqlite.Decode
import U.Codebase.Sqlite.Entity (SyncEntity)
import U.Codebase.Sqlite.Entity qualified as Entity
import U.Codebase.Sqlite.HashHandle (HashHandle (..))
import U.Codebase.Sqlite.LocalIds
  ( LocalDefnId (..),
    LocalIds,
    LocalIds' (..),
    LocalTextId (..),
  )
import U.Codebase.Sqlite.LocalIds qualified as LocalIds
import U.Codebase.Sqlite.NameLookups
import U.Codebase.Sqlite.NamedRef (NamedRef)
import U.Codebase.Sqlite.NamedRef qualified as NamedRef
import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent))
import U.Codebase.Sqlite.ObjectType qualified as ObjectType
import U.Codebase.Sqlite.Orphans ()
import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
import U.Codebase.Sqlite.Reference qualified as S
import U.Codebase.Sqlite.Reference qualified as S.Reference
import U.Codebase.Sqlite.Referent qualified as S (TextReferent)
import U.Codebase.Sqlite.Referent qualified as S.Referent
import U.Codebase.Sqlite.RemoteProject (RemoteProject (..))
import U.Codebase.Sqlite.RemoteProjectBranch (RemoteProjectBranch)
import U.Codebase.Sqlite.Serialization as Serialization
import U.Codebase.Sqlite.Symbol (Symbol)
import U.Codebase.Sqlite.TempEntity (TempEntity)
import U.Codebase.Sqlite.TempEntity qualified as TempEntity
import U.Codebase.Sqlite.TempEntityType (TempEntityType)
import U.Codebase.Sqlite.TempEntityType qualified as TempEntityType
import U.Codebase.Sqlite.Term.Format qualified as S.Term
import U.Codebase.Sqlite.Term.Format qualified as TermFormat
import U.Codebase.Term qualified as C
import U.Codebase.Term qualified as C.Term
import U.Codebase.Type qualified as C.Type
import U.Codebase.WatchKind (WatchKind)
import U.Core.ABT qualified as ABT
import U.Util.Serialization qualified as S
import U.Util.Term qualified as TermUtil
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
import Unison.Debug qualified as Debug
import Unison.Hash (Hash)
import Unison.Hash qualified as Hash
import Unison.Hash32 (Hash32)
import Unison.Hash32 qualified as Hash32
import Unison.Hash32.Orphans.Sqlite ()
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Prelude
import Unison.Sqlite
import Unison.Sqlite qualified as Sqlite
import Unison.Util.Alternative qualified as Alternative
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.FileEmbed (embedProjectStringFile)
import Unison.Util.Lens qualified as Lens
import Unison.Util.Map qualified as Map
import UnliftIO qualified

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

type TextPathSegments = [Text]

-- * main squeeze

currentSchemaVersion :: SchemaVersion
currentSchemaVersion :: SchemaVersion
currentSchemaVersion = SchemaVersion
17

runCreateSql :: Transaction ()
runCreateSql :: Transaction ()
runCreateSql =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/create.sql")

addTempEntityTables :: Transaction ()
addTempEntityTables :: Transaction ()
addTempEntityTables =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/001-temp-entity-tables.sql")

addNamespaceStatsTables :: Transaction ()
addNamespaceStatsTables :: Transaction ()
addNamespaceStatsTables =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/003-namespace-statistics.sql")

-- | Deprecated in favour of project-branch reflog
addReflogTable :: Transaction ()
addReflogTable :: Transaction ()
addReflogTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/002-reflog-table.sql")

fixScopedNameLookupTables :: Transaction ()
fixScopedNameLookupTables :: Transaction ()
fixScopedNameLookupTables =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/004-fix-scoped-name-lookup-tables.sql")

addProjectTables :: Transaction ()
addProjectTables :: Transaction ()
addProjectTables =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/005-project-tables.sql")

addMostRecentBranchTable :: Transaction ()
addMostRecentBranchTable :: Transaction ()
addMostRecentBranchTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/006-most-recent-branch-table.sql")

addNameLookupMountTables :: Transaction ()
addNameLookupMountTables :: Transaction ()
addNameLookupMountTables =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/007-add-name-lookup-mounts.sql")

addMostRecentNamespaceTable :: Transaction ()
addMostRecentNamespaceTable :: Transaction ()
addMostRecentNamespaceTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/008-add-most-recent-namespace-table.sql")

addSquashResultTable :: Transaction ()
addSquashResultTable :: Transaction ()
addSquashResultTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/009-add-squash-cache-table.sql")

-- | Added as a fix because 'addSquashResultTable' was missed in the createSchema action
-- for a portion of time.
addSquashResultTableIfNotExists :: Transaction ()
addSquashResultTableIfNotExists :: Transaction ()
addSquashResultTableIfNotExists =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/010-ensure-squash-cache-table.sql")

cdToProjectRoot :: Transaction ()
cdToProjectRoot :: Transaction ()
cdToProjectRoot =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/011-cd-to-project-root.sql")

addCurrentProjectPathTable :: Transaction ()
addCurrentProjectPathTable :: Transaction ()
addCurrentProjectPathTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/012-add-current-project-path-table.sql")

-- | Deprecated in favour of project-branch reflog
addProjectBranchReflogTable :: Transaction ()
addProjectBranchReflogTable :: Transaction ()
addProjectBranchReflogTable =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/013-add-project-branch-reflog-table.sql")

addProjectBranchCausalHashIdColumn :: Transaction ()
addProjectBranchCausalHashIdColumn :: Transaction ()
addProjectBranchCausalHashIdColumn =
  HasCallStack => Text -> Transaction ()
Text -> Transaction ()
executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql")

schemaVersion :: Transaction SchemaVersion
schemaVersion :: Transaction SchemaVersion
schemaVersion =
  Sql -> Transaction SchemaVersion
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT version
      FROM schema_version
    |]

data UnexpectedSchemaVersion = UnexpectedSchemaVersion
  { UnexpectedSchemaVersion -> SchemaVersion
actual :: SchemaVersion,
    UnexpectedSchemaVersion -> SchemaVersion
expected :: SchemaVersion
  }
  deriving stock (Int -> UnexpectedSchemaVersion -> ShowS
[UnexpectedSchemaVersion] -> ShowS
UnexpectedSchemaVersion -> [Char]
(Int -> UnexpectedSchemaVersion -> ShowS)
-> (UnexpectedSchemaVersion -> [Char])
-> ([UnexpectedSchemaVersion] -> ShowS)
-> Show UnexpectedSchemaVersion
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnexpectedSchemaVersion -> ShowS
showsPrec :: Int -> UnexpectedSchemaVersion -> ShowS
$cshow :: UnexpectedSchemaVersion -> [Char]
show :: UnexpectedSchemaVersion -> [Char]
$cshowList :: [UnexpectedSchemaVersion] -> ShowS
showList :: [UnexpectedSchemaVersion] -> ShowS
Show)
  deriving anyclass (Show UnexpectedSchemaVersion
Typeable UnexpectedSchemaVersion
(Show UnexpectedSchemaVersion, Typeable UnexpectedSchemaVersion) =>
SqliteExceptionReason UnexpectedSchemaVersion
forall e. (Show e, Typeable e) => SqliteExceptionReason e
SqliteExceptionReason)

-- | Expect the given schema version.
expectSchemaVersion :: SchemaVersion -> Transaction ()
expectSchemaVersion :: SchemaVersion -> Transaction ()
expectSchemaVersion SchemaVersion
expected =
  Sql
-> (SchemaVersion -> Either UnexpectedSchemaVersion ())
-> Transaction ()
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneColCheck
    [sql|
      SELECT version
      FROM schema_version
    |]
    (\SchemaVersion
actual -> if SchemaVersion
actual SchemaVersion -> SchemaVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= SchemaVersion
expected then UnexpectedSchemaVersion -> Either UnexpectedSchemaVersion ()
forall a b. a -> Either a b
Left UnexpectedSchemaVersion {SchemaVersion
$sel:actual:UnexpectedSchemaVersion :: SchemaVersion
actual :: SchemaVersion
actual, SchemaVersion
$sel:expected:UnexpectedSchemaVersion :: SchemaVersion
expected :: SchemaVersion
expected} else () -> Either UnexpectedSchemaVersion ()
forall a b. b -> Either a b
Right ())

setSchemaVersion :: SchemaVersion -> Transaction ()
setSchemaVersion :: SchemaVersion -> Transaction ()
setSchemaVersion SchemaVersion
schemaVersion =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE schema_version
      SET version = :schemaVersion
    |]

{- ORMOLU_DISABLE -}
{- Please don't try to format the SQL blocks —AI -}
countObjects :: Transaction Int
countObjects :: Transaction Int
countObjects = Sql -> Transaction Int
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol [sql| SELECT COUNT(*) FROM object |]

countCausals :: Transaction Int
countCausals :: Transaction Int
countCausals = Sql -> Transaction Int
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol [sql| SELECT COUNT(*) FROM causal |]

countWatches :: Transaction Int
countWatches :: Transaction Int
countWatches = Sql -> Transaction Int
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol [sql| SELECT COUNT(*) FROM watch |]

saveHash :: Hash32 -> Transaction HashId
saveHash :: Hash32 -> Transaction HashId
saveHash Hash32
hash = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO hash (base32) VALUES (:hash)
      ON CONFLICT DO NOTHING
    |]
  Hash32 -> Transaction HashId
expectHashId Hash32
hash

saveHashes :: Traversable f => f Hash32 -> Transaction (f HashId)
saveHashes :: forall (f :: * -> *).
Traversable f =>
f Hash32 -> Transaction (f HashId)
saveHashes f Hash32
hashes = do
  f Hash32 -> (Hash32 -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f Hash32
hashes \Hash32
hash ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO hash (base32)
        VALUES (:hash)
        ON CONFLICT DO NOTHING
      |]
  (Hash32 -> Transaction HashId)
-> f Hash32 -> Transaction (f HashId)
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) -> f a -> f (f b)
traverse Hash32 -> Transaction HashId
expectHashId f Hash32
hashes

saveHashHash :: Hash -> Transaction HashId
saveHashHash :: Hash -> Transaction HashId
saveHashHash = Hash32 -> Transaction HashId
saveHash (Hash32 -> Transaction HashId)
-> (Hash -> Hash32) -> Hash -> Transaction HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Hash32
Hash32.fromHash

loadHashId :: Hash32 -> Transaction (Maybe HashId)
loadHashId :: Hash32 -> Transaction (Maybe HashId)
loadHashId Hash32
hash = Sql -> Transaction (Maybe HashId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (Hash32 -> Sql
loadHashIdSql Hash32
hash)

expectHashId :: Hash32 -> Transaction HashId
expectHashId :: Hash32 -> Transaction HashId
expectHashId Hash32
hash = Sql -> Transaction HashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (Hash32 -> Sql
loadHashIdSql Hash32
hash)

loadHashIdSql :: Hash32 -> Sql
loadHashIdSql :: Hash32 -> Sql
loadHashIdSql Hash32
hash =
  [sql|
    SELECT id
    FROM hash
    WHERE base32 = :hash COLLATE NOCASE
  |]

loadHashIdByHash :: Hash -> Transaction (Maybe HashId)
loadHashIdByHash :: Hash -> Transaction (Maybe HashId)
loadHashIdByHash = Hash32 -> Transaction (Maybe HashId)
loadHashId (Hash32 -> Transaction (Maybe HashId))
-> (Hash -> Hash32) -> Hash -> Transaction (Maybe HashId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Hash32
Hash32.fromHash

saveCausalHash :: CausalHash -> Transaction CausalHashId
saveCausalHash :: CausalHash -> Transaction CausalHashId
saveCausalHash = (HashId -> CausalHashId)
-> Transaction HashId -> Transaction CausalHashId
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashId -> CausalHashId
CausalHashId (Transaction HashId -> Transaction CausalHashId)
-> (CausalHash -> Transaction HashId)
-> CausalHash
-> Transaction CausalHashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction HashId
saveHashHash (Hash -> Transaction HashId)
-> (CausalHash -> Hash) -> CausalHash -> Transaction HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> Hash
unCausalHash

saveBranchHash :: BranchHash -> Transaction BranchHashId
saveBranchHash :: BranchHash -> Transaction BranchHashId
saveBranchHash = (HashId -> BranchHashId)
-> Transaction HashId -> Transaction BranchHashId
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashId -> BranchHashId
BranchHashId (Transaction HashId -> Transaction BranchHashId)
-> (BranchHash -> Transaction HashId)
-> BranchHash
-> Transaction BranchHashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction HashId
saveHashHash (Hash -> Transaction HashId)
-> (BranchHash -> Hash) -> BranchHash -> Transaction HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BranchHash -> Hash
unBranchHash

loadCausalHashIdByCausalHash :: CausalHash -> Transaction (Maybe CausalHashId)
loadCausalHashIdByCausalHash :: CausalHash -> Transaction (Maybe CausalHashId)
loadCausalHashIdByCausalHash CausalHash
ch = MaybeT Transaction CausalHashId -> Transaction (Maybe CausalHashId)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  HashId
hId <- Transaction (Maybe HashId) -> MaybeT Transaction HashId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction (Maybe HashId) -> MaybeT Transaction HashId)
-> Transaction (Maybe HashId) -> MaybeT Transaction HashId
forall a b. (a -> b) -> a -> b
$ Hash -> Transaction (Maybe HashId)
loadHashIdByHash (CausalHash -> Hash
unCausalHash CausalHash
ch)
  MaybeT Transaction Bool
-> CausalHashId -> MaybeT Transaction CausalHashId
forall (m :: * -> *) a.
(Monad m, Alternative m) =>
m Bool -> a -> m a
Alternative.whenM (Transaction Bool -> MaybeT Transaction Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HashId -> Transaction Bool
isCausalHash HashId
hId)) (HashId -> CausalHashId
CausalHashId HashId
hId)

expectCausalHashIdByCausalHash :: CausalHash -> Transaction CausalHashId
expectCausalHashIdByCausalHash :: CausalHash -> Transaction CausalHashId
expectCausalHashIdByCausalHash CausalHash
ch = do
  HashId
hId <- Hash -> Transaction HashId
expectHashIdByHash (CausalHash -> Hash
unCausalHash CausalHash
ch)
  pure (HashId -> CausalHashId
CausalHashId HashId
hId)

loadCausalByCausalHash :: CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId))
loadCausalByCausalHash :: CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId))
loadCausalByCausalHash CausalHash
ch = MaybeT Transaction (CausalHashId, BranchHashId)
-> Transaction (Maybe (CausalHashId, BranchHashId))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  HashId
hId <- Transaction (Maybe HashId) -> MaybeT Transaction HashId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction (Maybe HashId) -> MaybeT Transaction HashId)
-> Transaction (Maybe HashId) -> MaybeT Transaction HashId
forall a b. (a -> b) -> a -> b
$ Hash -> Transaction (Maybe HashId)
loadHashIdByHash (CausalHash -> Hash
unCausalHash CausalHash
ch)
  BranchHashId
bhId <- Transaction (Maybe BranchHashId) -> MaybeT Transaction BranchHashId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Transaction (Maybe BranchHashId)
 -> MaybeT Transaction BranchHashId)
-> Transaction (Maybe BranchHashId)
-> MaybeT Transaction BranchHashId
forall a b. (a -> b) -> a -> b
$ HashId -> Transaction (Maybe BranchHashId)
loadCausalValueHashId HashId
hId
  pure (HashId -> CausalHashId
CausalHashId HashId
hId, BranchHashId
bhId)

expectCausalByCausalHash :: CausalHash -> Transaction (CausalHashId, BranchHashId)
expectCausalByCausalHash :: CausalHash -> Transaction (CausalHashId, BranchHashId)
expectCausalByCausalHash CausalHash
ch = do
  CausalHashId
hId <- CausalHash -> Transaction CausalHashId
expectCausalHashIdByCausalHash CausalHash
ch
  BranchHashId
bhId <- CausalHashId -> Transaction BranchHashId
expectCausalValueHashId CausalHashId
hId
  pure (CausalHashId
hId, BranchHashId
bhId)

expectHashIdByHash :: Hash -> Transaction HashId
expectHashIdByHash :: Hash -> Transaction HashId
expectHashIdByHash = Hash32 -> Transaction HashId
expectHashId (Hash32 -> Transaction HashId)
-> (Hash -> Hash32) -> Hash -> Transaction HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Hash32
Hash32.fromHash

expectHash :: HashId -> Transaction Hash
expectHash :: HashId -> Transaction Hash
expectHash HashId
h = Hash32 -> Hash
Hash32.toHash (Hash32 -> Hash) -> Transaction Hash32 -> Transaction Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashId -> Transaction Hash32
expectHash32 HashId
h

expectHash32 :: HashId -> Transaction Hash32
expectHash32 :: HashId -> Transaction Hash32
expectHash32 HashId
h =
  Sql -> Transaction Hash32
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT base32
      FROM hash
      WHERE id = :h
    |]

expectBranchHash :: BranchHashId -> Transaction BranchHash
expectBranchHash :: BranchHashId -> Transaction BranchHash
expectBranchHash = (HashId -> Transaction Hash)
-> BranchHashId -> Transaction BranchHash
forall a b. Coercible a b => a -> b
coerce HashId -> Transaction Hash
expectHash

expectBranchHashForCausalHash :: CausalHash -> Transaction BranchHash
expectBranchHashForCausalHash :: CausalHash -> Transaction BranchHash
expectBranchHashForCausalHash CausalHash
ch = do
  (CausalHashId
_, BranchHashId
bhId)<- CausalHash -> Transaction (CausalHashId, BranchHashId)
expectCausalByCausalHash CausalHash
ch
  BranchHashId -> Transaction BranchHash
expectBranchHash BranchHashId
bhId

saveText :: Text -> Transaction TextId
saveText :: Text -> Transaction TextId
saveText Text
t = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO text (text)
      VALUES (:t)
      ON CONFLICT DO NOTHING
    |]
  Text -> Transaction TextId
expectTextId Text
t

saveTexts :: Traversable f => f Text -> Transaction (f TextId)
saveTexts :: forall (f :: * -> *).
Traversable f =>
f Text -> Transaction (f TextId)
saveTexts =
  (Text -> Transaction TextId) -> f Text -> Transaction (f TextId)
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) -> f a -> f (f b)
traverse Text -> Transaction TextId
saveText

loadTextId :: Text -> Transaction (Maybe TextId)
loadTextId :: Text -> Transaction (Maybe TextId)
loadTextId Text
t = Sql -> Transaction (Maybe TextId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (Text -> Sql
loadTextIdSql Text
t)

expectTextId :: Text -> Transaction TextId
expectTextId :: Text -> Transaction TextId
expectTextId Text
t = Sql -> Transaction TextId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (Text -> Sql
loadTextIdSql Text
t)

loadTextIdSql :: Text -> Sql
loadTextIdSql :: Text -> Sql
loadTextIdSql Text
t =
  [sql|
    SELECT id
    FROM text
    WHERE text = :t
  |]

expectText :: TextId -> Transaction Text
expectText :: TextId -> Transaction Text
expectText TextId
h = Sql -> Transaction Text
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (TextId -> Sql
loadTextSql TextId
h)

expectTextCheck :: SqliteExceptionReason e => TextId -> (Text -> Either e a) -> Transaction a
expectTextCheck :: forall e a.
SqliteExceptionReason e =>
TextId -> (Text -> Either e a) -> Transaction a
expectTextCheck TextId
h = Sql -> (Text -> Either e a) -> Transaction a
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneColCheck (TextId -> Sql
loadTextSql TextId
h)

loadTextSql :: TextId -> Sql
loadTextSql :: TextId -> Sql
loadTextSql TextId
h =
  [sql|
    SELECT text
    FROM text
    WHERE id = :h
  |]

saveNameSegment :: NameSegment -> Transaction TextId
saveNameSegment :: NameSegment -> Transaction TextId
saveNameSegment =
 Text -> Transaction TextId
saveText (Text -> Transaction TextId)
-> (NameSegment -> Text) -> NameSegment -> Transaction TextId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toUnescapedText

expectNameSegment :: TextId -> Transaction NameSegment
expectNameSegment :: TextId -> Transaction NameSegment
expectNameSegment =
  (Text -> NameSegment)
-> Transaction Text -> Transaction NameSegment
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> NameSegment
NameSegment (Transaction Text -> Transaction NameSegment)
-> (TextId -> Transaction Text)
-> TextId
-> Transaction NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextId -> Transaction Text
expectText

saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction ()
saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction ()
saveHashObject HashId
hId ObjectId
oId HashVersion
version =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO hash_object (hash_id, object_id, hash_version)
      VALUES (:hId, :oId, :version)
      ON CONFLICT DO NOTHING
    |]

saveObject ::
  HashHandle ->
  HashId ->
  ObjectType ->
  ByteString ->
  Transaction ObjectId
saveObject :: HashHandle
-> HashId -> ObjectType -> ByteString -> Transaction ObjectId
saveObject HashHandle
hh HashId
h ObjectType
t ByteString
blob = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO object (primary_hash_id, type_id, bytes)
      VALUES (:h, :t, :blob)
      ON CONFLICT DO NOTHING
    |]
  ObjectId
oId <- HashId -> Transaction ObjectId
expectObjectIdForPrimaryHashId HashId
h
  HashId -> ObjectId -> HashVersion -> Transaction ()
saveHashObject HashId
h ObjectId
oId HashVersion
2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes
  Transaction Int
rowsModified Transaction Int -> (Int -> 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
    Int
0 -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Int
_ -> do
      Hash32
hash <- HashId -> Transaction Hash32
expectHash32 HashId
h
      HashHandle -> Hash32 -> Transaction ()
tryMoveTempEntityDependents HashHandle
hh Hash32
hash
  pure ObjectId
oId

expectObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a
expectObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction a
expectObject ObjectId
oId ByteString -> Either e a
check =
  Sql -> (ByteString -> Either e a) -> Transaction a
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneColCheck
    [sql|
      SELECT bytes
      FROM object
      WHERE id = :oId
    |]
    ByteString -> Either e a
check

loadObjectOfType ::
  SqliteExceptionReason e =>
  ObjectId ->
  ObjectType ->
  (ByteString -> Either e a) ->
  Transaction (Maybe a)
loadObjectOfType :: forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
loadObjectOfType ObjectId
oid ObjectType
ty =
  Sql -> (ByteString -> Either e a) -> Transaction (Maybe a)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck (ObjectId -> ObjectType -> Sql
loadObjectOfTypeSql ObjectId
oid ObjectType
ty) -- (oid, ty)

expectObjectOfType :: SqliteExceptionReason e => ObjectId -> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType :: forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType ObjectId
oid ObjectType
ty =
  Sql -> (ByteString -> Either e a) -> Transaction a
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneColCheck (ObjectId -> ObjectType -> Sql
loadObjectOfTypeSql ObjectId
oid ObjectType
ty)

loadObjectOfTypeSql :: ObjectId -> ObjectType -> Sql
loadObjectOfTypeSql :: ObjectId -> ObjectType -> Sql
loadObjectOfTypeSql ObjectId
oid ObjectType
ty =
  [sql|
    SELECT bytes
    FROM object
    WHERE id = :oid
      AND type_id = :ty
  |]

-- | Load a decl component object.
loadDeclObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadDeclObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadDeclObject ObjectId
oid =
  ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
loadObjectOfType ObjectId
oid ObjectType
DeclComponent

-- | Expect a decl component object.
expectDeclObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a
expectDeclObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction a
expectDeclObject ObjectId
oid =
  ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType ObjectId
oid ObjectType
DeclComponent

-- | Load a namespace object.
loadNamespaceObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadNamespaceObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadNamespaceObject ObjectId
oid =
  ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
loadObjectOfType ObjectId
oid ObjectType
Namespace

-- | Expect a namespace object.
expectNamespaceObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a
expectNamespaceObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction a
expectNamespaceObject ObjectId
oid =
  ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType ObjectId
oid ObjectType
Namespace

-- | Load a patch object.
loadPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadPatchObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadPatchObject ObjectId
oid =
  ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
loadObjectOfType ObjectId
oid ObjectType
Patch

-- | Expect a patch object.
expectPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a
expectPatchObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction a
expectPatchObject ObjectId
oid =
  ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType ObjectId
oid ObjectType
Patch

-- | Load a term component object.
loadTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadTermObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadTermObject ObjectId
oid =
  ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType
-> (ByteString -> Either e a)
-> Transaction (Maybe a)
loadObjectOfType ObjectId
oid ObjectType
TermComponent

-- | Expect a term component object.
expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a
expectTermObject :: forall e a.
SqliteExceptionReason e =>
ObjectId -> (ByteString -> Either e a) -> Transaction a
expectTermObject ObjectId
oid =
  ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
forall e a.
SqliteExceptionReason e =>
ObjectId
-> ObjectType -> (ByteString -> Either e a) -> Transaction a
expectObjectOfType ObjectId
oid ObjectType
TermComponent

expectPrimaryHashIdForObject :: ObjectId -> Transaction HashId
expectPrimaryHashIdForObject :: ObjectId -> Transaction HashId
expectPrimaryHashIdForObject ObjectId
oId = do
  Sql -> Transaction HashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT primary_hash_id
      FROM object
      WHERE id = :oId
    |]

expectObjectWithType :: SqliteExceptionReason e => ObjectId -> (ObjectType -> ByteString -> Either e a) -> Transaction a
expectObjectWithType :: forall e a.
SqliteExceptionReason e =>
ObjectId
-> (ObjectType -> ByteString -> Either e a) -> Transaction a
expectObjectWithType ObjectId
oId ObjectType -> ByteString -> Either e a
check =
  Sql -> ((ObjectType, ByteString) -> Either e a) -> Transaction a
forall a e r.
(FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneRowCheck
    [sql|
      SELECT type_id, bytes
      FROM object
      WHERE id = :oId
    |]
    (\(ObjectType
typ, ByteString
bytes) -> ObjectType -> ByteString -> Either e a
check ObjectType
typ ByteString
bytes)

expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString)
expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString)
expectObjectWithHashIdAndType ObjectId
oId =
  Sql -> Transaction (HashId, ObjectType, ByteString)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction a
queryOneRow
    [sql|
      SELECT primary_hash_id, type_id, bytes
      FROM object
      WHERE id = :oId
    |]

loadObjectIdForPrimaryHashId :: HashId -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHashId :: HashId -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHashId HashId
h =
  Sql -> Transaction (Maybe ObjectId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (HashId -> Sql
loadObjectIdForPrimaryHashIdSql HashId
h)

-- | Not all hashes have corresponding objects; e.g., hashes of term types
expectObjectIdForPrimaryHashId :: HashId -> Transaction ObjectId
expectObjectIdForPrimaryHashId :: HashId -> Transaction ObjectId
expectObjectIdForPrimaryHashId HashId
h =
  Sql -> Transaction ObjectId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (HashId -> Sql
loadObjectIdForPrimaryHashIdSql HashId
h)

loadObjectIdForPrimaryHashIdSql :: HashId -> Sql
loadObjectIdForPrimaryHashIdSql :: HashId -> Sql
loadObjectIdForPrimaryHashIdSql HashId
h =
  [sql|
    SELECT id
    FROM object
    WHERE primary_hash_id = :h
  |]

loadObjectIdForPrimaryHash :: Hash -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHash :: Hash -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHash Hash
h =
  Hash -> Transaction (Maybe HashId)
loadHashIdByHash Hash
h Transaction (Maybe HashId)
-> (Maybe HashId -> Transaction (Maybe ObjectId))
-> Transaction (Maybe ObjectId)
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 -> Maybe ObjectId -> Transaction (Maybe ObjectId)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ObjectId
forall a. Maybe a
Nothing
    Just HashId
hashId -> HashId -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHashId HashId
hashId

expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId
expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId
expectObjectIdForPrimaryHash =
  Hash32 -> Transaction ObjectId
expectObjectIdForHash32 (Hash32 -> Transaction ObjectId)
-> (Hash -> Hash32) -> Hash -> Transaction ObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Hash32
Hash32.fromHash

expectObjectIdForHash32 :: Hash32 -> Transaction ObjectId
expectObjectIdForHash32 :: Hash32 -> Transaction ObjectId
expectObjectIdForHash32 Hash32
hash = do
  Sql -> Transaction ObjectId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT object.id
      FROM object
      JOIN hash ON object.primary_hash_id = hash.id
      WHERE hash.base32 = :hash COLLATE NOCASE
    |]

expectBranchObjectIdForHash32 :: Hash32 -> Transaction BranchObjectId
expectBranchObjectIdForHash32 :: Hash32 -> Transaction BranchObjectId
expectBranchObjectIdForHash32 =
  (ObjectId -> BranchObjectId)
-> Transaction ObjectId -> Transaction BranchObjectId
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ObjectId -> BranchObjectId
BranchObjectId (Transaction ObjectId -> Transaction BranchObjectId)
-> (Hash32 -> Transaction ObjectId)
-> Hash32
-> Transaction BranchObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash32 -> Transaction ObjectId
expectObjectIdForHash32

expectPatchObjectIdForHash32 :: Hash32 -> Transaction PatchObjectId
expectPatchObjectIdForHash32 :: Hash32 -> Transaction PatchObjectId
expectPatchObjectIdForHash32 =
  (ObjectId -> PatchObjectId)
-> Transaction ObjectId -> Transaction PatchObjectId
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ObjectId -> PatchObjectId
PatchObjectId (Transaction ObjectId -> Transaction PatchObjectId)
-> (Hash32 -> Transaction ObjectId)
-> Hash32
-> Transaction PatchObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash32 -> Transaction ObjectId
expectObjectIdForHash32

expectBranchHashIdForHash32 :: Hash32 -> Transaction BranchHashId
expectBranchHashIdForHash32 :: Hash32 -> Transaction BranchHashId
expectBranchHashIdForHash32 Hash32
hash =
  Sql -> Transaction BranchHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT hash.id FROM object
      INNER JOIN hash_object ON hash_object.object_id = object.id
      INNER JOIN hash ON hash_object.hash_id = hash.id
      WHERE object.type_id = 2
        AND hash.base32 = :hash COLLATE NOCASE
    |]

expectBranchHashId :: BranchHash -> Transaction BranchHashId
expectBranchHashId :: BranchHash -> Transaction BranchHashId
expectBranchHashId = Hash32 -> Transaction BranchHashId
expectBranchHashIdForHash32 (Hash32 -> Transaction BranchHashId)
-> (BranchHash -> Hash32) -> BranchHash -> Transaction BranchHashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Hash32
Hash32.fromHash (Hash -> Hash32) -> (BranchHash -> Hash) -> BranchHash -> Hash32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BranchHash -> Hash
unBranchHash

expectCausalHashIdForHash32 :: Hash32 -> Transaction CausalHashId
expectCausalHashIdForHash32 :: Hash32 -> Transaction CausalHashId
expectCausalHashIdForHash32 Hash32
hash =
  Sql -> Transaction CausalHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT self_hash_id
      FROM causal INNER JOIN hash ON hash.id = self_hash_id
      WHERE base32 = :hash COLLATE NOCASE
    |]

loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId)
loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId)
loadPatchObjectIdForPrimaryHash =
  ((Maybe ObjectId -> Maybe PatchObjectId)
-> Transaction (Maybe ObjectId)
-> Transaction (Maybe PatchObjectId)
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ObjectId -> Maybe PatchObjectId)
 -> Transaction (Maybe ObjectId)
 -> Transaction (Maybe PatchObjectId))
-> ((ObjectId -> PatchObjectId)
    -> Maybe ObjectId -> Maybe PatchObjectId)
-> (ObjectId -> PatchObjectId)
-> Transaction (Maybe ObjectId)
-> Transaction (Maybe PatchObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjectId -> PatchObjectId)
-> Maybe ObjectId -> Maybe PatchObjectId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ObjectId -> PatchObjectId
PatchObjectId (Transaction (Maybe ObjectId) -> Transaction (Maybe PatchObjectId))
-> (PatchHash -> Transaction (Maybe ObjectId))
-> PatchHash
-> Transaction (Maybe PatchObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHash (Hash -> Transaction (Maybe ObjectId))
-> (PatchHash -> Hash) -> PatchHash -> Transaction (Maybe ObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchHash -> Hash
unPatchHash

loadObjectIdForAnyHash :: Hash -> Transaction (Maybe ObjectId)
loadObjectIdForAnyHash :: Hash -> Transaction (Maybe ObjectId)
loadObjectIdForAnyHash Hash
h =
  Hash -> Transaction (Maybe HashId)
loadHashIdByHash Hash
h Transaction (Maybe HashId)
-> (Maybe HashId -> Transaction (Maybe ObjectId))
-> Transaction (Maybe ObjectId)
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 -> Maybe ObjectId -> Transaction (Maybe ObjectId)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ObjectId
forall a. Maybe a
Nothing
    Just HashId
hashId -> HashId -> Transaction (Maybe ObjectId)
loadObjectIdForAnyHashId HashId
hashId

loadObjectIdForAnyHashId :: HashId -> Transaction (Maybe ObjectId)
loadObjectIdForAnyHashId :: HashId -> Transaction (Maybe ObjectId)
loadObjectIdForAnyHashId HashId
h =
  Sql -> Transaction (Maybe ObjectId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (HashId -> Sql
loadObjectIdForAnyHashIdSql HashId
h)

expectObjectIdForAnyHashId :: HashId -> Transaction ObjectId
expectObjectIdForAnyHashId :: HashId -> Transaction ObjectId
expectObjectIdForAnyHashId HashId
h =
  Sql -> Transaction ObjectId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (HashId -> Sql
loadObjectIdForAnyHashIdSql HashId
h)

loadObjectIdForAnyHashIdSql :: HashId -> Sql
loadObjectIdForAnyHashIdSql :: HashId -> Sql
loadObjectIdForAnyHashIdSql HashId
h =
  [sql|
    SELECT object_id
    FROM hash_object
    WHERE hash_id = :h
  |]

-- | Does a hash correspond to an object?
isObjectHash :: HashId -> Transaction Bool
isObjectHash :: HashId -> Transaction Bool
isObjectHash HashId
h =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM object
        WHERE primary_hash_id = :h
      )
    |] -- sql (Only h)

-- | All objects have corresponding hashes.
expectPrimaryHashByObjectId :: ObjectId -> Transaction Hash
expectPrimaryHashByObjectId :: ObjectId -> Transaction Hash
expectPrimaryHashByObjectId =
  (Hash32 -> Hash) -> Transaction Hash32 -> Transaction Hash
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash32 -> Hash
Hash32.toHash (Transaction Hash32 -> Transaction Hash)
-> (ObjectId -> Transaction Hash32) -> ObjectId -> Transaction Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId

expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId ObjectId
oId =
  Sql -> Transaction Hash32
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT hash.base32
      FROM hash INNER JOIN object ON object.primary_hash_id = hash.id
      WHERE object.id = :oId
    |]

expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId)
expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId)
expectHashIdsForObject ObjectId
oId = do
  HashId
primaryHashId <- Sql -> Transaction HashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol [sql| SELECT primary_hash_id FROM object WHERE id = :oId |] -- sql1 (Only oId)
  [HashId]
hashIds <- Sql -> Transaction [HashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol [sql| SELECT hash_id FROM hash_object WHERE object_id = :oId |]
  pure $ HashId
primaryHashId HashId -> [HashId] -> NonEmpty HashId
forall a. a -> [a] -> NonEmpty a
Nel.:| (HashId -> Bool) -> [HashId] -> [HashId]
forall a. (a -> Bool) -> [a] -> [a]
filter (HashId -> HashId -> Bool
forall a. Eq a => a -> a -> Bool
/= HashId
primaryHashId) [HashId]
hashIds

hashIdWithVersionForObject :: ObjectId -> Transaction [(HashId, HashVersion)]
hashIdWithVersionForObject :: ObjectId -> Transaction [(HashId, HashVersion)]
hashIdWithVersionForObject ObjectId
oId =
  Sql -> Transaction [(HashId, HashVersion)]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT hash_id, hash_version
      FROM hash_object
      WHERE object_id = :oId
    |]

-- | @recordObjectRehash old new@ records that object @old@ was rehashed and inserted as a new object, @new@.
--
-- This function rewrites @old@'s @hash_object@ rows in place to point at the new object.
recordObjectRehash :: ObjectId -> ObjectId -> Transaction ()
recordObjectRehash :: ObjectId -> ObjectId -> Transaction ()
recordObjectRehash ObjectId
old ObjectId
new =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE hash_object
      SET object_id = :new
      WHERE object_id = :old
    |]

-- |Maybe we would generalize this to something other than NamespaceHash if we
-- end up wanting to store other kinds of Causals here too.
saveCausal ::
  HashHandle ->
  CausalHashId ->
  BranchHashId ->
  [CausalHashId] ->
  Transaction ()
saveCausal :: HashHandle
-> CausalHashId -> BranchHashId -> [CausalHashId] -> Transaction ()
saveCausal HashHandle
hh CausalHashId
self BranchHashId
value [CausalHashId]
parents = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO causal (self_hash_id, value_hash_id)
      VALUES (:self, :value)
      ON CONFLICT DO NOTHING
    |]
  Transaction Int
rowsModified Transaction Int -> (Int -> 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
    Int
0 -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Int
_ -> do
      [CausalHashId]
-> (CausalHashId -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [CausalHashId]
parents \CausalHashId
parent ->
        HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
          [sql|
            INSERT INTO causal_parent (causal_id, parent_id)
            VALUES (:self, :parent)
          |]
      HashHandle -> CausalHashId -> Transaction ()
flushCausalDependents HashHandle
hh CausalHashId
self

flushCausalDependents ::
  HashHandle ->
  CausalHashId ->
  Transaction ()
flushCausalDependents :: HashHandle -> CausalHashId -> Transaction ()
flushCausalDependents HashHandle
hh CausalHashId
chId = do
  Hash32
hash <- HashId -> Transaction Hash32
expectHash32 (CausalHashId -> HashId
unCausalHashId CausalHashId
chId)
  HashHandle -> Hash32 -> Transaction ()
tryMoveTempEntityDependents HashHandle
hh Hash32
hash

-- | `tryMoveTempEntityDependents #foo` does this:
--    0. Precondition: We just inserted object #foo.
--    1. Look up the dependents of #foo
--    2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo)
--    3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency,
--        insert_entity them.
tryMoveTempEntityDependents ::
  HashHandle ->
  Hash32 ->
  Transaction ()
tryMoveTempEntityDependents :: HashHandle -> Hash32 -> Transaction ()
tryMoveTempEntityDependents HashHandle
hh Hash32
dependency = do
  [Hash32]
dependents <-
    Sql -> Transaction [Hash32]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
      [sql|
        DELETE FROM temp_entity_missing_dependency
        WHERE dependency = :dependency
        RETURNING dependent
      |]
  (Hash32 -> Transaction ()) -> [Hash32] -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Hash32 -> Transaction ()
flushIfReadyToFlush [Hash32]
dependents
  where
    flushIfReadyToFlush :: Hash32 -> Transaction ()
    flushIfReadyToFlush :: Hash32 -> Transaction ()
flushIfReadyToFlush Hash32
dependent = do
      Hash32 -> Transaction Bool
readyToFlush Hash32
dependent 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 -> HashHandle -> Hash32 -> Transaction ()
moveTempEntityToMain HashHandle
hh Hash32
dependent
        Bool
False -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    readyToFlush :: Hash32 -> Transaction Bool
    readyToFlush :: Hash32 -> Transaction Bool
readyToFlush Hash32
hash =
      Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
        [sql|
          SELECT EXISTS (
            SELECT 1
            FROM temp_entity
            WHERE hash = :hash
          ) AND NOT EXISTS (
            SELECT 1
            FROM temp_entity_missing_dependency
            WHERE dependent = :hash
          )
        |]

expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat
expectCausal :: CausalHashId -> Transaction SyncCausalFormat
expectCausal CausalHashId
hashId = do
  BranchHashId
valueHash <-
    Sql -> Transaction BranchHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
      [sql|
        SELECT value_hash_id
        FROM causal
        WHERE self_hash_id = :hashId
      |]
  Vector CausalHashId
parents <-
    ([CausalHashId] -> Vector CausalHashId)
-> Transaction [CausalHashId] -> Transaction (Vector CausalHashId)
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CausalHashId] -> Vector CausalHashId
forall a. [a] -> Vector a
Vector.fromList do
      -- is the random ordering from the database ok? (seems so, for now)
      Sql -> Transaction [CausalHashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
        [sql|
          SELECT parent_id
          FROM causal_parent
          WHERE causal_id = :hashId
        |]
  pure Causal.SyncCausalFormat {Vector CausalHashId
parents :: Vector CausalHashId
$sel:parents:SyncCausalFormat :: Vector CausalHashId
parents, BranchHashId
valueHash :: BranchHashId
$sel:valueHash:SyncCausalFormat :: BranchHashId
valueHash}

-- | Read an entity out of main storage.
expectEntity :: Hash32 -> Transaction SyncEntity
expectEntity :: Hash32 -> Transaction SyncEntity
expectEntity Hash32
hash = do
  HashId
hashId <- Hash32 -> Transaction HashId
expectHashId Hash32
hash
  -- We don't know if this is an object or a causal, so just try one, then the other.
  HashId -> Transaction (Maybe ObjectId)
loadObjectIdForPrimaryHashId HashId
hashId Transaction (Maybe ObjectId)
-> (Maybe ObjectId -> Transaction SyncEntity)
-> Transaction SyncEntity
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 ObjectId
Nothing -> SyncCausalFormat -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncCausalFormat' causal branchh
-> SyncEntity' text hash defn patch branchh branch causal
Entity.C (SyncCausalFormat -> SyncEntity)
-> Transaction SyncCausalFormat -> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CausalHashId -> Transaction SyncCausalFormat
expectCausal (HashId -> CausalHashId
CausalHashId HashId
hashId)
    Just ObjectId
objectId ->
      ObjectId
-> (ObjectType -> ByteString -> Either DecodeError SyncEntity)
-> Transaction SyncEntity
forall e a.
SqliteExceptionReason e =>
ObjectId
-> (ObjectType -> ByteString -> Either e a) -> Transaction a
expectObjectWithType ObjectId
objectId \ObjectType
typ ByteString
bytes ->
        case ObjectType
typ of
          ObjectType
TermComponent -> SyncTermFormat' TextId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncTermFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.TC (SyncTermFormat' TextId ObjectId -> SyncEntity)
-> Either DecodeError (SyncTermFormat' TextId ObjectId)
-> Either DecodeError SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either DecodeError (SyncTermFormat' TextId ObjectId)
decodeSyncTermFormat ByteString
bytes
          ObjectType
DeclComponent -> SyncDeclFormat' TextId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncDeclFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.DC (SyncDeclFormat' TextId ObjectId -> SyncEntity)
-> Either DecodeError (SyncDeclFormat' TextId ObjectId)
-> Either DecodeError SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either DecodeError (SyncDeclFormat' TextId ObjectId)
decodeSyncDeclFormat ByteString
bytes
          ObjectType
Namespace -> SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> SyncEntity
forall text hash defn patch branchh branch causal.
SyncBranchFormat' branch text defn patch (branch, causal)
-> SyncEntity' text hash defn patch branchh branch causal
Entity.N (SyncBranchFormat'
   BranchObjectId
   TextId
   ObjectId
   PatchObjectId
   (BranchObjectId, CausalHashId)
 -> SyncEntity)
-> Either
     DecodeError
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
-> Either DecodeError SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Either
     DecodeError
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
decodeSyncNamespaceFormat ByteString
bytes
          ObjectType
Patch -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncPatchFormat' patch text hash defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.P (SyncPatchFormat' PatchObjectId TextId HashId ObjectId
 -> SyncEntity)
-> Either
     DecodeError (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Either DecodeError SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Either
     DecodeError (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
decodeSyncPatchFormat ByteString
bytes

-- | Read an entity out of temp storage.
expectTempEntity :: Hash32 -> Transaction TempEntity
expectTempEntity :: Hash32 -> Transaction TempEntity
expectTempEntity Hash32
hash = do
  Sql
-> ((ByteString, TempEntityType) -> Either DecodeError TempEntity)
-> Transaction TempEntity
forall a e r.
(FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneRowCheck
    [sql|
      SELECT blob, type_id
      FROM temp_entity
      WHERE hash = :hash
    |]
    \(ByteString
blob, TempEntityType
typeId) ->
      case TempEntityType
typeId of
        TempEntityType
TempEntityType.TermComponentType -> SyncTermFormat' Text Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncTermFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.TC (SyncTermFormat' Text Hash32 -> TempEntity)
-> Either DecodeError (SyncTermFormat' Text Hash32)
-> Either DecodeError TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either DecodeError (SyncTermFormat' Text Hash32)
decodeTempTermFormat ByteString
blob
        TempEntityType
TempEntityType.DeclComponentType -> SyncDeclFormat' Text Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncDeclFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.DC (SyncDeclFormat' Text Hash32 -> TempEntity)
-> Either DecodeError (SyncDeclFormat' Text Hash32)
-> Either DecodeError TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either DecodeError (SyncDeclFormat' Text Hash32)
decodeTempDeclFormat ByteString
blob
        TempEntityType
TempEntityType.NamespaceType -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
-> TempEntity
forall text hash defn patch branchh branch causal.
SyncBranchFormat' branch text defn patch (branch, causal)
-> SyncEntity' text hash defn patch branchh branch causal
Entity.N (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
 -> TempEntity)
-> Either
     DecodeError
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Either DecodeError TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Either
     DecodeError
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
decodeTempNamespaceFormat ByteString
blob
        TempEntityType
TempEntityType.PatchType -> SyncPatchFormat' Hash32 Text Hash32 Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncPatchFormat' patch text hash defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.P (SyncPatchFormat' Hash32 Text Hash32 Hash32 -> TempEntity)
-> Either DecodeError (SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Either DecodeError TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Either DecodeError (SyncPatchFormat' Hash32 Text Hash32 Hash32)
decodeTempPatchFormat ByteString
blob
        TempEntityType
TempEntityType.CausalType -> SyncCausalFormat' Hash32 Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncCausalFormat' causal branchh
-> SyncEntity' text hash defn patch branchh branch causal
Entity.C (SyncCausalFormat' Hash32 Hash32 -> TempEntity)
-> Either DecodeError (SyncCausalFormat' Hash32 Hash32)
-> Either DecodeError TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either DecodeError (SyncCausalFormat' Hash32 Hash32)
decodeTempCausalFormat ByteString
blob

{- ORMOLU_ENABLE -}

-- | look up all of the input entity's dependencies in the main table, to convert it to a sync entity
tempToSyncEntity :: TempEntity -> Transaction SyncEntity
tempToSyncEntity :: TempEntity -> Transaction SyncEntity
tempToSyncEntity = \case
  Entity.TC SyncTermFormat' Text Hash32
term -> SyncTermFormat' TextId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncTermFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.TC (SyncTermFormat' TextId ObjectId -> SyncEntity)
-> Transaction (SyncTermFormat' TextId ObjectId)
-> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncTermFormat' Text Hash32
-> Transaction (SyncTermFormat' TextId ObjectId)
tempToSyncTermComponent SyncTermFormat' Text Hash32
term
  Entity.DC SyncDeclFormat' Text Hash32
decl -> SyncDeclFormat' TextId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncDeclFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.DC (SyncDeclFormat' TextId ObjectId -> SyncEntity)
-> Transaction (SyncDeclFormat' TextId ObjectId)
-> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncDeclFormat' Text Hash32
-> Transaction (SyncDeclFormat' TextId ObjectId)
tempToSyncDeclComponent SyncDeclFormat' Text Hash32
decl
  Entity.N SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
namespace -> SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> SyncEntity
forall text hash defn patch branchh branch causal.
SyncBranchFormat' branch text defn patch (branch, causal)
-> SyncEntity' text hash defn patch branchh branch causal
Entity.N (SyncBranchFormat'
   BranchObjectId
   TextId
   ObjectId
   PatchObjectId
   (BranchObjectId, CausalHashId)
 -> SyncEntity)
-> Transaction
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
-> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
-> Transaction
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
tempToSyncNamespace SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
namespace
  Entity.P SyncPatchFormat' Hash32 Text Hash32 Hash32
patch -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncPatchFormat' patch text hash defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.P (SyncPatchFormat' PatchObjectId TextId HashId ObjectId
 -> SyncEntity)
-> Transaction
     (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncPatchFormat' Hash32 Text Hash32 Hash32
-> Transaction
     (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
tempToSyncPatch SyncPatchFormat' Hash32 Text Hash32 Hash32
patch
  Entity.C SyncCausalFormat' Hash32 Hash32
causal -> SyncCausalFormat -> SyncEntity
forall text hash defn patch branchh branch causal.
SyncCausalFormat' causal branchh
-> SyncEntity' text hash defn patch branchh branch causal
Entity.C (SyncCausalFormat -> SyncEntity)
-> Transaction SyncCausalFormat -> Transaction SyncEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncCausalFormat' Hash32 Hash32 -> Transaction SyncCausalFormat
tempToSyncCausal SyncCausalFormat' Hash32 Hash32
causal
  where
    tempToSyncCausal :: TempEntity.TempCausalFormat -> Transaction Causal.SyncCausalFormat
    tempToSyncCausal :: SyncCausalFormat' Hash32 Hash32 -> Transaction SyncCausalFormat
tempToSyncCausal Causal.SyncCausalFormat {Hash32
$sel:valueHash:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> valueHash
valueHash :: Hash32
valueHash, Vector Hash32
$sel:parents:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> Vector causalHash
parents :: Vector Hash32
parents} =
      BranchHashId -> Vector CausalHashId -> SyncCausalFormat
forall causalHash valueHash.
valueHash
-> Vector causalHash -> SyncCausalFormat' causalHash valueHash
Causal.SyncCausalFormat
        (BranchHashId -> Vector CausalHashId -> SyncCausalFormat)
-> Transaction BranchHashId
-> Transaction (Vector CausalHashId -> SyncCausalFormat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash32 -> Transaction BranchHashId
expectBranchHashIdForHash32 Hash32
valueHash
        Transaction (Vector CausalHashId -> SyncCausalFormat)
-> Transaction (Vector CausalHashId)
-> Transaction SyncCausalFormat
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction CausalHashId)
-> Vector Hash32 -> Transaction (Vector CausalHashId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction CausalHashId
expectCausalHashIdForHash32 Vector Hash32
parents

    tempToSyncDeclComponent :: TempEntity.TempDeclFormat -> Transaction DeclFormat.SyncDeclFormat
    tempToSyncDeclComponent :: SyncDeclFormat' Text Hash32
-> Transaction (SyncDeclFormat' TextId ObjectId)
tempToSyncDeclComponent = \case
      DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent Vector (LocalIds' Text Hash32, ByteString)
decls) ->
        SyncLocallyIndexedComponent' TextId ObjectId
-> SyncDeclFormat' TextId ObjectId
forall t d. SyncLocallyIndexedComponent' t d -> SyncDeclFormat' t d
DeclFormat.SyncDecl (SyncLocallyIndexedComponent' TextId ObjectId
 -> SyncDeclFormat' TextId ObjectId)
-> (Vector (LocalIds' TextId ObjectId, ByteString)
    -> SyncLocallyIndexedComponent' TextId ObjectId)
-> Vector (LocalIds' TextId ObjectId, ByteString)
-> SyncDeclFormat' TextId ObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (LocalIds' TextId ObjectId, ByteString)
-> SyncLocallyIndexedComponent' TextId ObjectId
forall t d.
Vector (LocalIds' t d, ByteString)
-> SyncLocallyIndexedComponent' t d
DeclFormat.SyncLocallyIndexedComponent
          (Vector (LocalIds' TextId ObjectId, ByteString)
 -> SyncDeclFormat' TextId ObjectId)
-> Transaction (Vector (LocalIds' TextId ObjectId, ByteString))
-> Transaction (SyncDeclFormat' TextId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LensLike
  Transaction
  (Vector (LocalIds' Text Hash32, ByteString))
  (Vector (LocalIds' TextId ObjectId, ByteString))
  (LocalIds' Text Hash32)
  (LocalIds' TextId ObjectId)
-> LensLike
     Transaction
     (Vector (LocalIds' Text Hash32, ByteString))
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (LocalIds' Text Hash32)
     (LocalIds' TextId ObjectId)
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
Lens.traverseOf
            (((LocalIds' Text Hash32, ByteString)
 -> Transaction (LocalIds' TextId ObjectId, ByteString))
-> Vector (LocalIds' Text Hash32, ByteString)
-> Transaction (Vector (LocalIds' TextId ObjectId, ByteString))
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) -> Vector a -> f (Vector b)
traverse (((LocalIds' Text Hash32, ByteString)
  -> Transaction (LocalIds' TextId ObjectId, ByteString))
 -> Vector (LocalIds' Text Hash32, ByteString)
 -> Transaction (Vector (LocalIds' TextId ObjectId, ByteString)))
-> ((LocalIds' Text Hash32
     -> Transaction (LocalIds' TextId ObjectId))
    -> (LocalIds' Text Hash32, ByteString)
    -> Transaction (LocalIds' TextId ObjectId, ByteString))
-> LensLike
     Transaction
     (Vector (LocalIds' Text Hash32, ByteString))
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (LocalIds' Text Hash32)
     (LocalIds' TextId ObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalIds' Text Hash32 -> Transaction (LocalIds' TextId ObjectId))
-> (LocalIds' Text Hash32, ByteString)
-> Transaction (LocalIds' TextId ObjectId, ByteString)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (LocalIds' Text Hash32, ByteString)
  (LocalIds' TextId ObjectId, ByteString)
  (LocalIds' Text Hash32)
  (LocalIds' TextId ObjectId)
Lens._1)
            ( \LocalIds.LocalIds {Vector Text
textLookup :: Vector Text
$sel:textLookup:LocalIds :: forall t h. LocalIds' t h -> Vector t
textLookup, Vector Hash32
defnLookup :: Vector Hash32
$sel:defnLookup:LocalIds :: forall t h. LocalIds' t h -> Vector h
defnLookup} ->
                Vector TextId -> Vector ObjectId -> LocalIds' TextId ObjectId
forall t h. Vector t -> Vector h -> LocalIds' t h
LocalIds.LocalIds
                  (Vector TextId -> Vector ObjectId -> LocalIds' TextId ObjectId)
-> Transaction (Vector TextId)
-> Transaction (Vector ObjectId -> LocalIds' TextId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Text -> Transaction (Vector TextId)
forall (f :: * -> *).
Traversable f =>
f Text -> Transaction (f TextId)
saveTexts Vector Text
textLookup
                  Transaction (Vector ObjectId -> LocalIds' TextId ObjectId)
-> Transaction (Vector ObjectId)
-> Transaction (LocalIds' TextId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction ObjectId)
-> Vector Hash32 -> Transaction (Vector ObjectId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction ObjectId
expectObjectIdForHash32 Vector Hash32
defnLookup
            )
            Vector (LocalIds' Text Hash32, ByteString)
decls

    tempToSyncNamespace :: TempEntity.TempNamespaceFormat -> Transaction NamespaceFormat.SyncBranchFormat
    tempToSyncNamespace :: SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
-> Transaction
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
tempToSyncNamespace = \case
      NamespaceFormat.SyncFull BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds LocalBranchBytes
bytes ->
        BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-> LocalBranchBytes
-> SyncBranchFormat'
     BranchObjectId
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
forall parent text defn patch child.
BranchLocalIds' text defn patch child
-> LocalBranchBytes
-> SyncBranchFormat' parent text defn patch child
NamespaceFormat.SyncFull (BranchLocalIds'
   TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
 -> LocalBranchBytes
 -> SyncBranchFormat'
      BranchObjectId
      TextId
      ObjectId
      PatchObjectId
      (BranchObjectId, CausalHashId))
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction
     (LocalBranchBytes
      -> SyncBranchFormat'
           BranchObjectId
           TextId
           ObjectId
           PatchObjectId
           (BranchObjectId, CausalHashId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
tempToSyncNamespaceLocalIds BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds Transaction
  (LocalBranchBytes
   -> SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
-> Transaction LocalBranchBytes
-> Transaction
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LocalBranchBytes -> Transaction LocalBranchBytes
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalBranchBytes
bytes
      NamespaceFormat.SyncDiff Hash32
parent BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds LocalBranchBytes
bytes ->
        BranchObjectId
-> BranchLocalIds'
     TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-> LocalBranchBytes
-> SyncBranchFormat'
     BranchObjectId
     TextId
     ObjectId
     PatchObjectId
     (BranchObjectId, CausalHashId)
forall parent text defn patch child.
parent
-> BranchLocalIds' text defn patch child
-> LocalBranchBytes
-> SyncBranchFormat' parent text defn patch child
NamespaceFormat.SyncDiff
          (BranchObjectId
 -> BranchLocalIds'
      TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
 -> LocalBranchBytes
 -> SyncBranchFormat'
      BranchObjectId
      TextId
      ObjectId
      PatchObjectId
      (BranchObjectId, CausalHashId))
-> Transaction BranchObjectId
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
      -> LocalBranchBytes
      -> SyncBranchFormat'
           BranchObjectId
           TextId
           ObjectId
           PatchObjectId
           (BranchObjectId, CausalHashId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash32 -> Transaction BranchObjectId
expectBranchObjectIdForHash32 Hash32
parent
          Transaction
  (BranchLocalIds'
     TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
   -> LocalBranchBytes
   -> SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction
     (LocalBranchBytes
      -> SyncBranchFormat'
           BranchObjectId
           TextId
           ObjectId
           PatchObjectId
           (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
tempToSyncNamespaceLocalIds BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
localIds
          Transaction
  (LocalBranchBytes
   -> SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
-> Transaction LocalBranchBytes
-> Transaction
     (SyncBranchFormat'
        BranchObjectId
        TextId
        ObjectId
        PatchObjectId
        (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LocalBranchBytes -> Transaction LocalBranchBytes
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalBranchBytes
bytes

    tempToSyncNamespaceLocalIds :: TempEntity.TempNamespaceLocalIds -> Transaction NamespaceFormat.BranchLocalIds
    tempToSyncNamespaceLocalIds :: BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds Vector Text
texts Vector Hash32
defns Vector Hash32
patches Vector (Hash32, Hash32)
children) =
      Vector TextId
-> Vector ObjectId
-> Vector PatchObjectId
-> Vector (BranchObjectId, CausalHashId)
-> BranchLocalIds'
     TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
forall t d p c.
Vector t
-> Vector d -> Vector p -> Vector c -> BranchLocalIds' t d p c
NamespaceFormat.LocalIds
        (Vector TextId
 -> Vector ObjectId
 -> Vector PatchObjectId
 -> Vector (BranchObjectId, CausalHashId)
 -> BranchLocalIds'
      TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction (Vector TextId)
-> Transaction
     (Vector ObjectId
      -> Vector PatchObjectId
      -> Vector (BranchObjectId, CausalHashId)
      -> BranchLocalIds'
           TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Text -> Transaction (Vector TextId)
forall (f :: * -> *).
Traversable f =>
f Text -> Transaction (f TextId)
saveTexts Vector Text
texts
        Transaction
  (Vector ObjectId
   -> Vector PatchObjectId
   -> Vector (BranchObjectId, CausalHashId)
   -> BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction (Vector ObjectId)
-> Transaction
     (Vector PatchObjectId
      -> Vector (BranchObjectId, CausalHashId)
      -> BranchLocalIds'
           TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction ObjectId)
-> Vector Hash32 -> Transaction (Vector ObjectId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction ObjectId
expectObjectIdForHash32 Vector Hash32
defns
        Transaction
  (Vector PatchObjectId
   -> Vector (BranchObjectId, CausalHashId)
   -> BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction (Vector PatchObjectId)
-> Transaction
     (Vector (BranchObjectId, CausalHashId)
      -> BranchLocalIds'
           TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction PatchObjectId)
-> Vector Hash32 -> Transaction (Vector PatchObjectId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction PatchObjectId
expectPatchObjectIdForHash32 Vector Hash32
patches
        Transaction
  (Vector (BranchObjectId, CausalHashId)
   -> BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
-> Transaction (Vector (BranchObjectId, CausalHashId))
-> Transaction
     (BranchLocalIds'
        TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Hash32, Hash32) -> Transaction (BranchObjectId, CausalHashId))
-> Vector (Hash32, Hash32)
-> Transaction (Vector (BranchObjectId, CausalHashId))
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) -> Vector a -> f (Vector b)
traverse
          ( \(Hash32
branch, Hash32
causal) ->
              (,)
                (BranchObjectId -> CausalHashId -> (BranchObjectId, CausalHashId))
-> Transaction BranchObjectId
-> Transaction (CausalHashId -> (BranchObjectId, CausalHashId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash32 -> Transaction BranchObjectId
expectBranchObjectIdForHash32 Hash32
branch
                Transaction (CausalHashId -> (BranchObjectId, CausalHashId))
-> Transaction CausalHashId
-> Transaction (BranchObjectId, CausalHashId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Hash32 -> Transaction CausalHashId
expectCausalHashIdForHash32 Hash32
causal
          )
          Vector (Hash32, Hash32)
children

    tempToSyncPatch :: TempEntity.TempPatchFormat -> Transaction PatchFormat.SyncPatchFormat
    tempToSyncPatch :: SyncPatchFormat' Hash32 Text Hash32 Hash32
-> Transaction
     (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
tempToSyncPatch = \case
      PatchFormat.SyncFull PatchLocalIds' Text Hash32 Hash32
localIds ByteString
bytes -> PatchLocalIds' TextId HashId ObjectId
-> ByteString
-> SyncPatchFormat' PatchObjectId TextId HashId ObjectId
forall parent text hash defn.
PatchLocalIds' text hash defn
-> ByteString -> SyncPatchFormat' parent text hash defn
PatchFormat.SyncFull (PatchLocalIds' TextId HashId ObjectId
 -> ByteString
 -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
-> Transaction
     (ByteString
      -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchLocalIds' Text Hash32 Hash32
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
tempToSyncPatchLocalIds PatchLocalIds' Text Hash32 Hash32
localIds Transaction
  (ByteString
   -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction ByteString
-> Transaction
     (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Transaction ByteString
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bytes
      PatchFormat.SyncDiff Hash32
parent PatchLocalIds' Text Hash32 Hash32
localIds ByteString
bytes ->
        PatchObjectId
-> PatchLocalIds' TextId HashId ObjectId
-> ByteString
-> SyncPatchFormat' PatchObjectId TextId HashId ObjectId
forall parent text hash defn.
parent
-> PatchLocalIds' text hash defn
-> ByteString
-> SyncPatchFormat' parent text hash defn
PatchFormat.SyncDiff
          (PatchObjectId
 -> PatchLocalIds' TextId HashId ObjectId
 -> ByteString
 -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction PatchObjectId
-> Transaction
     (PatchLocalIds' TextId HashId ObjectId
      -> ByteString
      -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash32 -> Transaction PatchObjectId
expectPatchObjectIdForHash32 Hash32
parent
          Transaction
  (PatchLocalIds' TextId HashId ObjectId
   -> ByteString
   -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
-> Transaction
     (ByteString
      -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PatchLocalIds' Text Hash32 Hash32
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
tempToSyncPatchLocalIds PatchLocalIds' Text Hash32 Hash32
localIds
          Transaction
  (ByteString
   -> SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
-> Transaction ByteString
-> Transaction
     (SyncPatchFormat' PatchObjectId TextId HashId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Transaction ByteString
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bytes

    tempToSyncPatchLocalIds :: TempEntity.TempPatchLocalIds -> Transaction PatchFormat.PatchLocalIds
    tempToSyncPatchLocalIds :: PatchLocalIds' Text Hash32 Hash32
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
tempToSyncPatchLocalIds (PatchFormat.LocalIds Vector Text
texts Vector Hash32
hashes Vector Hash32
defns) =
      Vector TextId
-> Vector HashId
-> Vector ObjectId
-> PatchLocalIds' TextId HashId ObjectId
forall t h d.
Vector t -> Vector h -> Vector d -> PatchLocalIds' t h d
PatchFormat.LocalIds
        (Vector TextId
 -> Vector HashId
 -> Vector ObjectId
 -> PatchLocalIds' TextId HashId ObjectId)
-> Transaction (Vector TextId)
-> Transaction
     (Vector HashId
      -> Vector ObjectId -> PatchLocalIds' TextId HashId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Text -> Transaction (Vector TextId)
forall (f :: * -> *).
Traversable f =>
f Text -> Transaction (f TextId)
saveTexts Vector Text
texts
        Transaction
  (Vector HashId
   -> Vector ObjectId -> PatchLocalIds' TextId HashId ObjectId)
-> Transaction (Vector HashId)
-> Transaction
     (Vector ObjectId -> PatchLocalIds' TextId HashId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Vector Hash32 -> Transaction (Vector HashId)
forall (f :: * -> *).
Traversable f =>
f Hash32 -> Transaction (f HashId)
saveHashes Vector Hash32
hashes
        Transaction
  (Vector ObjectId -> PatchLocalIds' TextId HashId ObjectId)
-> Transaction (Vector ObjectId)
-> Transaction (PatchLocalIds' TextId HashId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction ObjectId)
-> Vector Hash32 -> Transaction (Vector ObjectId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction ObjectId
expectObjectIdForHash32 Vector Hash32
defns

    tempToSyncTermComponent :: TempEntity.TempTermFormat -> Transaction TermFormat.SyncTermFormat
    tempToSyncTermComponent :: SyncTermFormat' Text Hash32
-> Transaction (SyncTermFormat' TextId ObjectId)
tempToSyncTermComponent = \case
      TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent Vector (LocalIds' Text Hash32, ByteString)
terms) ->
        SyncLocallyIndexedComponent' TextId ObjectId
-> SyncTermFormat' TextId ObjectId
forall t d. SyncLocallyIndexedComponent' t d -> SyncTermFormat' t d
TermFormat.SyncTerm (SyncLocallyIndexedComponent' TextId ObjectId
 -> SyncTermFormat' TextId ObjectId)
-> (Vector (LocalIds' TextId ObjectId, ByteString)
    -> SyncLocallyIndexedComponent' TextId ObjectId)
-> Vector (LocalIds' TextId ObjectId, ByteString)
-> SyncTermFormat' TextId ObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (LocalIds' TextId ObjectId, ByteString)
-> SyncLocallyIndexedComponent' TextId ObjectId
forall t d.
Vector (LocalIds' t d, ByteString)
-> SyncLocallyIndexedComponent' t d
TermFormat.SyncLocallyIndexedComponent
          (Vector (LocalIds' TextId ObjectId, ByteString)
 -> SyncTermFormat' TextId ObjectId)
-> Transaction (Vector (LocalIds' TextId ObjectId, ByteString))
-> Transaction (SyncTermFormat' TextId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LensLike
  Transaction
  (Vector (LocalIds' Text Hash32, ByteString))
  (Vector (LocalIds' TextId ObjectId, ByteString))
  (LocalIds' Text Hash32)
  (LocalIds' TextId ObjectId)
-> LensLike
     Transaction
     (Vector (LocalIds' Text Hash32, ByteString))
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (LocalIds' Text Hash32)
     (LocalIds' TextId ObjectId)
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
Lens.traverseOf
            (((LocalIds' Text Hash32, ByteString)
 -> Transaction (LocalIds' TextId ObjectId, ByteString))
-> Vector (LocalIds' Text Hash32, ByteString)
-> Transaction (Vector (LocalIds' TextId ObjectId, ByteString))
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) -> Vector a -> f (Vector b)
traverse (((LocalIds' Text Hash32, ByteString)
  -> Transaction (LocalIds' TextId ObjectId, ByteString))
 -> Vector (LocalIds' Text Hash32, ByteString)
 -> Transaction (Vector (LocalIds' TextId ObjectId, ByteString)))
-> ((LocalIds' Text Hash32
     -> Transaction (LocalIds' TextId ObjectId))
    -> (LocalIds' Text Hash32, ByteString)
    -> Transaction (LocalIds' TextId ObjectId, ByteString))
-> LensLike
     Transaction
     (Vector (LocalIds' Text Hash32, ByteString))
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (LocalIds' Text Hash32)
     (LocalIds' TextId ObjectId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalIds' Text Hash32 -> Transaction (LocalIds' TextId ObjectId))
-> (LocalIds' Text Hash32, ByteString)
-> Transaction (LocalIds' TextId ObjectId, ByteString)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (LocalIds' Text Hash32, ByteString)
  (LocalIds' TextId ObjectId, ByteString)
  (LocalIds' Text Hash32)
  (LocalIds' TextId ObjectId)
Lens._1)
            ( \LocalIds.LocalIds {Vector Text
$sel:textLookup:LocalIds :: forall t h. LocalIds' t h -> Vector t
textLookup :: Vector Text
textLookup, Vector Hash32
$sel:defnLookup:LocalIds :: forall t h. LocalIds' t h -> Vector h
defnLookup :: Vector Hash32
defnLookup} ->
                Vector TextId -> Vector ObjectId -> LocalIds' TextId ObjectId
forall t h. Vector t -> Vector h -> LocalIds' t h
LocalIds.LocalIds
                  (Vector TextId -> Vector ObjectId -> LocalIds' TextId ObjectId)
-> Transaction (Vector TextId)
-> Transaction (Vector ObjectId -> LocalIds' TextId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Text -> Transaction (Vector TextId)
forall (f :: * -> *).
Traversable f =>
f Text -> Transaction (f TextId)
saveTexts Vector Text
textLookup
                  Transaction (Vector ObjectId -> LocalIds' TextId ObjectId)
-> Transaction (Vector ObjectId)
-> Transaction (LocalIds' TextId ObjectId)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash32 -> Transaction ObjectId)
-> Vector Hash32 -> Transaction (Vector ObjectId)
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) -> Vector a -> f (Vector b)
traverse Hash32 -> Transaction ObjectId
expectObjectIdForHash32 Vector Hash32
defnLookup
            )
            Vector (LocalIds' Text Hash32, ByteString)
terms

{- ORMOLU_DISABLE -}

-- | looking up all of the text and hashes is the first step of converting a SyncEntity to a Share.Entity
syncToTempEntity :: SyncEntity -> Transaction TempEntity
syncToTempEntity :: SyncEntity -> Transaction TempEntity
syncToTempEntity = \case
  Entity.TC SyncTermFormat' TextId ObjectId
term -> SyncTermFormat' Text Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncTermFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.TC (SyncTermFormat' Text Hash32 -> TempEntity)
-> Transaction (SyncTermFormat' Text Hash32)
-> Transaction TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncTermFormat' TextId ObjectId
-> Transaction (SyncTermFormat' Text Hash32)
syncToTempTermComponent SyncTermFormat' TextId ObjectId
term
  Entity.DC SyncDeclFormat' TextId ObjectId
decl -> SyncDeclFormat' Text Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncDeclFormat' text defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.DC (SyncDeclFormat' Text Hash32 -> TempEntity)
-> Transaction (SyncDeclFormat' Text Hash32)
-> Transaction TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncDeclFormat' TextId ObjectId
-> Transaction (SyncDeclFormat' Text Hash32)
syncToTempDeclComponent SyncDeclFormat' TextId ObjectId
decl
  Entity.N SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
namespace -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
-> TempEntity
forall text hash defn patch branchh branch causal.
SyncBranchFormat' branch text defn patch (branch, causal)
-> SyncEntity' text hash defn patch branchh branch causal
Entity.N (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
 -> TempEntity)
-> Transaction
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> Transaction
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
syncToTempNamespace SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
namespace
  Entity.P SyncPatchFormat' PatchObjectId TextId HashId ObjectId
patch -> SyncPatchFormat' Hash32 Text Hash32 Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncPatchFormat' patch text hash defn
-> SyncEntity' text hash defn patch branchh branch causal
Entity.P (SyncPatchFormat' Hash32 Text Hash32 Hash32 -> TempEntity)
-> Transaction (SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncPatchFormat' PatchObjectId TextId HashId ObjectId
-> Transaction (SyncPatchFormat' Hash32 Text Hash32 Hash32)
syncToTempPatch SyncPatchFormat' PatchObjectId TextId HashId ObjectId
patch
  Entity.C SyncCausalFormat
causal -> SyncCausalFormat' Hash32 Hash32 -> TempEntity
forall text hash defn patch branchh branch causal.
SyncCausalFormat' causal branchh
-> SyncEntity' text hash defn patch branchh branch causal
Entity.C (SyncCausalFormat' Hash32 Hash32 -> TempEntity)
-> Transaction (SyncCausalFormat' Hash32 Hash32)
-> Transaction TempEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SyncCausalFormat -> Transaction (SyncCausalFormat' Hash32 Hash32)
syncToTempCausal SyncCausalFormat
causal
  where
    syncToTempCausal :: Causal.SyncCausalFormat -> Transaction TempEntity.TempCausalFormat
    syncToTempCausal :: SyncCausalFormat -> Transaction (SyncCausalFormat' Hash32 Hash32)
syncToTempCausal Causal.SyncCausalFormat {BranchHashId
$sel:valueHash:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> valueHash
valueHash :: BranchHashId
valueHash, Vector CausalHashId
$sel:parents:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> Vector causalHash
parents :: Vector CausalHashId
parents} =
      Hash32 -> Vector Hash32 -> SyncCausalFormat' Hash32 Hash32
forall causalHash valueHash.
valueHash
-> Vector causalHash -> SyncCausalFormat' causalHash valueHash
Causal.SyncCausalFormat
        (Hash32 -> Vector Hash32 -> SyncCausalFormat' Hash32 Hash32)
-> Transaction Hash32
-> Transaction (Vector Hash32 -> SyncCausalFormat' Hash32 Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashId -> Transaction Hash32
expectHash32 (BranchHashId -> HashId
unBranchHashId BranchHashId
valueHash)
        Transaction (Vector Hash32 -> SyncCausalFormat' Hash32 Hash32)
-> Transaction (Vector Hash32)
-> Transaction (SyncCausalFormat' Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CausalHashId -> Transaction Hash32)
-> Vector CausalHashId -> Transaction (Vector Hash32)
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) -> Vector a -> f (Vector b)
traverse (HashId -> Transaction Hash32
expectHash32 (HashId -> Transaction Hash32)
-> (CausalHashId -> HashId) -> CausalHashId -> Transaction Hash32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHashId -> HashId
unCausalHashId) Vector CausalHashId
parents

    syncToTempDeclComponent :: DeclFormat.SyncDeclFormat -> Transaction TempEntity.TempDeclFormat
    syncToTempDeclComponent :: SyncDeclFormat' TextId ObjectId
-> Transaction (SyncDeclFormat' Text Hash32)
syncToTempDeclComponent = \case
      DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent Vector (LocalIds' TextId ObjectId, ByteString)
decls) ->
        SyncLocallyIndexedComponent' Text Hash32
-> SyncDeclFormat' Text Hash32
forall t d. SyncLocallyIndexedComponent' t d -> SyncDeclFormat' t d
DeclFormat.SyncDecl (SyncLocallyIndexedComponent' Text Hash32
 -> SyncDeclFormat' Text Hash32)
-> (Vector (LocalIds' Text Hash32, ByteString)
    -> SyncLocallyIndexedComponent' Text Hash32)
-> Vector (LocalIds' Text Hash32, ByteString)
-> SyncDeclFormat' Text Hash32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (LocalIds' Text Hash32, ByteString)
-> SyncLocallyIndexedComponent' Text Hash32
forall t d.
Vector (LocalIds' t d, ByteString)
-> SyncLocallyIndexedComponent' t d
DeclFormat.SyncLocallyIndexedComponent
          (Vector (LocalIds' Text Hash32, ByteString)
 -> SyncDeclFormat' Text Hash32)
-> Transaction (Vector (LocalIds' Text Hash32, ByteString))
-> Transaction (SyncDeclFormat' Text Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LensLike
  Transaction
  (Vector (LocalIds' TextId ObjectId, ByteString))
  (Vector (LocalIds' Text Hash32, ByteString))
  (LocalIds' TextId ObjectId)
  (LocalIds' Text Hash32)
-> LensLike
     Transaction
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (Vector (LocalIds' Text Hash32, ByteString))
     (LocalIds' TextId ObjectId)
     (LocalIds' Text Hash32)
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
Lens.traverseOf (((LocalIds' TextId ObjectId, ByteString)
 -> Transaction (LocalIds' Text Hash32, ByteString))
-> Vector (LocalIds' TextId ObjectId, ByteString)
-> Transaction (Vector (LocalIds' Text Hash32, ByteString))
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) -> Vector a -> f (Vector b)
traverse (((LocalIds' TextId ObjectId, ByteString)
  -> Transaction (LocalIds' Text Hash32, ByteString))
 -> Vector (LocalIds' TextId ObjectId, ByteString)
 -> Transaction (Vector (LocalIds' Text Hash32, ByteString)))
-> ((LocalIds' TextId ObjectId
     -> Transaction (LocalIds' Text Hash32))
    -> (LocalIds' TextId ObjectId, ByteString)
    -> Transaction (LocalIds' Text Hash32, ByteString))
-> LensLike
     Transaction
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (Vector (LocalIds' Text Hash32, ByteString))
     (LocalIds' TextId ObjectId)
     (LocalIds' Text Hash32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalIds' TextId ObjectId -> Transaction (LocalIds' Text Hash32))
-> (LocalIds' TextId ObjectId, ByteString)
-> Transaction (LocalIds' Text Hash32, ByteString)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (LocalIds' TextId ObjectId, ByteString)
  (LocalIds' Text Hash32, ByteString)
  (LocalIds' TextId ObjectId)
  (LocalIds' Text Hash32)
Lens._1) ((TextId -> Transaction Text)
-> (ObjectId -> Transaction Hash32)
-> LocalIds' TextId ObjectId
-> Transaction (LocalIds' Text Hash32)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> LocalIds' a b -> f (LocalIds' 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 TextId -> Transaction Text
expectText ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId) Vector (LocalIds' TextId ObjectId, ByteString)
decls

    syncToTempNamespace :: NamespaceFormat.SyncBranchFormat -> Transaction TempEntity.TempNamespaceFormat
    syncToTempNamespace :: SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> Transaction
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
syncToTempNamespace = \case
      NamespaceFormat.SyncFull BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
localIds LocalBranchBytes
bytes ->
        BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> LocalBranchBytes
-> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
forall parent text defn patch child.
BranchLocalIds' text defn patch child
-> LocalBranchBytes
-> SyncBranchFormat' parent text defn patch child
NamespaceFormat.SyncFull (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
 -> LocalBranchBytes
 -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction
     (LocalBranchBytes
      -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
syncToTempNamespaceLocalIds BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
localIds Transaction
  (LocalBranchBytes
   -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction LocalBranchBytes
-> Transaction
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LocalBranchBytes -> Transaction LocalBranchBytes
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalBranchBytes
bytes
      NamespaceFormat.SyncDiff BranchObjectId
parent BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
localIds LocalBranchBytes
bytes ->
        Hash32
-> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
-> LocalBranchBytes
-> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)
forall parent text defn patch child.
parent
-> BranchLocalIds' text defn patch child
-> LocalBranchBytes
-> SyncBranchFormat' parent text defn patch child
NamespaceFormat.SyncDiff
          (Hash32
 -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
 -> LocalBranchBytes
 -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction Hash32
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
      -> LocalBranchBytes
      -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId (BranchObjectId -> ObjectId
unBranchObjectId BranchObjectId
parent)
          Transaction
  (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
   -> LocalBranchBytes
   -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction
     (LocalBranchBytes
      -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
syncToTempNamespaceLocalIds BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
localIds
          Transaction
  (LocalBranchBytes
   -> SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction LocalBranchBytes
-> Transaction
     (SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LocalBranchBytes -> Transaction LocalBranchBytes
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalBranchBytes
bytes

    syncToTempNamespaceLocalIds :: NamespaceFormat.BranchLocalIds -> Transaction TempEntity.TempNamespaceLocalIds
    syncToTempNamespaceLocalIds :: BranchLocalIds'
  TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
syncToTempNamespaceLocalIds (NamespaceFormat.LocalIds Vector TextId
texts Vector ObjectId
defns Vector PatchObjectId
patches Vector (BranchObjectId, CausalHashId)
children) =
      Vector Text
-> Vector Hash32
-> Vector Hash32
-> Vector (Hash32, Hash32)
-> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32)
forall t d p c.
Vector t
-> Vector d -> Vector p -> Vector c -> BranchLocalIds' t d p c
NamespaceFormat.LocalIds
        (Vector Text
 -> Vector Hash32
 -> Vector Hash32
 -> Vector (Hash32, Hash32)
 -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction (Vector Text)
-> Transaction
     (Vector Hash32
      -> Vector Hash32
      -> Vector (Hash32, Hash32)
      -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextId -> Transaction Text)
-> Vector TextId -> Transaction (Vector Text)
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) -> Vector a -> f (Vector b)
traverse TextId -> Transaction Text
expectText Vector TextId
texts
        Transaction
  (Vector Hash32
   -> Vector Hash32
   -> Vector (Hash32, Hash32)
   -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction (Vector Hash32)
-> Transaction
     (Vector Hash32
      -> Vector (Hash32, Hash32)
      -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ObjectId -> Transaction Hash32)
-> Vector ObjectId -> Transaction (Vector Hash32)
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) -> Vector a -> f (Vector b)
traverse ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId Vector ObjectId
defns
        Transaction
  (Vector Hash32
   -> Vector (Hash32, Hash32)
   -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction (Vector Hash32)
-> Transaction
     (Vector (Hash32, Hash32)
      -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (PatchObjectId -> Transaction Hash32)
-> Vector PatchObjectId -> Transaction (Vector Hash32)
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) -> Vector a -> f (Vector b)
traverse (ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId (ObjectId -> Transaction Hash32)
-> (PatchObjectId -> ObjectId)
-> PatchObjectId
-> Transaction Hash32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchObjectId -> ObjectId
unPatchObjectId) Vector PatchObjectId
patches
        Transaction
  (Vector (Hash32, Hash32)
   -> BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
-> Transaction (Vector (Hash32, Hash32))
-> Transaction
     (BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32))
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((BranchObjectId, CausalHashId) -> Transaction (Hash32, Hash32))
-> Vector (BranchObjectId, CausalHashId)
-> Transaction (Vector (Hash32, Hash32))
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) -> Vector a -> f (Vector b)
traverse
          ( \(BranchObjectId
branch, CausalHashId
causal) ->
              (,)
                (Hash32 -> Hash32 -> (Hash32, Hash32))
-> Transaction Hash32 -> Transaction (Hash32 -> (Hash32, Hash32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId (BranchObjectId -> ObjectId
unBranchObjectId BranchObjectId
branch)
                Transaction (Hash32 -> (Hash32, Hash32))
-> Transaction Hash32 -> Transaction (Hash32, Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashId -> Transaction Hash32
expectHash32 (CausalHashId -> HashId
unCausalHashId CausalHashId
causal)
          )
          Vector (BranchObjectId, CausalHashId)
children

    syncToTempPatch :: PatchFormat.SyncPatchFormat -> Transaction TempEntity.TempPatchFormat
    syncToTempPatch :: SyncPatchFormat' PatchObjectId TextId HashId ObjectId
-> Transaction (SyncPatchFormat' Hash32 Text Hash32 Hash32)
syncToTempPatch = \case
      PatchFormat.SyncFull PatchLocalIds' TextId HashId ObjectId
localIds ByteString
bytes -> PatchLocalIds' Text Hash32 Hash32
-> ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32
forall parent text hash defn.
PatchLocalIds' text hash defn
-> ByteString -> SyncPatchFormat' parent text hash defn
PatchFormat.SyncFull (PatchLocalIds' Text Hash32 Hash32
 -> ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
-> Transaction
     (ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchLocalIds' TextId HashId ObjectId
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
syncToTempPatchLocalIds PatchLocalIds' TextId HashId ObjectId
localIds Transaction
  (ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction ByteString
-> Transaction (SyncPatchFormat' Hash32 Text Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Transaction ByteString
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bytes
      PatchFormat.SyncDiff PatchObjectId
parent PatchLocalIds' TextId HashId ObjectId
localIds ByteString
bytes ->
        Hash32
-> PatchLocalIds' Text Hash32 Hash32
-> ByteString
-> SyncPatchFormat' Hash32 Text Hash32 Hash32
forall parent text hash defn.
parent
-> PatchLocalIds' text hash defn
-> ByteString
-> SyncPatchFormat' parent text hash defn
PatchFormat.SyncDiff
          (Hash32
 -> PatchLocalIds' Text Hash32 Hash32
 -> ByteString
 -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction Hash32
-> Transaction
     (PatchLocalIds' Text Hash32 Hash32
      -> ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId (PatchObjectId -> ObjectId
unPatchObjectId PatchObjectId
parent)
          Transaction
  (PatchLocalIds' Text Hash32 Hash32
   -> ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
-> Transaction
     (ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PatchLocalIds' TextId HashId ObjectId
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
syncToTempPatchLocalIds PatchLocalIds' TextId HashId ObjectId
localIds
          Transaction
  (ByteString -> SyncPatchFormat' Hash32 Text Hash32 Hash32)
-> Transaction ByteString
-> Transaction (SyncPatchFormat' Hash32 Text Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Transaction ByteString
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bytes

    syncToTempPatchLocalIds :: PatchFormat.PatchLocalIds -> Transaction TempEntity.TempPatchLocalIds
    syncToTempPatchLocalIds :: PatchLocalIds' TextId HashId ObjectId
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
syncToTempPatchLocalIds (PatchFormat.LocalIds Vector TextId
texts Vector HashId
hashes Vector ObjectId
defns) =
      Vector Text
-> Vector Hash32
-> Vector Hash32
-> PatchLocalIds' Text Hash32 Hash32
forall t h d.
Vector t -> Vector h -> Vector d -> PatchLocalIds' t h d
PatchFormat.LocalIds
        (Vector Text
 -> Vector Hash32
 -> Vector Hash32
 -> PatchLocalIds' Text Hash32 Hash32)
-> Transaction (Vector Text)
-> Transaction
     (Vector Hash32
      -> Vector Hash32 -> PatchLocalIds' Text Hash32 Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextId -> Transaction Text)
-> Vector TextId -> Transaction (Vector Text)
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) -> Vector a -> f (Vector b)
traverse TextId -> Transaction Text
expectText Vector TextId
texts
        Transaction
  (Vector Hash32
   -> Vector Hash32 -> PatchLocalIds' Text Hash32 Hash32)
-> Transaction (Vector Hash32)
-> Transaction (Vector Hash32 -> PatchLocalIds' Text Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HashId -> Transaction Hash32)
-> Vector HashId -> Transaction (Vector Hash32)
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) -> Vector a -> f (Vector b)
traverse HashId -> Transaction Hash32
expectHash32 Vector HashId
hashes
        Transaction (Vector Hash32 -> PatchLocalIds' Text Hash32 Hash32)
-> Transaction (Vector Hash32)
-> Transaction (PatchLocalIds' Text Hash32 Hash32)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ObjectId -> Transaction Hash32)
-> Vector ObjectId -> Transaction (Vector Hash32)
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) -> Vector a -> f (Vector b)
traverse ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId Vector ObjectId
defns

    syncToTempTermComponent :: TermFormat.SyncTermFormat -> Transaction TempEntity.TempTermFormat
    syncToTempTermComponent :: SyncTermFormat' TextId ObjectId
-> Transaction (SyncTermFormat' Text Hash32)
syncToTempTermComponent = \case
      TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent Vector (LocalIds' TextId ObjectId, ByteString)
terms) ->
        SyncLocallyIndexedComponent' Text Hash32
-> SyncTermFormat' Text Hash32
forall t d. SyncLocallyIndexedComponent' t d -> SyncTermFormat' t d
TermFormat.SyncTerm (SyncLocallyIndexedComponent' Text Hash32
 -> SyncTermFormat' Text Hash32)
-> (Vector (LocalIds' Text Hash32, ByteString)
    -> SyncLocallyIndexedComponent' Text Hash32)
-> Vector (LocalIds' Text Hash32, ByteString)
-> SyncTermFormat' Text Hash32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (LocalIds' Text Hash32, ByteString)
-> SyncLocallyIndexedComponent' Text Hash32
forall t d.
Vector (LocalIds' t d, ByteString)
-> SyncLocallyIndexedComponent' t d
TermFormat.SyncLocallyIndexedComponent
          (Vector (LocalIds' Text Hash32, ByteString)
 -> SyncTermFormat' Text Hash32)
-> Transaction (Vector (LocalIds' Text Hash32, ByteString))
-> Transaction (SyncTermFormat' Text Hash32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LensLike
  Transaction
  (Vector (LocalIds' TextId ObjectId, ByteString))
  (Vector (LocalIds' Text Hash32, ByteString))
  (LocalIds' TextId ObjectId)
  (LocalIds' Text Hash32)
-> LensLike
     Transaction
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (Vector (LocalIds' Text Hash32, ByteString))
     (LocalIds' TextId ObjectId)
     (LocalIds' Text Hash32)
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
Lens.traverseOf (((LocalIds' TextId ObjectId, ByteString)
 -> Transaction (LocalIds' Text Hash32, ByteString))
-> Vector (LocalIds' TextId ObjectId, ByteString)
-> Transaction (Vector (LocalIds' Text Hash32, ByteString))
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) -> Vector a -> f (Vector b)
traverse (((LocalIds' TextId ObjectId, ByteString)
  -> Transaction (LocalIds' Text Hash32, ByteString))
 -> Vector (LocalIds' TextId ObjectId, ByteString)
 -> Transaction (Vector (LocalIds' Text Hash32, ByteString)))
-> ((LocalIds' TextId ObjectId
     -> Transaction (LocalIds' Text Hash32))
    -> (LocalIds' TextId ObjectId, ByteString)
    -> Transaction (LocalIds' Text Hash32, ByteString))
-> LensLike
     Transaction
     (Vector (LocalIds' TextId ObjectId, ByteString))
     (Vector (LocalIds' Text Hash32, ByteString))
     (LocalIds' TextId ObjectId)
     (LocalIds' Text Hash32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalIds' TextId ObjectId -> Transaction (LocalIds' Text Hash32))
-> (LocalIds' TextId ObjectId, ByteString)
-> Transaction (LocalIds' Text Hash32, ByteString)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (LocalIds' TextId ObjectId, ByteString)
  (LocalIds' Text Hash32, ByteString)
  (LocalIds' TextId ObjectId)
  (LocalIds' Text Hash32)
Lens._1) ((TextId -> Transaction Text)
-> (ObjectId -> Transaction Hash32)
-> LocalIds' TextId ObjectId
-> Transaction (LocalIds' Text Hash32)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> LocalIds' a b -> f (LocalIds' 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 TextId -> Transaction Text
expectText ObjectId -> Transaction Hash32
expectPrimaryHash32ByObjectId) Vector (LocalIds' TextId ObjectId, ByteString)
terms

-- -- maybe: look at whether parent causal is "committed"; if so, then increment;
-- -- otherwise, don't.
-- getNurseryGeneration :: DB m => m Generation
-- getNurseryGeneration = query_ sql <&> \case
--   [] -> Generation 0
--   [fromOnly -> g] -> Generation $ fromMaybe 0 g
--   (fmap fromOnly -> gs) ->
--     error $ "How did I get multiple values out of a MAX()? " ++ show gs
--   where sql = [here|
--     SELECT MAX(gc_generation) FROM causal;
--   |]

expectCausalValueHashId :: CausalHashId -> Transaction BranchHashId
expectCausalValueHashId :: CausalHashId -> Transaction BranchHashId
expectCausalValueHashId (CausalHashId HashId
id) =
  Sql -> Transaction BranchHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (HashId -> Sql
loadCausalValueHashIdSql HashId
id) -- (Only id)

expectCausalHash :: CausalHashId -> Transaction CausalHash
expectCausalHash :: CausalHashId -> Transaction CausalHash
expectCausalHash = (HashId -> Transaction Hash)
-> CausalHashId -> Transaction CausalHash
forall a b. Coercible a b => a -> b
coerce HashId -> Transaction Hash
expectHash

loadCausalValueHashId :: HashId -> Transaction (Maybe BranchHashId)
loadCausalValueHashId :: HashId -> Transaction (Maybe BranchHashId)
loadCausalValueHashId HashId
id =
  Sql -> Transaction (Maybe BranchHashId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (HashId -> Sql
loadCausalValueHashIdSql HashId
id)

loadCausalValueHashIdSql :: HashId -> Sql
loadCausalValueHashIdSql :: HashId -> Sql
loadCausalValueHashIdSql HashId
id =
  [sql|
    SELECT value_hash_id
    FROM causal
    WHERE self_hash_id = :id
  |]

isCausalHash :: HashId -> Transaction Bool
isCausalHash :: HashId -> Transaction Bool
isCausalHash HashId
hash =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM causal
        WHERE self_hash_id = :hash
      )
    |]

-- | Return whether or not a causal exists with the given hash32.
causalExistsByHash32 :: Hash32 -> Transaction Bool
causalExistsByHash32 :: Hash32 -> Transaction Bool
causalExistsByHash32 Hash32
hash =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM causal
        JOIN hash ON causal.self_hash_id = hash.id
        WHERE hash.base32 = :hash
      )
    |]

loadBranchObjectIdByCausalHashId :: CausalHashId -> Transaction (Maybe BranchObjectId)
loadBranchObjectIdByCausalHashId :: CausalHashId -> Transaction (Maybe BranchObjectId)
loadBranchObjectIdByCausalHashId CausalHashId
id = Sql -> Transaction (Maybe BranchObjectId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (CausalHashId -> Sql
loadBranchObjectIdByCausalHashIdSql CausalHashId
id)

expectBranchObjectIdByCausalHashId :: CausalHashId -> Transaction BranchObjectId
expectBranchObjectIdByCausalHashId :: CausalHashId -> Transaction BranchObjectId
expectBranchObjectIdByCausalHashId CausalHashId
id = Sql -> Transaction BranchObjectId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (CausalHashId -> Sql
loadBranchObjectIdByCausalHashIdSql CausalHashId
id)

loadBranchObjectIdByCausalHashIdSql :: CausalHashId -> Sql
loadBranchObjectIdByCausalHashIdSql :: CausalHashId -> Sql
loadBranchObjectIdByCausalHashIdSql CausalHashId
id =
  [sql|
    SELECT object_id FROM hash_object
    INNER JOIN causal ON hash_id = causal.value_hash_id
    WHERE causal.self_hash_id = :id
  |]

expectBranchObjectIdByBranchHashId :: BranchHashId -> Transaction BranchObjectId
expectBranchObjectIdByBranchHashId :: BranchHashId -> Transaction BranchObjectId
expectBranchObjectIdByBranchHashId BranchHashId
id = Sql -> Transaction BranchObjectId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol (BranchHashId -> Sql
loadBranchObjectIdByBranchHashIdSql BranchHashId
id)

loadBranchObjectIdByBranchHashId :: BranchHashId -> Transaction (Maybe BranchObjectId)
loadBranchObjectIdByBranchHashId :: BranchHashId -> Transaction (Maybe BranchObjectId)
loadBranchObjectIdByBranchHashId BranchHashId
id = Sql -> Transaction (Maybe BranchObjectId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol (BranchHashId -> Sql
loadBranchObjectIdByBranchHashIdSql BranchHashId
id)

loadBranchObjectIdByBranchHashIdSql :: BranchHashId -> Sql
loadBranchObjectIdByBranchHashIdSql :: BranchHashId -> Sql
loadBranchObjectIdByBranchHashIdSql BranchHashId
id =
  [sql|
    SELECT object_id FROM hash_object
    WHERE hash_id = :id
  |]

saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction ()
saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction ()
saveCausalParents CausalHashId
child =
  (CausalHashId -> Transaction ())
-> [CausalHashId] -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \CausalHashId
parent ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO causal_parent (causal_id, parent_id)
        VALUES (:child, :parent)
        ON CONFLICT DO NOTHING
      |]

loadCausalParents :: CausalHashId -> Transaction [CausalHashId]
loadCausalParents :: CausalHashId -> Transaction [CausalHashId]
loadCausalParents CausalHashId
h =
  Sql -> Transaction [CausalHashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT parent_id
      FROM causal_parent
      WHERE causal_id = :h
    |]

-- | Like 'loadCausalParents', but the input and outputs are hashes, not hash ids.
loadCausalParentsByHash :: Hash32 -> Transaction [Hash32]
loadCausalParentsByHash :: Hash32 -> Transaction [Hash32]
loadCausalParentsByHash Hash32
hash =
  Sql -> Transaction [Hash32]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT h2.base32
      FROM causal_parent cp
      JOIN hash h1 ON cp.causal_id = h1.id
      JOIN hash h2 ON cp.parent_id = h2.id
      WHERE h1.base32 = :hash COLLATE NOCASE
    |]

saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction ()
saveWatch :: WatchKind -> IdH -> ByteString -> Transaction ()
saveWatch WatchKind
k IdH
r ByteString
blob = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO watch_result (hash_id, component_index, result)
      VALUES (@r, @, :blob)
      ON CONFLICT DO NOTHING
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO watch (hash_id, component_index, watch_kind_id)
      VALUES (@r, @, :k)
      ON CONFLICT DO NOTHING
    |]

loadWatch ::
  SqliteExceptionReason e =>
  WatchKind ->
  S.Reference.IdH ->
  (ByteString -> Either e a) ->
  Transaction (Maybe a)
loadWatch :: forall e a.
SqliteExceptionReason e =>
WatchKind
-> IdH -> (ByteString -> Either e a) -> Transaction (Maybe a)
loadWatch WatchKind
k IdH
r ByteString -> Either e a
check =
  Sql -> (ByteString -> Either e a) -> Transaction (Maybe a)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck
    [sql|
      SELECT result FROM watch_result
      INNER JOIN watch
        ON watch_result.hash_id = watch.hash_id
        AND watch_result.component_index = watch.component_index
      WHERE watch.watch_kind_id = :k
        AND watch.hash_id = @r
        AND watch.component_index = @
    |]
    ByteString -> Either e a
check

loadWatchKindsByReference :: S.Reference.IdH -> Transaction [WatchKind]
loadWatchKindsByReference :: IdH -> Transaction [WatchKind]
loadWatchKindsByReference IdH
r =
  Sql -> Transaction [WatchKind]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT watch_kind_id FROM watch_result
      INNER JOIN watch
        ON watch_result.hash_id = watch.hash_id
        AND watch_result.component_index = watch.component_index
      WHERE watch.hash_id = @r
        AND watch.component_index = @
    |]

loadWatchesByWatchKind :: WatchKind -> Transaction [S.Reference.IdH]
loadWatchesByWatchKind :: WatchKind -> Transaction [IdH]
loadWatchesByWatchKind WatchKind
k =
  Sql -> Transaction [IdH]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT hash_id, component_index
      FROM watch
      WHERE watch_kind_id = :k
    |]

-- | Delete all watches that were put by 'putWatch'.
clearWatches :: Transaction ()
clearWatches :: Transaction ()
clearWatches = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DELETE FROM watch_result |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DELETE FROM watch |]

-- * Index-building
addToTypeIndex :: S.ReferenceH -> S.Referent.Id -> Transaction ()
addToTypeIndex :: ReferenceH -> Id -> Transaction ()
addToTypeIndex ReferenceH
tp Id
tm =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO find_type_index (
        type_reference_builtin,
        type_reference_hash_id,
        type_reference_component_index,
        term_referent_object_id,
        term_referent_component_index,
        term_referent_constructor_index
      ) VALUES (@tp, @, @, @tm, @, @)
      ON CONFLICT DO NOTHING
    |]

getReferentsByType :: S.ReferenceH -> Transaction [S.Referent.Id]
getReferentsByType :: ReferenceH -> Transaction [Id]
getReferentsByType ReferenceH
r =
  Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT
        term_referent_object_id,
        term_referent_component_index,
        term_referent_constructor_index
      FROM find_type_index
      WHERE type_reference_builtin IS @r
        AND type_reference_hash_id IS @
        AND type_reference_component_index IS @
    |]

getTypeReferenceForReferent :: S.Referent.Id -> Transaction S.ReferenceH
getTypeReferenceForReferent :: Id -> Transaction ReferenceH
getTypeReferenceForReferent Id
r =
  Sql -> Transaction ReferenceH
forall a. (FromRow a, HasCallStack) => Sql -> Transaction a
queryOneRow
    [sql|
      SELECT
        type_reference_builtin,
        type_reference_hash_id,
        type_reference_component_index
      FROM find_type_index
      WHERE term_referent_object_id = @r
        AND term_referent_component_index = @
        AND term_referent_constructor_index IS @
    |]

-- todo: error if no results
getTypeReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)]
getTypeReferencesForComponent :: ObjectId -> Transaction [(ReferenceH, Id)]
getTypeReferencesForComponent ObjectId
oId =
  ([ReferenceH :. Id] -> [(ReferenceH, Id)])
-> Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)]
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ReferenceH :. Id) -> (ReferenceH, Id))
-> [ReferenceH :. Id] -> [(ReferenceH, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (ReferenceH :. Id) -> (ReferenceH, Id)
fixupTypeIndexRow) (Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)])
-> Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)]
forall a b. (a -> b) -> a -> b
$
    Sql -> Transaction [ReferenceH :. Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT
          type_reference_builtin,
          type_reference_hash_id,
          type_reference_component_index,
          term_referent_object_id,
          term_referent_component_index,
          term_referent_constructor_index
        FROM find_type_index
        WHERE term_referent_object_id = :oId
      |]

filterTermsByReferentHavingType :: S.ReferenceH -> [S.Referent.Id] -> Transaction [S.Referent.Id]
filterTermsByReferentHavingType :: ReferenceH -> [Id] -> Transaction [Id]
filterTermsByReferentHavingType ReferenceH
typ [Id]
terms = Transaction ()
create Transaction () -> Transaction () -> Transaction ()
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Id] -> (Id -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Id]
terms Id -> Transaction ()
forall {a}. ToRow a => a -> Transaction ()
insert Transaction () -> Transaction [Id] -> Transaction [Id]
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Transaction [Id]
select Transaction [Id] -> Transaction () -> Transaction [Id]
forall a b. Transaction a -> Transaction b -> Transaction a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Transaction ()
drop
  where
    select :: Transaction [Id]
select = Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow [sql|
      SELECT
        q.term_referent_object_id,
        q.term_referent_component_index,
        q.term_referent_constructor_index
      FROM filter_query q, find_type_index t
      WHERE t.type_reference_builtin IS :typeBuiltin
        AND t.type_reference_hash_id IS :typeHashId
        AND t.type_reference_component_index IS :typeComponentIndex
        AND t.term_referent_object_id = q.term_referent_object_id
        AND t.term_referent_component_index = q.term_referent_component_index
        AND t.term_referent_constructor_index IS q.term_referent_constructor_index
    |]
    insert :: a -> Transaction ()
insert a
r = HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql|
      INSERT INTO filter_query (
        term_referent_object_id,
        term_referent_component_index,
        term_referent_constructor_index
      ) VALUES (@r, @, @)
    |]
    Maybe TextId
typeBuiltin :: Maybe TextId = Getting (First TextId) ReferenceH TextId
-> ReferenceH -> Maybe TextId
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview Getting (First TextId) ReferenceH TextId
forall t h t' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p t (f t') -> p (Reference' t h) (f (Reference' t' h))
C.Reference.t_ ReferenceH
typ
    Maybe HashId
typeHashId :: Maybe HashId = Getting (First HashId) ReferenceH HashId
-> ReferenceH -> Maybe HashId
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview ((IdH -> Const (First HashId) IdH)
-> ReferenceH -> Const (First HashId) ReferenceH
forall t h h' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (Id' h) (f (Id' h')) -> p (Reference' t h) (f (Reference' t h'))
C.Reference._ReferenceDerived ((IdH -> Const (First HashId) IdH)
 -> ReferenceH -> Const (First HashId) ReferenceH)
-> ((HashId -> Const (First HashId) HashId)
    -> IdH -> Const (First HashId) IdH)
-> Getting (First HashId) ReferenceH HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashId -> Const (First HashId) HashId)
-> IdH -> Const (First HashId) IdH
forall h h' (f :: * -> *).
Functor f =>
(h -> f h') -> Id' h -> f (Id' h')
C.Reference.idH) ReferenceH
typ
    Maybe Pos
typeComponentIndex :: Maybe C.Reference.Pos = Getting (First Pos) ReferenceH Pos -> ReferenceH -> Maybe Pos
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview ((IdH -> Const (First Pos) IdH)
-> ReferenceH -> Const (First Pos) ReferenceH
forall t h h' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (Id' h) (f (Id' h')) -> p (Reference' t h) (f (Reference' t h'))
C.Reference._ReferenceDerived ((IdH -> Const (First Pos) IdH)
 -> ReferenceH -> Const (First Pos) ReferenceH)
-> ((Pos -> Const (First Pos) Pos) -> IdH -> Const (First Pos) IdH)
-> Getting (First Pos) ReferenceH Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pos -> Const (First Pos) Pos) -> IdH -> Const (First Pos) IdH
forall h (f :: * -> *).
Functor f =>
(Pos -> f Pos) -> Id' h -> f (Id' h)
C.Reference.idPos) ReferenceH
typ
    create :: Transaction ()
create =  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        CREATE TEMPORARY TABLE filter_query (
          term_referent_object_id INTEGER NOT NULL,
          term_referent_component_index INTEGER NOT NULL,
          term_referent_constructor_index INTEGER NULL
        )
      |]
    drop :: Transaction ()
drop =  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql|DROP TABLE filter_query|]

filterTermsByReferenceHavingType :: S.ReferenceH -> [S.Reference.Id] -> Transaction [S.Reference.Id]
filterTermsByReferenceHavingType :: ReferenceH -> [Id] -> Transaction [Id]
filterTermsByReferenceHavingType ReferenceH
typ [Id]
terms = Transaction ()
create Transaction () -> Transaction () -> Transaction ()
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Id] -> (Id -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Id]
terms Id -> Transaction ()
forall {a}. ToRow a => a -> Transaction ()
insert Transaction () -> Transaction [Id] -> Transaction [Id]
forall a b. Transaction a -> Transaction b -> Transaction b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Transaction [Id]
select Transaction [Id] -> Transaction () -> Transaction [Id]
forall a b. Transaction a -> Transaction b -> Transaction a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Transaction ()
drop
  where
    select :: Transaction [Id]
select = Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow [sql|
      SELECT
        q.term_reference_object_id,
        q.term_reference_component_index
      FROM filter_query q, find_type_index t
      WHERE t.type_reference_builtin IS :typeBuiltin
        AND t.type_reference_hash_id IS :typeHashId
        AND t.type_reference_component_index IS :typeComponentIndex
        AND t.term_referent_object_id = q.term_reference_object_id
        AND t.term_referent_component_index = q.term_reference_component_index
        AND t.term_referent_constructor_index IS NULL
    |]
    insert :: a -> Transaction ()
insert a
r = HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql|
      INSERT INTO filter_query (
        term_reference_object_id,
        term_reference_component_index
      ) VALUES (@r, @)
    |]
    Maybe TextId
typeBuiltin :: Maybe TextId = Getting (First TextId) ReferenceH TextId
-> ReferenceH -> Maybe TextId
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview Getting (First TextId) ReferenceH TextId
forall t h t' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p t (f t') -> p (Reference' t h) (f (Reference' t' h))
C.Reference.t_ ReferenceH
typ
    Maybe HashId
typeHashId :: Maybe HashId = Getting (First HashId) ReferenceH HashId
-> ReferenceH -> Maybe HashId
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview ((IdH -> Const (First HashId) IdH)
-> ReferenceH -> Const (First HashId) ReferenceH
forall t h h' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (Id' h) (f (Id' h')) -> p (Reference' t h) (f (Reference' t h'))
C.Reference._ReferenceDerived ((IdH -> Const (First HashId) IdH)
 -> ReferenceH -> Const (First HashId) ReferenceH)
-> ((HashId -> Const (First HashId) HashId)
    -> IdH -> Const (First HashId) IdH)
-> Getting (First HashId) ReferenceH HashId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashId -> Const (First HashId) HashId)
-> IdH -> Const (First HashId) IdH
forall h h' (f :: * -> *).
Functor f =>
(h -> f h') -> Id' h -> f (Id' h')
C.Reference.idH) ReferenceH
typ
    Maybe Pos
typeComponentIndex :: Maybe C.Reference.Pos = Getting (First Pos) ReferenceH Pos -> ReferenceH -> Maybe Pos
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
Lens.preview ((IdH -> Const (First Pos) IdH)
-> ReferenceH -> Const (First Pos) ReferenceH
forall t h h' (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (Id' h) (f (Id' h')) -> p (Reference' t h) (f (Reference' t h'))
C.Reference._ReferenceDerived ((IdH -> Const (First Pos) IdH)
 -> ReferenceH -> Const (First Pos) ReferenceH)
-> ((Pos -> Const (First Pos) Pos) -> IdH -> Const (First Pos) IdH)
-> Getting (First Pos) ReferenceH Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pos -> Const (First Pos) Pos) -> IdH -> Const (First Pos) IdH
forall h (f :: * -> *).
Functor f =>
(Pos -> f Pos) -> Id' h -> f (Id' h)
C.Reference.idPos) ReferenceH
typ
    create :: Transaction ()
create =  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        CREATE TEMPORARY TABLE filter_query (
          term_reference_object_id INTEGER NOT NULL,
          term_reference_component_index INTEGER NOT NULL
        )
      |]
    drop :: Transaction ()
drop =  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql|DROP TABLE filter_query|]


addToTypeMentionsIndex :: S.ReferenceH -> S.Referent.Id -> Transaction ()
addToTypeMentionsIndex :: ReferenceH -> Id -> Transaction ()
addToTypeMentionsIndex ReferenceH
tp Id
tm =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO find_type_mentions_index (
        type_reference_builtin,
        type_reference_hash_id,
        type_reference_component_index,
        term_referent_object_id,
        term_referent_component_index,
        term_referent_constructor_index
      ) VALUES (@tp, @, @, @tm, @, @)
      ON CONFLICT DO NOTHING
    |]

getReferentsByTypeMention :: S.ReferenceH -> Transaction [S.Referent.Id]
getReferentsByTypeMention :: ReferenceH -> Transaction [Id]
getReferentsByTypeMention ReferenceH
r =
  Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT
        term_referent_object_id,
        term_referent_component_index,
        term_referent_constructor_index
      FROM find_type_mentions_index
      WHERE type_reference_builtin IS @r
        AND type_reference_hash_id IS @
        AND type_reference_component_index IS @
    |]

-- todo: error if no results
getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)]
getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(ReferenceH, Id)]
getTypeMentionsReferencesForComponent ObjectId
r =
  ([ReferenceH :. Id] -> [(ReferenceH, Id)])
-> Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)]
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ReferenceH :. Id) -> (ReferenceH, Id))
-> [ReferenceH :. Id] -> [(ReferenceH, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (ReferenceH :. Id) -> (ReferenceH, Id)
fixupTypeIndexRow) (Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)])
-> Transaction [ReferenceH :. Id] -> Transaction [(ReferenceH, Id)]
forall a b. (a -> b) -> a -> b
$
    Sql -> Transaction [ReferenceH :. Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT
          type_reference_builtin,
          type_reference_hash_id,
          type_reference_component_index,
          term_referent_object_id,
          term_referent_component_index,
          term_referent_constructor_index
        FROM find_type_mentions_index
        WHERE term_referent_object_id IS :r
      |]

fixupTypeIndexRow :: S.ReferenceH :. S.Referent.Id -> (S.ReferenceH, S.Referent.Id)
fixupTypeIndexRow :: (ReferenceH :. Id) -> (ReferenceH, Id)
fixupTypeIndexRow (ReferenceH
rh :. Id
ri) = (ReferenceH
rh, Id
ri)

-- | Delete objects without hashes. An object typically *would* have a hash, but (for example) during a migration in which an object's hash
-- may change, its corresponding hash_object row may be updated to point at a new version of that object. This procedure clears out all
-- references to objects that do not have any corresponding hash_object rows.
garbageCollectObjectsWithoutHashes :: Transaction ()
garbageCollectObjectsWithoutHashes :: Transaction ()
garbageCollectObjectsWithoutHashes = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      CREATE TEMPORARY TABLE object_without_hash AS
        SELECT id
        FROM object
        WHERE id NOT IN (
          SELECT object_id
          FROM hash_object
        )
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM dependents_index
      WHERE dependency_object_id IN object_without_hash
        OR dependent_object_id IN object_without_hash
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM find_type_index
      WHERE term_referent_object_id IN object_without_hash
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM find_type_mentions_index
      WHERE term_referent_object_id IN object_without_hash
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM object
      WHERE id IN object_without_hash
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DROP TABLE object_without_hash
    |]

-- | Delete all
garbageCollectWatchesWithoutObjects :: Transaction ()
garbageCollectWatchesWithoutObjects :: Transaction ()
garbageCollectWatchesWithoutObjects = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM watch
      WHERE watch.hash_id NOT IN
      (SELECT hash_object.hash_id FROM hash_object)
    |]

addToDependentsIndex :: [S.Reference] -> S.Reference.Id -> Transaction ()
addToDependentsIndex :: [Reference] -> Id -> Transaction ()
addToDependentsIndex [Reference]
dependencies Id
dependent =
  [Reference] -> (Reference -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Reference]
dependencies \Reference
dependency ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO dependents_index (
          dependency_builtin,
          dependency_object_id,
          dependency_component_index,
          dependent_object_id,
          dependent_component_index
        )
        VALUES (@dependency, @, @, @dependent, @)
        ON CONFLICT DO NOTHING
      |]

-- | Which dependents should be returned?
--
-- * /IncludeAllDependents/. Include all dependents, including references from one's own component-mates, and references
-- from oneself (e.g. those in recursive functions)
-- * /ExcludeSelf/. Include all dependents, including references from one's own component-mates, but excluding
-- actual self references (e.g. those in recursive functions).
-- * /ExcludeOwnComponent/. Include all dependents outside of one's own component.
data DependentsSelector
  = IncludeAllDependents
  | ExcludeSelf
  | ExcludeOwnComponent

-- | Get dependents of a dependency.
getDependentsForDependency :: DependentsSelector -> S.Reference -> Transaction (Set S.Reference.Id)
getDependentsForDependency :: DependentsSelector -> Reference -> Transaction (Set Id)
getDependentsForDependency DependentsSelector
selector Reference
dependency = do
  [Id]
dependents <-
    Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT dependent_object_id, dependent_component_index
        FROM dependents_index
        WHERE dependency_builtin IS @dependency
          AND dependency_object_id IS @
          AND dependency_component_index IS @
      |]
  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
$
    case DependentsSelector
selector of
      DependentsSelector
IncludeAllDependents -> [Id]
dependents
      DependentsSelector
ExcludeSelf -> (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isNotSelfReference [Id]
dependents
      DependentsSelector
ExcludeOwnComponent -> (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isNotReferenceFromOwnComponent [Id]
dependents
  where
    isNotReferenceFromOwnComponent :: S.Reference.Id -> Bool
    isNotReferenceFromOwnComponent :: Id -> Bool
isNotReferenceFromOwnComponent =
      case Reference
dependency of
        ReferenceBuiltin TextId
_ -> Bool -> Id -> Bool
forall a b. a -> b -> a
const Bool
True
        ReferenceDerived (C.Reference.Id ObjectId
oid0 Pos
_pos0) -> \(C.Reference.Id ObjectId
oid1 Pos
_pos1) -> ObjectId
oid0 ObjectId -> ObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= ObjectId
oid1

    isNotSelfReference :: S.Reference.Id -> Bool
    isNotSelfReference :: Id -> Bool
isNotSelfReference =
      case Reference
dependency of
        ReferenceBuiltin TextId
_ -> Bool -> Id -> Bool
forall a b. a -> b -> a
const Bool
True
        ReferenceDerived Id
ref -> (Id
ref Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/=)

getDependentsForDependencyComponent :: ObjectId -> Transaction [S.Reference.Id]
getDependentsForDependencyComponent :: ObjectId -> Transaction [Id]
getDependentsForDependencyComponent ObjectId
dependency =
  (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isNotSelfReference ([Id] -> [Id]) -> Transaction [Id] -> Transaction [Id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT dependent_object_id, dependent_component_index
        FROM dependents_index
        WHERE dependency_builtin IS NULL
          AND dependency_object_id IS :dependency
      |]
  where
    isNotSelfReference :: S.Reference.Id -> Bool
    isNotSelfReference :: Id -> Bool
isNotSelfReference = \case
      (C.Reference.Id ObjectId
oid1 Pos
_pos1) -> ObjectId
dependency ObjectId -> ObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= ObjectId
oid1

-- | Get non-self dependencies of a user-defined dependent.
getDependenciesForDependent :: S.Reference.Id -> Transaction [S.Reference]
getDependenciesForDependent :: Id -> Transaction [Reference]
getDependenciesForDependent dependent :: Id
dependent@(C.Reference.Id ObjectId
oid0 Pos
_) =
  ([Reference] -> [Reference])
-> Transaction [Reference] -> Transaction [Reference]
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Reference -> Bool) -> [Reference] -> [Reference]
forall a. (a -> Bool) -> [a] -> [a]
filter Reference -> Bool
isNotSelfReference) (Transaction [Reference] -> Transaction [Reference])
-> Transaction [Reference] -> Transaction [Reference]
forall a b. (a -> b) -> a -> b
$
    Sql -> Transaction [Reference]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT dependency_builtin, dependency_object_id, dependency_component_index
        FROM dependents_index
        WHERE dependent_object_id IS @dependent
          AND dependent_component_index IS @
      |]
  where
    isNotSelfReference :: S.Reference -> Bool
    isNotSelfReference :: Reference -> Bool
isNotSelfReference = \case
      ReferenceBuiltin TextId
_ -> Bool
True
      ReferenceDerived (C.Reference.Id ObjectId
oid1 Pos
_) -> ObjectId
oid0 ObjectId -> ObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= ObjectId
oid1

-- | Get non-self, user-defined dependencies of a user-defined dependent.
getDependencyIdsForDependent :: S.Reference.Id -> Transaction [S.Reference.Id]
getDependencyIdsForDependent :: Id -> Transaction [Id]
getDependencyIdsForDependent dependent :: Id
dependent@(C.Reference.Id ObjectId
oid0 Pos
_) =
  ([Id] -> [Id]) -> Transaction [Id] -> Transaction [Id]
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isNotSelfReference) (Transaction [Id] -> Transaction [Id])
-> Transaction [Id] -> Transaction [Id]
forall a b. (a -> b) -> a -> b
$
    Sql -> Transaction [Id]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT dependency_object_id, dependency_component_index
        FROM dependents_index
        WHERE dependency_builtin IS NULL
          AND dependent_object_id = @dependent
          AND dependent_component_index = @
      |]
  where
    isNotSelfReference :: S.Reference.Id -> Bool
    isNotSelfReference :: Id -> Bool
isNotSelfReference (C.Reference.Id ObjectId
oid1 Pos
_) =
      ObjectId
oid0 ObjectId -> ObjectId -> Bool
forall a. Eq a => a -> a -> Bool
/= ObjectId
oid1

-- | Given two term (components) A and B, return the set of all terms that are along any "dependency path" from A to B,
-- not including A nor B; i.e., the transitive dependencies of A that are transitive dependents of B.
--
-- For example, if A depends on X and Y, X depends on Q, Y depends on Z, and X and Z depend on B...
--
--     --X-----Q
--    /     \
--   A       B
--    \     /
--     Y---Z
--
-- ...then `getDependenciesBetweenTerms A B` would return the set {X Y Z}
getDependenciesBetweenTerms :: ObjectId -> ObjectId -> Transaction (Set ObjectId)
getDependenciesBetweenTerms :: ObjectId -> ObjectId -> Transaction (Set ObjectId)
getDependenciesBetweenTerms ObjectId
oid1 ObjectId
oid2 =
  Sql -> Transaction [ObjectId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol Sql
theSql Transaction [ObjectId]
-> ([ObjectId] -> Set ObjectId) -> Transaction (Set ObjectId)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [ObjectId] -> Set ObjectId
forall a. Ord a => [a] -> Set a
Set.fromList
  where
    -- Given the example above, we'd have tables that look like this.
    --
    -- First, the `paths` table finds all paths from source `A`, exploring depth-first. As a minor optimization, we seed
    -- the search not with `A`, but rather the direct dependencies of `A` (namely `X` and `Y`).
    --
    -- Naming note: "path_init" / "path_last" refer to the "init" / "last" elements of a list segments of a list (though
    -- our "last" is in reverse order):
    --
    --        [foo, bar, baz, qux]
    --   init  ^^^^^^^^^^^^^
    --   last                 ^^^
    --
    -- +-paths-------------------------+
    -- +-level-+-path_last-+-path_init-+
    -- |     0 |         X |        '' | -- path: [X]
    -- |     0 |         Y |        '' | -- path: [Y]
    -- |     1 |         B |      'X,' | -- path: [X,B]   -- ends in B, yay!
    -- |     1 |         Q |      'X,' | -- path: [X,Q]
    -- |     1 |         Z |      'Y,' | -- path: [Y,Z]
    -- |     2 |         B |    'Z,Y,' | -- path: [Y,Z,B] -- ends in B, yay!
    -- +-------+-----------+-----------+
    --
    -- Next, we seed another recursive CTE with those paths that end in the sink `B`. This is just the (very verbose)
    -- way to unnest an array in SQLite. All we're doing is turning the set of strings {'X,' 'Z,Y,'}, each of which
    -- represents the inner nodes of a full path between `A` and `B`, into the set {X Z Y}, which is just the full set
    -- of such inner nodes, along any path.
    --
    -- +-elems-----------------+
    -- +-path_elem-+-path_init-+
    -- |           |      'X,' |
    -- |           |    'Z,Y,' |
    -- |       'X' |        '' |
    -- |       'Z' |      'Y,' |
    -- |       'Y' |        '' |
    -- +-----------+-----------+
    --
    -- And finally, we just select out the non-null `path_elem` rows from here, casting the strings back to integers for
    -- clarity (this isn't very matter - SQLite would cast on-the-fly).
    --
    -- +-path_elem-+
    -- |         X |
    -- |         Z |
    -- |         Y |
    -- +-----------+
    --
    -- Notes
    --
    -- (1) We only care about term dependencies, not type dependencies. This is because a type can only depend on types,
    --     not terms, so there is no point in searching through a type's transitive dependencies looking for our sink.
    -- (2) No need to search beyond the sink itself, since component dependencies form a DAG.
    -- (3) An explicit cast from e.g. string '1' to int 1 isn't strictly necessary.
    theSql :: Sql
    theSql :: Sql
theSql = [sql|
      WITH RECURSIVE paths(level, path_last, path_init) AS (
        SELECT
          0,
          dependents_index.dependency_object_id,
          ''
        FROM dependents_index
          JOIN object ON dependents_index.dependency_object_id = object.id
        WHERE dependents_index.dependent_object_id = :oid1
          AND object.type_id = 0 -- Note (1)
          AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
        UNION ALL
        SELECT
          paths.level + 1 AS level,
          dependents_index.dependency_object_id,
          dependents_index.dependent_object_id || ',' || paths.path_init
        FROM paths
          JOIN dependents_index
            ON paths.path_last = dependents_index.dependent_object_id
          JOIN object ON dependents_index.dependency_object_id = object.id
        WHERE object.type_id = 0 -- Note (1)
          AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
          AND paths.path_last != :oid2 -- Note (2)
        ORDER BY level DESC
      ),
      elems(path_elem, path_init) AS (
        SELECT null, path_init
        FROM paths
        WHERE paths.path_last = :oid2
        UNION ALL
        SELECT
          substr(path_init, 0, instr(path_init, ',')),
          substr(path_init, instr(path_init, ',') + 1)
        FROM elems
        WHERE path_init != ''
      )
      SELECT DISTINCT CAST(path_elem AS integer) AS path_elem -- Note (3)
      FROM elems
      WHERE path_elem IS NOT null
    |]

-- Mitchell says: why are we enabling and disabling ormolu all over this file? Let's just enable. But right now I'm only
-- adding this one query and don't want a big diff in my PR.

{- ORMOLU_ENABLE -}

getDirectDependenciesOfScope ::
  DefnsF Set S.TermReferenceId S.TypeReferenceId ->
  Transaction (DefnsF Set S.TermReference S.TypeReference)
getDirectDependenciesOfScope :: Defns (Set Id) (Set Id)
-> Transaction (Defns (Set Reference) (Set Reference))
getDirectDependenciesOfScope Defns (Set Id) (Set Id)
scope = do
  let tempTableName :: Sql
tempTableName = [sql| temp_dependents |]

  -- Populate a temporary table with all of the references in `scope`
  Sql -> Set Id -> Transaction ()
createTemporaryTableOfReferenceIds Sql
tempTableName (Set Id -> Set Id -> Set Id
forall a. Ord a => Set a -> Set a -> Set a
Set.union Defns (Set Id) (Set Id)
scope.terms Defns (Set Id) (Set Id)
scope.types)

  -- Get their direct dependencies (tagged with object type)
  [Reference :. Only ObjectType]
dependencies0 <-
    forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow @(S.Reference :. Only ObjectType)
      [sql|
        SELECT d.dependency_builtin, d.dependency_object_id, d.dependency_component_index, o.type_id
        FROM dependents_index d
          JOIN object o ON d.dependency_object_id = o.id
        WHERE (d.dependent_object_id, d.dependent_component_index) IN (
          SELECT object_id, component_index
          FROM $tempTableName
        )
      |]

  -- Drop the temporary table
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DROP TABLE $tempTableName |]

  -- Post-process the query result
  let dependencies1 :: Defns (Set Reference) (Set Reference)
dependencies1 =
        (Defns (Set Reference) (Set Reference)
 -> (Reference :. Only ObjectType)
 -> Defns (Set Reference) (Set Reference))
-> Defns (Set Reference) (Set Reference)
-> [Reference :. Only ObjectType]
-> Defns (Set Reference) (Set Reference)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
          ( \Defns (Set Reference) (Set Reference)
deps -> \case
              Reference
dep :. Only ObjectType
TermComponent -> Set Reference
-> Set Reference -> Defns (Set Reference) (Set Reference)
forall terms types. terms -> types -> Defns terms types
Defns (Reference -> Set Reference -> Set Reference
forall a. Ord a => a -> Set a -> Set a
Set.insert Reference
dep Defns (Set Reference) (Set Reference)
deps.terms) Defns (Set Reference) (Set Reference)
deps.types
              Reference
dep :. Only ObjectType
DeclComponent -> Set Reference
-> Set Reference -> Defns (Set Reference) (Set Reference)
forall terms types. terms -> types -> Defns terms types
Defns Defns (Set Reference) (Set Reference)
deps.terms (Reference -> Set Reference -> Set Reference
forall a. Ord a => a -> Set a -> Set a
Set.insert Reference
dep Defns (Set Reference) (Set Reference)
deps.types)
              Reference :. Only ObjectType
_ -> Defns (Set Reference) (Set Reference)
deps -- impossible; could error here
          )
          (Set Reference
-> Set Reference -> Defns (Set Reference) (Set Reference)
forall terms types. terms -> types -> Defns terms types
Defns Set Reference
forall a. Set a
Set.empty Set Reference
forall a. Set a
Set.empty)
          [Reference :. Only ObjectType]
dependencies0

  pure Defns (Set Reference) (Set Reference)
dependencies1

-- | `getDirectDependentsWithinScope scope query` returns all direct dependents of `query` that are in `scope` (not
-- including `query` itself).
getDirectDependentsWithinScope ::
  Set S.Reference.Id ->
  Set S.Reference ->
  Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId)
getDirectDependentsWithinScope :: Set Id -> Set Reference -> Transaction (Defns (Set Id) (Set Id))
getDirectDependentsWithinScope Set Id
scope Set Reference
query = do
  -- Populate a temporary table with all of the references in `scope`
  let scopeTableName :: Sql
scopeTableName = [sql| dependents_search_scope |]
  Sql -> Set Id -> Transaction ()
createTemporaryTableOfReferenceIds Sql
scopeTableName Set Id
scope

  -- Populate a temporary table with all of the references in `query`
  let queryTableName :: Sql
queryTableName = [sql| dependencies_query |]
  Sql -> Set Reference -> Transaction ()
createTemporaryTableOfReferences Sql
queryTableName Set Reference
query

  -- Get their direct dependents (tagged with object type)
  [Id :. Only ObjectType]
dependents0 <-
    forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow @(S.Reference.Id :. Only ObjectType)
      [sql|
        SELECT s.object_id, s.component_index, o.type_id
        FROM $queryTableName q
          JOIN dependents_index d
            ON q.builtin IS d.dependency_builtin
            AND q.object_id IS d.dependency_object_id
            AND q.component_index IS d.dependency_component_index
          JOIN $scopeTableName s
            ON d.dependent_object_id = s.object_id
            AND d.dependent_component_index = s.component_index
          JOIN object o ON s.object_id = o.id
      |]

  -- Drop the temporary tables
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DROP TABLE $scopeTableName |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DROP TABLE $queryTableName |]

  -- Post-process the query result
  let dependents1 :: Defns (Set Id) (Set Id)
dependents1 =
        (Defns (Set Id) (Set Id)
 -> (Id :. Only ObjectType) -> Defns (Set Id) (Set Id))
-> Defns (Set Id) (Set Id)
-> [Id :. Only ObjectType]
-> Defns (Set Id) (Set Id)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
          ( \Defns (Set Id) (Set Id)
deps -> \case
              Id
dep :. Only ObjectType
TermComponent -> Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns (Id -> Set Id -> Set Id
forall a. Ord a => a -> Set a -> Set a
Set.insert Id
dep Defns (Set Id) (Set Id)
deps.terms) Defns (Set Id) (Set Id)
deps.types
              Id
dep :. Only ObjectType
DeclComponent -> Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns Defns (Set Id) (Set Id)
deps.terms (Id -> Set Id -> Set Id
forall a. Ord a => a -> Set a -> Set a
Set.insert Id
dep Defns (Set Id) (Set Id)
deps.types)
              Id :. Only ObjectType
_ -> Defns (Set Id) (Set Id)
deps -- impossible; could error here
          )
          (Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns Set Id
forall a. Set a
Set.empty Set Id
forall a. Set a
Set.empty)
          [Id :. Only ObjectType]
dependents0

  pure Defns (Set Id) (Set Id)
dependents1

-- | `getTransitiveDependentsWithinScope scope query` returns all transitive dependents of `query` that are in `scope`
-- (not including `query` itself).
getTransitiveDependentsWithinScope ::
  Set S.Reference.Id ->
  Set S.Reference ->
  Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId)
getTransitiveDependentsWithinScope :: Set Id -> Set Reference -> Transaction (Defns (Set Id) (Set Id))
getTransitiveDependentsWithinScope Set Id
scope Set Reference
query = do
  -- Populate a temporary table with all of the references in `scope`
  let scopeTableName :: Sql
scopeTableName = [sql| dependents_search_scope |]
  Sql -> Set Id -> Transaction ()
createTemporaryTableOfReferenceIds Sql
scopeTableName Set Id
scope

  -- Populate a temporary table with all of the references in `query`
  let queryTableName :: Sql
queryTableName = [sql| dependencies_query |]
  Sql -> Set Reference -> Transaction ()
createTemporaryTableOfReferences Sql
queryTableName Set Reference
query

  -- Say the query set is { #foo, #bar }, and the scope set is { #foo, #bar, #baz, #qux, #honk }.
  --
  -- Furthermore, say the dependencies are as follows, where `x -> y` means "x depends on y".
  --
  --   #honk -> #baz -> #foo
  --            #qux -> #bar
  --
  -- The recursive query below is seeded with direct dependents of the `query` set that are in `scope`, namely:
  --
  --   #honk -> #baz -> #foo
  --            #qux -> #bar
  --            ^^^^
  --            direct deps of { #foo, #bar } are: { #baz, #qux }
  --
  -- Then, every iteration of the query expands to that set's dependents (#honk and onwards), until there are no more.
  -- We use `UNION` rather than `UNION ALL` so as to not track down the transitive dependents of any particular
  -- reference more than once.

  [Id :. Only ObjectType]
result0 :: [S.Reference.Id :. Only ObjectType] <-
    Sql -> Transaction [Id :. Only ObjectType]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        WITH RECURSIVE transitive_dependents (dependent_object_id, dependent_component_index, type_id) AS (
          SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
          FROM dependents_index d
          JOIN object ON d.dependent_object_id = object.id
          JOIN $queryTableName q
            ON q.builtin IS d.dependency_builtin
            AND q.object_id IS d.dependency_object_id
            AND q.component_index IS d.dependency_component_index
          JOIN $scopeTableName s
            ON s.object_id = d.dependent_object_id
            AND s.component_index = d.dependent_component_index

          UNION SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
          FROM dependents_index d
          JOIN object ON d.dependent_object_id = object.id
          JOIN transitive_dependents t
            ON t.dependent_object_id = d.dependency_object_id
            AND t.dependent_component_index = d.dependency_component_index
          JOIN $scopeTableName s
            ON s.object_id = d.dependent_object_id
            AND s.component_index = d.dependent_component_index
        )
        SELECT * FROM transitive_dependents
      |]

  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DROP TABLE $scopeTableName |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DROP TABLE $queryTableName |]

  -- Post-process the query result
  let result1 :: Defns (Set Id) (Set Id)
result1 =
        (Defns (Set Id) (Set Id)
 -> (Id :. Only ObjectType) -> Defns (Set Id) (Set Id))
-> Defns (Set Id) (Set Id)
-> [Id :. Only ObjectType]
-> Defns (Set Id) (Set Id)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
          ( \Defns (Set Id) (Set Id)
deps -> \case
              Id
dep :. Only ObjectType
TermComponent -> Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns (Id -> Set Id -> Set Id
forall a. Ord a => a -> Set a -> Set a
Set.insert Id
dep Defns (Set Id) (Set Id)
deps.terms) Defns (Set Id) (Set Id)
deps.types
              Id
dep :. Only ObjectType
DeclComponent -> Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns Defns (Set Id) (Set Id)
deps.terms (Id -> Set Id -> Set Id
forall a. Ord a => a -> Set a -> Set a
Set.insert Id
dep Defns (Set Id) (Set Id)
deps.types)
              Id :. Only ObjectType
_ -> Defns (Set Id) (Set Id)
deps -- impossible; could error here
          )
          (Set Id -> Set Id -> Defns (Set Id) (Set Id)
forall terms types. terms -> types -> Defns terms types
Defns Set Id
forall a. Set a
Set.empty Set Id
forall a. Set a
Set.empty)
          [Id :. Only ObjectType]
result0

  pure Defns (Set Id) (Set Id)
result1

createTemporaryTableOfReferences :: Sql -> Set S.Reference -> Transaction ()
createTemporaryTableOfReferences :: Sql -> Set Reference -> Transaction ()
createTemporaryTableOfReferences Sql
tableName Set Reference
refs = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      CREATE TEMPORARY TABLE $tableName (
        builtin INTEGER NULL,
        object_id INTEGER NULL,
        component_index INTEGER NULL
        CHECK ((builtin IS NULL) = (object_id IS NOT NULL)),
        CHECK ((object_id IS NULL) = (component_index IS NULL))
      )
    |]

  Set Reference -> (Reference -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set Reference
refs \Reference
ref ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| INSERT INTO $tableName VALUES (@ref, @, @) |]

createTemporaryTableOfReferenceIds :: Sql -> Set S.Reference.Id -> Transaction ()
createTemporaryTableOfReferenceIds :: Sql -> Set Id -> Transaction ()
createTemporaryTableOfReferenceIds Sql
tableName Set Id
refs = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      CREATE TEMPORARY TABLE $tableName (
        object_id INTEGER NOT NULL,
        component_index INTEGER NOT NULL,
        PRIMARY KEY (object_id, component_index)
      )
    |]
  Set Id -> (Id -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set Id
refs \Id
ref ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| INSERT INTO $tableName VALUES (@ref, @) |]

{- ORMOLU_DISABLE -}

objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId]
objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId]
objectIdByBase32Prefix ObjectType
objType Text
prefix =
  Sql -> Transaction [ObjectId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT object.id FROM object
      INNER JOIN hash_object ON hash_object.object_id = object.id
      INNER JOIN hash ON hash_object.hash_id = hash.id
      WHERE object.type_id = :objType
        AND hash.base32 LIKE :prefix2 ESCAPE '\'
    |]
  where
    prefix2 :: Text
prefix2 = Char -> Text -> Text
likeEscape Char
'\\' Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

causalHashIdByBase32Prefix :: Text -> Transaction [CausalHashId]
causalHashIdByBase32Prefix :: Text -> Transaction [CausalHashId]
causalHashIdByBase32Prefix Text
prefix =
  Sql -> Transaction [CausalHashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT self_hash_id FROM causal
      INNER JOIN hash ON id = self_hash_id
      WHERE base32 LIKE :prefix2 ESCAPE '\'
    |]
  where
    prefix2 :: Text
prefix2 = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

namespaceHashIdByBase32Prefix :: Text -> Transaction [BranchHashId]
namespaceHashIdByBase32Prefix :: Text -> Transaction [BranchHashId]
namespaceHashIdByBase32Prefix Text
prefix =
  Sql -> Transaction [BranchHashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT value_hash_id FROM causal
      INNER JOIN hash ON id = value_hash_id
      WHERE base32 LIKE :prefix2 ESCAPE '\'
    |]
  where
    prefix2 :: Text
prefix2 = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

-- | Finds all causals that refer to a branch for which we don't have an object stored.
-- Although there are plans to support this in the future, currently all such cases
-- are the result of database inconsistencies and are unexpected.
getCausalsWithoutBranchObjects :: Transaction [CausalHashId]
getCausalsWithoutBranchObjects :: Transaction [CausalHashId]
getCausalsWithoutBranchObjects =
  Sql -> Transaction [CausalHashId]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      SELECT self_hash_id from causal
      WHERE value_hash_id NOT IN (
        SELECT hash_id
        FROM hash_object
      )
    |]

{- ORMOLU_ENABLE -}

-- | Delete all hash objects of a given hash version.
-- Leaves the corresponding `hash`es in the hash table alone.
removeHashObjectsByHashingVersion :: HashVersion -> Transaction ()
removeHashObjectsByHashingVersion :: HashVersion -> Transaction ()
removeHashObjectsByHashingVersion HashVersion
hashVersion =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM hash_object
      WHERE hash_version = :hashVersion
    |]

-- | Copies existing name lookup rows but replaces their branch hash id;
-- This is a low-level operation used as part of deriving a new name lookup index
-- from an existing one as performantly as possible.
copyScopedNameLookup :: BranchHashId -> BranchHashId -> Transaction ()
copyScopedNameLookup :: BranchHashId -> BranchHashId -> Transaction ()
copyScopedNameLookup BranchHashId
fromBHId BranchHashId
toBHId = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute Sql
termsCopySql
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute Sql
typesCopySql
  where
    termsCopySql :: Sql
termsCopySql =
      [sql|
        INSERT INTO scoped_term_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type)
        SELECT :toBHId, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM scoped_term_name_lookup
        WHERE root_branch_hash_id = :fromBHId
      |]
    typesCopySql :: Sql
typesCopySql =
      [sql|
        INSERT INTO scoped_type_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index)
        SELECT :toBHId, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index
        FROM scoped_type_name_lookup
        WHERE root_branch_hash_id = :fromBHId
      |]

-- | Delete the specified name lookup.
-- This should only be used if you're sure it's unused, or if you're going to re-create it in
-- the same transaction.
deleteNameLookup :: BranchHashId -> Transaction ()
deleteNameLookup :: BranchHashId -> Transaction ()
deleteNameLookup BranchHashId
bhId = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM name_lookups
      WHERE root_branch_hash_id = :bhId
    |]

-- | Inserts a new record into the name_lookups table
trackNewBranchHashNameLookup :: BranchHashId -> Transaction ()
trackNewBranchHashNameLookup :: BranchHashId -> Transaction ()
trackNewBranchHashNameLookup BranchHashId
bhId = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO name_lookups (root_branch_hash_id)
      VALUES (:bhId)
    |]

-- | Check if we've already got an index for the desired root branch hash.
checkBranchHashNameLookupExists :: BranchHashId -> Transaction Bool
checkBranchHashNameLookupExists :: BranchHashId -> Transaction Bool
checkBranchHashNameLookupExists BranchHashId
hashId = do
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM name_lookups
        WHERE root_branch_hash_id = :hashId
        LIMIT 1
      )
    |]

-- | Delete any name lookup that's not in the provided list.
--
-- This can be used to garbage collect unreachable name lookups.
deleteNameLookupsExceptFor :: [BranchHashId] -> Transaction ()
deleteNameLookupsExceptFor :: [BranchHashId] -> Transaction ()
deleteNameLookupsExceptFor [BranchHashId]
hashIds = do
  case [BranchHashId]
hashIds of
    [] -> HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DELETE FROM name_lookups |]
    (BranchHashId
x : [BranchHashId]
xs) -> do
      let hashIdValues :: NonEmpty (Only BranchHashId)
          hashIdValues :: NonEmpty (Only BranchHashId)
hashIdValues = NonEmpty BranchHashId -> NonEmpty (Only BranchHashId)
forall a b. Coercible a b => a -> b
coerce (BranchHashId
x BranchHashId -> [BranchHashId] -> NonEmpty BranchHashId
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [BranchHashId]
xs)
      HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
        [sql|
          WITH RECURSIVE reachable(branch_hash_id) AS (
            VALUES :hashIdValues
            -- Any name lookup that's mounted on a reachable name lookup is also reachable
            UNION ALL
            SELECT mounted_root_branch_hash_id FROM name_lookup_mounts JOIN reachable ON branch_hash_id = parent_root_branch_hash_id
          )
          DELETE FROM name_lookups
            WHERE root_branch_hash_id NOT IN (SELECT branch_hash_id FROM reachable);
        |]

-- | Insert the given set of term names into the name lookup table
insertScopedTermNames :: BranchHashId -> [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction ()
insertScopedTermNames :: BranchHashId
-> [NamedRef (TextReferent, Maybe ConstructorType)]
-> Transaction ()
insertScopedTermNames BranchHashId
bhId = do
  (NamedRef (TextReferent, Maybe ConstructorType) -> Transaction ())
-> [NamedRef (TextReferent, Maybe ConstructorType)]
-> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \NamedRef (TextReferent, Maybe ConstructorType)
name0 -> do
    let name :: ScopedRow (TextReferent :. Only (Maybe ConstructorType))
name = NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> ScopedRow (TextReferent :. Only (Maybe ConstructorType))
forall ref. NamedRef ref -> ScopedRow ref
NamedRef.ScopedRow ((TextReferent, Maybe ConstructorType)
-> TextReferent :. Only (Maybe ConstructorType)
refToRow ((TextReferent, Maybe ConstructorType)
 -> TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedRef (TextReferent, Maybe ConstructorType)
name0)
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO scoped_term_name_lookup (
          root_branch_hash_id,
          reversed_name,
          namespace,
          last_name_segment,
          referent_builtin,
          referent_component_hash,
          referent_component_index,
          referent_constructor_index,
          referent_constructor_type
        )
        VALUES (:bhId, @name, @, @, @, @, @, @, @)
      |]
  where
    refToRow :: (S.TextReferent, Maybe NamedRef.ConstructorType) -> (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))
    refToRow :: (TextReferent, Maybe ConstructorType)
-> TextReferent :. Only (Maybe ConstructorType)
refToRow (TextReferent
ref, Maybe ConstructorType
ct) = TextReferent
ref TextReferent
-> Only (Maybe ConstructorType)
-> TextReferent :. Only (Maybe ConstructorType)
forall h t. h -> t -> h :. t
:. Maybe ConstructorType -> Only (Maybe ConstructorType)
forall a. a -> Only a
Only Maybe ConstructorType
ct

-- | Insert the given set of type names into the name lookup table
insertScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction ()
insertScopedTypeNames :: BranchHashId -> [NamedRef TextReference] -> Transaction ()
insertScopedTypeNames BranchHashId
bhId =
  (NamedRef TextReference -> Transaction ())
-> [NamedRef TextReference] -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \NamedRef TextReference
name0 -> do
    let name :: ScopedRow TextReference
name = NamedRef TextReference -> ScopedRow TextReference
forall ref. NamedRef ref -> ScopedRow ref
NamedRef.ScopedRow NamedRef TextReference
name0
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO scoped_type_name_lookup (
          root_branch_hash_id,
          reversed_name,
          namespace,
          last_name_segment,
          reference_builtin,
          reference_component_hash,
          reference_component_index
        )
        VALUES (:bhId, @name, @, @, @, @, @)
      |]

-- | Remove the given set of term names into the name lookup table
removeScopedTermNames :: BranchHashId -> [NamedRef S.TextReferent] -> Transaction ()
removeScopedTermNames :: BranchHashId -> [NamedRef TextReferent] -> Transaction ()
removeScopedTermNames BranchHashId
bhId [NamedRef TextReferent]
names = do
  [NamedRef TextReferent]
-> (NamedRef TextReferent -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamedRef TextReferent]
names \NamedRef TextReferent
name ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        DELETE FROM scoped_term_name_lookup
        WHERE root_branch_hash_id IS :bhId
          AND reversed_name IS @name
          AND referent_builtin IS @
          AND referent_component_hash IS @
          AND referent_component_index IS @
          AND referent_constructor_index IS @
      |]

-- | Remove the given set of term names into the name lookup table
removeScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction ()
removeScopedTypeNames :: BranchHashId -> [NamedRef TextReference] -> Transaction ()
removeScopedTypeNames BranchHashId
bhId [NamedRef TextReference]
names = do
  [NamedRef TextReference]
-> (NamedRef TextReference -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamedRef TextReference]
names \NamedRef TextReference
name ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        DELETE FROM scoped_type_name_lookup
        WHERE root_branch_hash_id IS :bhId
          AND reversed_name IS @name
          AND reference_builtin IS @
          AND reference_component_hash IS @
          AND reference_component_index IS @
      |]

-- | We need to escape any special characters for globbing.
--
-- >>> globEscape "Nat.*.doc"
-- "Nat.[*].doc"
globEscape :: Text -> Text
globEscape :: Text -> Text
globEscape =
  -- We can't use Text.replace, since we'd end up replacing either "[" or "]" multiple
  -- times.
  (Char -> Text) -> Text -> Text
Text.concatMap \case
    Char
'*' -> Text
"[*]"
    Char
'?' -> Text
"[?]"
    Char
'[' -> Text
"[[]"
    Char
']' -> Text
"[]]"
    Char
c -> Char -> Text
Text.singleton Char
c

-- | Escape special characters for "LIKE" matches.
--
-- Prepared statements prevent sql injection, but it's still possible some user
-- may be able to craft a query using a fake "hash" that would let them see more than they
-- ought to.
--
-- You still need to provide the escape char in the sql query, E.g.
--
-- @@
--   SELECT * FROM table
--     WHERE txt LIKE ? ESCAPE '\'
-- @@
--
-- >>> likeEscape '\\' "Nat.%"
-- "Nat.\%"
likeEscape :: Char -> Text -> Text
likeEscape :: Char -> Text -> Text
likeEscape Char
'%' Text
_ = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Can't use % or _ as escape characters"
likeEscape Char
'_' Text
_ = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Can't use % or _ as escape characters"
likeEscape Char
escapeChar Text
pat =
  ((Char -> Text) -> Text -> Text) -> Text -> (Char -> Text) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Char -> Text) -> Text -> Text
Text.concatMap Text
pat \case
    Char
'%' -> [Char] -> Text
Text.pack [Char
escapeChar, Char
'%']
    Char
'_' -> [Char] -> Text
Text.pack [Char
escapeChar, Char
'_']
    Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
escapeChar -> [Char] -> Text
Text.pack [Char
escapeChar, Char
escapeChar]
      | Bool
otherwise -> Char -> Text
Text.singleton Char
c

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of a term names in the provided name lookup and relative namespace.
-- Includes dependencies, but not transitive dependencies.
termNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)]
termNamesWithinNamespace :: BranchHashId
-> PathSegments
-> Transaction [NamedRef (TextReferent, Maybe ConstructorType)]
termNamesWithinNamespace BranchHashId
bhId PathSegments
namespace = do
  [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
    Sql
-> Transaction
     [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM scoped_term_name_lookup
        WHERE
          root_branch_hash_id = :bhId
          AND namespace GLOB :namespaceGlob

        UNION ALL

        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM name_lookup_mounts mount
          INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE
          mount.parent_root_branch_hash_id = :bhId
          -- We have a pre-condition that the namespace must not be within any of the mounts,
          -- so this is sufficient to determine whether the entire sub-index is within the
          -- required namespace prefix.
          AND mount.mount_path GLOB :namespaceGlob
      |]
  pure (((TextReferent :. Only (Maybe ConstructorType))
 -> (TextReferent, Maybe ConstructorType))
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
forall a b. (a -> b) -> NamedRef a -> NamedRef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TextReferent :. Only (Maybe ConstructorType))
-> (TextReferent, Maybe ConstructorType)
forall {a} {b}. (a :. Only b) -> (a, b)
unRow (NamedRef (TextReferent :. Only (Maybe ConstructorType))
 -> NamedRef (TextReferent, Maybe ConstructorType))
-> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
-> [NamedRef (TextReferent, Maybe ConstructorType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results)
  where
    namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespace
    unRow :: (a :. Only b) -> (a, b)
unRow (a
a :. Only b
b) = (a
a, b
b)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of a type names in the provided name lookup and relative namespace.
-- Includes dependencies, but not transitive dependencies.
typeNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef S.TextReference]
typeNamesWithinNamespace :: BranchHashId
-> PathSegments -> Transaction [NamedRef TextReference]
typeNamesWithinNamespace BranchHashId
bhId PathSegments
namespace =
  Sql -> Transaction [NamedRef TextReference]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index
      FROM scoped_type_name_lookup
      WHERE
        root_branch_hash_id = :bhId
        AND namespace GLOB :namespaceGlob

      UNION ALL

      SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash, reference_component_index
      FROM name_lookup_mounts mount
        INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
      WHERE
        mount.parent_root_branch_hash_id = :bhId
        -- We have a pre-condition that the namespace must not be within any of the mounts,
        -- so this is sufficient to determine whether the entire sub-index is within the
        -- required namespace prefix.
        AND mount.mount_path GLOB :namespaceGlob
    |]
  where
    namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespace

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of term names within a given namespace which have the given suffix.
termNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)]
termNamesBySuffix :: BranchHashId
-> PathSegments
-> ReversedName
-> Transaction [NamedRef (TextReferent, Maybe ConstructorType)]
termNamesBySuffix BranchHashId
bhId PathSegments
namespaceRoot ReversedName
suffix = do
  DebugFlag
-> [Char] -> (PathSegments, ReversedName) -> Transaction ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> [Char] -> a -> m ()
Debug.debugM DebugFlag
Debug.Server [Char]
"termNamesBySuffix" (PathSegments
namespaceRoot, ReversedName
suffix)
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot
  let lastSegment :: Text
lastSegment = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty Text -> Text)
-> (ReversedName -> NonEmpty Text) -> ReversedName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @(NonEmpty Text) (ReversedName -> Text) -> ReversedName -> Text
forall a b. (a -> b) -> a -> b
$ ReversedName
suffix
  let reversedNameGlob :: Text
reversedNameGlob = ReversedName -> Text
toSuffixGlob ReversedName
suffix
  [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
    -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
    -- GLOB, but this helps improve query performance.
    -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will
    -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for
    -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of
    -- names which couldn't possibly match before we then manually filter the remaining names
    -- using the `reversed_name` glob which can't be optimized with an index.
    Sql
-> Transaction
     [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM scoped_term_name_lookup
        WHERE root_branch_hash_id = :bhId
              AND last_name_segment IS :lastSegment
              AND namespace GLOB :namespaceGlob
              AND reversed_name GLOB :reversedNameGlob
        UNION ALL
        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM name_lookup_mounts mount
          INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE mount.parent_root_branch_hash_id = :bhId
              AND mount.mount_path GLOB :namespaceGlob
              AND last_name_segment IS :lastSegment
              AND reversed_name GLOB :reversedNameGlob
      |]
  pure (((TextReferent :. Only (Maybe ConstructorType))
 -> (TextReferent, Maybe ConstructorType))
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
forall a b. (a -> b) -> NamedRef a -> NamedRef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TextReferent :. Only (Maybe ConstructorType))
-> (TextReferent, Maybe ConstructorType)
forall {a} {b}. (a :. Only b) -> (a, b)
unRow (NamedRef (TextReferent :. Only (Maybe ConstructorType))
 -> NamedRef (TextReferent, Maybe ConstructorType))
-> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
-> [NamedRef (TextReferent, Maybe ConstructorType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results)
  where
    unRow :: (a :. Only b) -> (a, b)
unRow (a
a :. Only b
b) = (a
a, b
b)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of type names within a given namespace which have the given suffix.
typeNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef S.TextReference]
typeNamesBySuffix :: BranchHashId
-> PathSegments
-> ReversedName
-> Transaction [NamedRef TextReference]
typeNamesBySuffix BranchHashId
bhId PathSegments
namespaceRoot ReversedName
suffix = do
  DebugFlag
-> [Char] -> (PathSegments, ReversedName) -> Transaction ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> [Char] -> a -> m ()
Debug.debugM DebugFlag
Debug.Server [Char]
"typeNamesBySuffix" (PathSegments
namespaceRoot, ReversedName
suffix)
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot
  let lastNameSegment :: Text
lastNameSegment = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty Text -> Text)
-> (ReversedName -> NonEmpty Text) -> ReversedName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @(NonEmpty Text) (ReversedName -> Text) -> ReversedName -> Text
forall a b. (a -> b) -> a -> b
$ ReversedName
suffix
  let reversedNameGlob :: Text
reversedNameGlob = ReversedName -> Text
toSuffixGlob ReversedName
suffix
  -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
  -- GLOB, but this helps improve query performance.
  -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will
  -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for
  -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of
  -- names which couldn't possibly match before we then manually filter the remaining names
  -- using the `reversed_name` glob which can't be optimized with an index.
  Sql -> Transaction [NamedRef TextReference]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index
      FROM scoped_type_name_lookup
      WHERE     root_branch_hash_id = :bhId
            AND last_name_segment IS :lastNameSegment
            AND namespace GLOB :namespaceGlob
            AND reversed_name GLOB :reversedNameGlob
      UNION ALL
      SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash, reference_component_index
      FROM name_lookup_mounts mount
        INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
      WHERE mount.parent_root_branch_hash_id = :bhId
            AND mount.mount_path GLOB :namespaceGlob
            AND last_name_segment IS :lastNameSegment
            AND reversed_name GLOB :reversedNameGlob
    |]

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the set of refs for an exact name.
-- This will only return results which are within the name lookup for the provided branch hash
-- id. It's the caller's job to select the correct name lookup for your exact name.
--
-- See termRefsForExactName in U.Codebase.Sqlite.Operations
termRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)]
termRefsForExactName :: BranchHashId
-> ReversedName
-> Transaction [NamedRef (TextReferent, Maybe ConstructorType)]
termRefsForExactName BranchHashId
bhId ReversedName
reversedSegments = do
  let reversedName :: Text
reversedName = ReversedName -> Text
toReversedName ReversedName
reversedSegments
  [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
    Sql
-> Transaction
     [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM scoped_term_name_lookup
        WHERE root_branch_hash_id = :bhId
              AND reversed_name = :reversedName
      |]
  pure (((TextReferent :. Only (Maybe ConstructorType))
 -> (TextReferent, Maybe ConstructorType))
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
forall a b. (a -> b) -> NamedRef a -> NamedRef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TextReferent :. Only (Maybe ConstructorType))
-> (TextReferent, Maybe ConstructorType)
forall {a} {b}. (a :. Only b) -> (a, b)
unRow (NamedRef (TextReferent :. Only (Maybe ConstructorType))
 -> NamedRef (TextReferent, Maybe ConstructorType))
-> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
-> [NamedRef (TextReferent, Maybe ConstructorType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
results)
  where
    unRow :: (a :. Only b) -> (a, b)
unRow (a
a :. Only b
b) = (a
a, b
b)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the set of refs for an exact name.
-- This will only return results which are within the name lookup for the provided branch hash
-- id. It's the caller's job to select the correct name lookup for your exact name.
--
-- See termRefsForExactName in U.Codebase.Sqlite.Operations
typeRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef S.TextReference]
typeRefsForExactName :: BranchHashId
-> ReversedName -> Transaction [NamedRef TextReference]
typeRefsForExactName BranchHashId
bhId ReversedName
reversedSegments = do
  let reversedName :: Text
reversedName = ReversedName -> Text
toReversedName ReversedName
reversedSegments
  Sql -> Transaction [NamedRef TextReference]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index
      FROM scoped_type_name_lookup
      WHERE root_branch_hash_id = :bhId
            AND reversed_name = :reversedName
    |]

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of term names for a given Referent within a given namespace.
-- Considers one level of dependencies, but not transitive dependencies.
termNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReferent -> Maybe ReversedName -> Transaction [ReversedName]
termNamesForRefWithinNamespace :: BranchHashId
-> PathSegments
-> TextReferent
-> Maybe ReversedName
-> Transaction [ReversedName]
termNamesForRefWithinNamespace BranchHashId
bhId PathSegments
namespaceRoot TextReferent
ref Maybe ReversedName
maySuffix = do
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot
  let suffixGlob :: Text
suffixGlob = case Maybe ReversedName
maySuffix of
        Just ReversedName
suffix -> ReversedName -> Text
toSuffixGlob ReversedName
suffix
        Maybe ReversedName
Nothing -> Text
"*"
  [ReversedName]
directNames <- Sql
-> ([Text] -> Either EmptyName [ReversedName])
-> Transaction [ReversedName]
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> ([a] -> Either e r) -> Transaction r
queryListColCheck
    [sql|
        SELECT reversed_name FROM scoped_term_name_lookup
        WHERE root_branch_hash_id = :bhId
              AND referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @
              AND namespace GLOB :namespaceGlob
              AND reversed_name GLOB :suffixGlob
        UNION ALL
        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name
        FROM name_lookup_mounts mount
          INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE mount.parent_root_branch_hash_id = :bhId
              AND mount.mount_path GLOB :namespaceGlob
              AND referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @
              AND reversed_name GLOB :suffixGlob
        |]
    \[Text]
reversedNames -> [Text]
-> (Text -> Either EmptyName ReversedName)
-> Either EmptyName [ReversedName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Text]
reversedNames HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments
  -- If we don't find a name in the name lookup, expand the search to recursively include transitive deps
  -- and just return the first one we find.
  if [ReversedName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ReversedName]
directNames
    then do
      Maybe ReversedName -> [ReversedName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (Maybe ReversedName -> [ReversedName])
-> Transaction (Maybe ReversedName) -> Transaction [ReversedName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sql
-> (Text -> Either EmptyName ReversedName)
-> Transaction (Maybe ReversedName)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck
          [sql|
        $transitive_dependency_mounts
        SELECT (reversed_name || reversed_mount_path) AS reversed_name
          FROM transitive_dependency_mounts
            INNER JOIN scoped_term_name_lookup
            ON scoped_term_name_lookup.root_branch_hash_id = transitive_dependency_mounts.root_branch_hash_id
        WHERE referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @
              AND reversed_name GLOB :suffixGlob
        LIMIT 1
      |]
          (\Text
reversedName -> HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments Text
reversedName)
    else [ReversedName] -> Transaction [ReversedName]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ReversedName]
directNames
  where
    transitive_dependency_mounts :: Sql
transitive_dependency_mounts = BranchHashId -> Sql
transitiveDependenciesSql BranchHashId
bhId

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Get the list of type names for a given Reference within a given namespace.
-- Considers one level of dependencies, but not transitive dependencies.
typeNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReference -> Maybe ReversedName -> Transaction [ReversedName]
typeNamesForRefWithinNamespace :: BranchHashId
-> PathSegments
-> TextReference
-> Maybe ReversedName
-> Transaction [ReversedName]
typeNamesForRefWithinNamespace BranchHashId
bhId PathSegments
namespaceRoot TextReference
ref Maybe ReversedName
maySuffix = do
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot
  let suffixGlob :: Text
suffixGlob = case Maybe ReversedName
maySuffix of
        Just ReversedName
suffix -> ReversedName -> Text
toSuffixGlob ReversedName
suffix
        Maybe ReversedName
Nothing -> Text
"*"
  [ReversedName]
directNames <- Sql
-> ([Text] -> Either EmptyName [ReversedName])
-> Transaction [ReversedName]
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> ([a] -> Either e r) -> Transaction r
queryListColCheck
    [sql|
        SELECT reversed_name FROM scoped_type_name_lookup
        WHERE root_branch_hash_id = :bhId
              AND reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @
              AND namespace GLOB :namespaceGlob
              AND reversed_name GLOB :suffixGlob
        UNION ALL
        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name
        FROM name_lookup_mounts mount
          INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE mount.parent_root_branch_hash_id = :bhId
              AND mount.mount_path GLOB :namespaceGlob
              AND reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @
              AND reversed_name GLOB :suffixGlob
        |]
    \[Text]
reversedNames -> [Text]
-> (Text -> Either EmptyName ReversedName)
-> Either EmptyName [ReversedName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Text]
reversedNames HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments
  -- If we don't find a name in the name lookup, expand the search to recursively include transitive deps
  -- and just return the first one we find.
  if [ReversedName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ReversedName]
directNames
    then
      Maybe ReversedName -> [ReversedName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (Maybe ReversedName -> [ReversedName])
-> Transaction (Maybe ReversedName) -> Transaction [ReversedName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sql
-> (Text -> Either EmptyName ReversedName)
-> Transaction (Maybe ReversedName)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck
          [sql|
        $transitive_dependency_mounts
        SELECT (reversed_name || reversed_mount_path) AS reversed_name
          FROM transitive_dependency_mounts
            INNER JOIN scoped_type_name_lookup
            ON scoped_type_name_lookup.root_branch_hash_id = transitive_dependency_mounts.root_branch_hash_id
        WHERE reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @
              AND reversed_name GLOB :suffixGlob
        LIMIT 1
          |]
          (\Text
reversedName -> HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments Text
reversedName)
    else [ReversedName] -> Transaction [ReversedName]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ReversedName]
directNames
  where
    transitive_dependency_mounts :: Sql
transitive_dependency_mounts = BranchHashId -> Sql
transitiveDependenciesSql BranchHashId
bhId

-- | Brings into scope the transitive_dependency_mounts CTE table, which contains all transitive deps of the given root, but does NOT include the direct dependencies.
-- @transitive_dependency_mounts(root_branch_hash_id, reversed_mount_path)@
-- Where @reversed_mount_path@ is the reversed path from the provided root to the mounted
-- dependency's root.
transitiveDependenciesSql :: BranchHashId -> Sql
transitiveDependenciesSql :: BranchHashId -> Sql
transitiveDependenciesSql BranchHashId
rootBranchHashId =
  [sql|
        -- Recursive table containing all transitive deps
        WITH RECURSIVE
          transitive_dependency_mounts(root_branch_hash_id, reversed_mount_path) AS (
            -- We've already searched direct deps above, so start with children of direct deps
            SELECT transitive.mounted_root_branch_hash_id, transitive.reversed_mount_path || direct.reversed_mount_path
            FROM name_lookup_mounts direct
                 JOIN name_lookup_mounts transitive on direct.mounted_root_branch_hash_id = transitive.parent_root_branch_hash_id
            WHERE direct.parent_root_branch_hash_id = :rootBranchHashId
            UNION ALL
            SELECT mount.mounted_root_branch_hash_id, mount.reversed_mount_path || rec.reversed_mount_path
            FROM name_lookup_mounts mount
              INNER JOIN transitive_dependency_mounts rec ON mount.parent_root_branch_hash_id = rec.root_branch_hash_id
          )
          |]

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Searches all dependencies transitively looking for the provided referent.
-- Prefer 'termNamesForRefWithinNamespace' in most cases.
-- This is slower and only necessary when resolving the name of references when you don't know which
-- dependency it may exist in.
--
-- Searching transitive dependencies is exponential so we want to replace this with a more
-- efficient approach as soon as possible.
--
-- Note: this returns the first name it finds by searching in order of:
-- Names in the current namespace, then names in the current namespace's dependencies, then
-- through the current namespace's dependencies' dependencies, etc.
recursiveTermNameSearch :: BranchHashId -> S.TextReferent -> Transaction (Maybe ReversedName)
recursiveTermNameSearch :: BranchHashId -> TextReferent -> Transaction (Maybe ReversedName)
recursiveTermNameSearch BranchHashId
bhId TextReferent
ref = do
  Sql
-> (Text -> Either EmptyName ReversedName)
-> Transaction (Maybe ReversedName)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck
    [sql|
        -- Recursive table containing all transitive deps
        WITH RECURSIVE
          all_in_scope_roots(root_branch_hash_id, reversed_mount_path) AS (
            -- Include the primary root
            SELECT :bhId, ""
            UNION ALL
            SELECT mount.mounted_root_branch_hash_id, mount.reversed_mount_path || rec.reversed_mount_path
            FROM name_lookup_mounts mount
              INNER JOIN all_in_scope_roots rec ON mount.parent_root_branch_hash_id = rec.root_branch_hash_id
          )
        SELECT (reversed_name || reversed_mount_path) AS reversed_name
          FROM all_in_scope_roots
            INNER JOIN scoped_term_name_lookup
            ON scoped_term_name_lookup.root_branch_hash_id = all_in_scope_roots.root_branch_hash_id
        WHERE referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @
        LIMIT 1
        |]
    (\Text
reversedName -> HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments Text
reversedName)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- Searches all dependencies transitively looking for the provided referent.
-- Prefer 'typeNamesForRefWithinNamespace' in most cases.
-- This is slower and only necessary when resolving the name of references when you don't know which
-- dependency it may exist in.
--
-- Searching transitive dependencies is exponential so we want to replace this with a more
-- efficient approach as soon as possible.
--
-- Note: this returns the first name it finds by searching in order of:
-- Names in the current namespace, then names in the current namespace's dependencies, then
-- through the current namespace's dependencies' dependencies, etc.
recursiveTypeNameSearch :: BranchHashId -> S.TextReference -> Transaction (Maybe ReversedName)
recursiveTypeNameSearch :: BranchHashId -> TextReference -> Transaction (Maybe ReversedName)
recursiveTypeNameSearch BranchHashId
bhId TextReference
ref = do
  Sql
-> (Text -> Either EmptyName ReversedName)
-> Transaction (Maybe ReversedName)
forall a e r.
(FromField a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction (Maybe r)
queryMaybeColCheck
    [sql|
        -- Recursive table containing all transitive deps
        WITH RECURSIVE
          all_in_scope_roots(root_branch_hash_id, reversed_mount_path) AS (
            -- Include the primary root
            SELECT :bhId, ""
            UNION ALL
            SELECT mount.mounted_root_branch_hash_id, mount.reversed_mount_path || rec.reversed_mount_path
            FROM name_lookup_mounts mount
              INNER JOIN all_in_scope_roots rec ON mount.parent_root_branch_hash_id = rec.root_branch_hash_id
          )
        SELECT (reversed_name || reversed_mount_path) AS reversed_name
          FROM all_in_scope_roots
            INNER JOIN scoped_type_name_lookup
            ON scoped_type_name_lookup.root_branch_hash_id = all_in_scope_roots.root_branch_hash_id
        WHERE reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @
        LIMIT 1
        |]
    (\Text
reversedName -> HasCallStack => Text -> Either EmptyName ReversedName
Text -> Either EmptyName ReversedName
reversedNameToReversedSegments Text
reversedName)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- The goal of this query is to search the codebase for the single name which has a different
-- hash from the provided name, but shares longest matching suffix for for that name.
--
-- Including this name in the pretty-printer object causes it to suffixify the name so that it
-- is unambiguous from other names in scope.
--
-- Sqlite doesn't provide enough functionality to do this query in a single query, so we do
-- it iteratively, querying for longer and longer suffixes we no longer find matches.
-- Then we return the name with longest matching suffix.
--
-- This is still relatively efficient because we can use an index and LIMIT 1 to make each
-- individual query fast, and in the common case we'll only need two or three queries to find
-- the longest matching suffix.
--
-- Considers one level of dependencies, but not transitive dependencies.
longestMatchingTermNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReferent -> Transaction (Maybe (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)))
longestMatchingTermNameForSuffixification :: BranchHashId
-> PathSegments
-> NamedRef TextReferent
-> Transaction
     (Maybe (NamedRef (TextReferent, Maybe ConstructorType)))
longestMatchingTermNameForSuffixification BranchHashId
bhId PathSegments
namespaceRoot (NamedRef.NamedRef {$sel:reversedSegments:NamedRef :: forall ref. NamedRef ref -> ReversedName
reversedSegments = revSuffix :: ReversedName
revSuffix@(ReversedName (Text
lastSegment NonEmpty.:| [Text]
_)), TextReferent
ref :: TextReferent
$sel:ref:NamedRef :: forall ref. NamedRef ref -> ref
ref}) = do
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".*"
  let loop :: [Text] -> MaybeT Transaction (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))
      loop :: [Text]
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
loop [] = MaybeT Transaction (NamedRef (TextReferent, Maybe ConstructorType))
forall a. MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a
empty
      loop (Text
suffGlob : [Text]
rest) = do
        Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType)))
result :: Maybe (NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))) <-
          Transaction
  (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
-> MaybeT
     Transaction
     (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
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
   (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
 -> MaybeT
      Transaction
      (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType)))))
-> Transaction
     (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
-> MaybeT
     Transaction
     (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
forall a b. (a -> b) -> a -> b
$
            Sql
-> Transaction
     (Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType))))
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
              -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
              -- GLOB, but this helps improve query performance.
              -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will
              -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for
              -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of
              -- names which couldn't possibly match before we then manually filter the remaining names
              -- using the `reversed_name` glob which can't be optimized with an index.
              [sql|
              SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM scoped_term_name_lookup
              WHERE root_branch_hash_id = :bhId
                    AND last_name_segment IS :lastSegment
                    AND namespace GLOB :namespaceGlob
                    AND reversed_name GLOB :suffGlob
                    -- We don't need to consider names for the same definition when suffixifying, so
                    -- we filter those out. Importantly this also avoids matching the name we're trying to suffixify.
                    AND NOT (referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @)
              UNION ALL
              SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, names.referent_builtin, names.referent_component_hash, names.referent_component_index, names.referent_constructor_index, names.referent_constructor_type
              FROM name_lookup_mounts mount
                INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
              WHERE mount.parent_root_branch_hash_id = :bhId
                    AND mount.mount_path GLOB :namespaceGlob
                    AND last_name_segment IS :lastSegment
                    AND reversed_name GLOB :suffGlob
                    -- We don't need to consider names for the same definition when suffixifying, so
                    -- we filter those out. Importantly this also avoids matching the name we're trying to suffixify.
                    AND NOT (names.referent_builtin IS @ref AND names.referent_component_hash IS @ AND names.referent_component_index IS @ AND names.referent_constructor_index IS @)
              LIMIT 1
            |]
        case Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType)))
result of
          Just NamedRef (TextReferent :. Only (Maybe ConstructorType))
namedRef ->
            -- We want to find matches for the _longest_ possible suffix, so we keep going until we
            -- don't find any more matches.
            NamedRef (TextReferent, Maybe ConstructorType)
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
forall a. a -> MaybeT Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TextReferent :. Only (Maybe ConstructorType))
-> (TextReferent, Maybe ConstructorType)
forall {a} {b}. (a :. Only b) -> (a, b)
unRow ((TextReferent :. Only (Maybe ConstructorType))
 -> (TextReferent, Maybe ConstructorType))
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedRef (TextReferent :. Only (Maybe ConstructorType))
namedRef) MaybeT Transaction (NamedRef (TextReferent, Maybe ConstructorType))
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
forall a.
MaybeT Transaction a
-> MaybeT Transaction a -> MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text]
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
loop [Text]
rest
          Maybe (NamedRef (TextReferent :. Only (Maybe ConstructorType)))
Nothing ->
            -- If we don't find a match for a suffix, there's no way we could match on an even
            -- longer suffix, so we bail.
            MaybeT Transaction (NamedRef (TextReferent, Maybe ConstructorType))
forall a. MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a
empty
  let suffixes :: [Text]
suffixes =
        ReversedName
revSuffix
          ReversedName -> (ReversedName -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& forall target source. From source target => source -> target
into @[Text]
          [Text] -> ([Text] -> [[Text]]) -> [[Text]]
forall a b. a -> (a -> b) -> b
& [Text] -> [[Text]]
forall a. [a] -> [[a]]
List.inits
          [[Text]] -> ([[Text]] -> [NonEmpty Text]) -> [NonEmpty Text]
forall a b. a -> (a -> b) -> b
& ([Text] -> Maybe (NonEmpty Text)) -> [[Text]] -> [NonEmpty Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty
          [NonEmpty Text] -> ([NonEmpty Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (NonEmpty Text -> Text) -> [NonEmpty Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ReversedName -> Text
toSuffixGlob (ReversedName -> Text)
-> (NonEmpty Text -> ReversedName) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @ReversedName)
  MaybeT Transaction (NamedRef (TextReferent, Maybe ConstructorType))
-> Transaction
     (Maybe (NamedRef (TextReferent, Maybe ConstructorType)))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   Transaction (NamedRef (TextReferent, Maybe ConstructorType))
 -> Transaction
      (Maybe (NamedRef (TextReferent, Maybe ConstructorType))))
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
-> Transaction
     (Maybe (NamedRef (TextReferent, Maybe ConstructorType)))
forall a b. (a -> b) -> a -> b
$ [Text]
-> MaybeT
     Transaction (NamedRef (TextReferent, Maybe ConstructorType))
loop [Text]
suffixes
  where
    unRow :: (a :. Only b) -> (a, b)
unRow (a
a :. Only b
b) = (a
a, b
b)

-- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
-- is only true on Share.
--
-- The goal of this query is to search the codebase for the single name which has a different
-- hash from the provided name, but shares longest matching suffix for for that name.
--
-- Including this name in the pretty-printer object causes it to suffixify the name so that it
-- is unambiguous from other names in scope.
--
-- Sqlite doesn't provide enough functionality to do this query in a single query, so we do
-- it iteratively, querying for longer and longer suffixes we no longer find matches.
-- Then we return the name with longest matching suffix.
--
-- This is still relatively efficient because we can use an index and LIMIT 1 to make each
-- individual query fast, and in the common case we'll only need two or three queries to find
-- the longest matching suffix.
--
-- Considers one level of dependencies, but not transitive dependencies.
longestMatchingTypeNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReference -> Transaction (Maybe (NamedRef S.TextReference))
longestMatchingTypeNameForSuffixification :: BranchHashId
-> PathSegments
-> NamedRef TextReference
-> Transaction (Maybe (NamedRef TextReference))
longestMatchingTypeNameForSuffixification BranchHashId
bhId PathSegments
namespaceRoot (NamedRef.NamedRef {$sel:reversedSegments:NamedRef :: forall ref. NamedRef ref -> ReversedName
reversedSegments = revSuffix :: ReversedName
revSuffix@(ReversedName (Text
lastSegment NonEmpty.:| [Text]
_)), TextReference
$sel:ref:NamedRef :: forall ref. NamedRef ref -> ref
ref :: TextReference
ref}) = do
  let namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespaceRoot Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".*"
  let loop :: [Text] -> MaybeT Transaction (NamedRef S.TextReference)
      loop :: [Text] -> MaybeT Transaction (NamedRef TextReference)
loop [] = MaybeT Transaction (NamedRef TextReference)
forall a. MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a
empty
      loop (Text
suffGlob : [Text]
rest) = do
        Maybe (NamedRef TextReference)
result :: Maybe (NamedRef (S.TextReference)) <-
          Transaction (Maybe (NamedRef TextReference))
-> MaybeT Transaction (Maybe (NamedRef TextReference))
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 (Maybe (NamedRef TextReference))
 -> MaybeT Transaction (Maybe (NamedRef TextReference)))
-> Transaction (Maybe (NamedRef TextReference))
-> MaybeT Transaction (Maybe (NamedRef TextReference))
forall a b. (a -> b) -> a -> b
$
            Sql -> Transaction (Maybe (NamedRef TextReference))
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
              -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
              -- GLOB, but this helps improve query performance.
              -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will
              -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for
              -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of
              -- names which couldn't possibly match before we then manually filter the remaining names
              -- using the `reversed_name` glob which can't be optimized with an index.
              [sql|
              SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM scoped_type_name_lookup
              WHERE root_branch_hash_id = :bhId
                    AND last_name_segment IS :lastSegment
                    AND namespace GLOB :namespaceGlob
                    AND reversed_name GLOB :suffGlob
                    -- We don't need to consider names for the same definition when suffixifying, so
                    -- we filter those out. Importantly this also avoids matching the name we're trying to suffixify.
                    AND NOT (reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @)
              UNION ALL
              SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, names.reference_builtin, names.reference_component_hash, names.reference_component_index
              FROM name_lookup_mounts mount
                INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
              WHERE mount.parent_root_branch_hash_id = :bhId
                    AND mount.mount_path GLOB :namespaceGlob
                    AND last_name_segment IS :lastSegment
                    AND reversed_name GLOB :suffGlob
                    -- We don't need to consider names for the same definition when suffixifying, so
                    -- we filter those out. Importantly this also avoids matching the name we're trying to suffixify.
                    AND NOT (names.reference_builtin IS @ref AND names.reference_component_hash IS @ AND names.reference_component_index IS @)
              LIMIT 1
            |]
        case Maybe (NamedRef TextReference)
result of
          Just NamedRef TextReference
namedRef ->
            -- We want to find matches for the _longest_ possible suffix, so we keep going until we
            -- don't find any more matches.
            NamedRef TextReference
-> MaybeT Transaction (NamedRef TextReference)
forall a. a -> MaybeT Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedRef TextReference
namedRef MaybeT Transaction (NamedRef TextReference)
-> MaybeT Transaction (NamedRef TextReference)
-> MaybeT Transaction (NamedRef TextReference)
forall a.
MaybeT Transaction a
-> MaybeT Transaction a -> MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> MaybeT Transaction (NamedRef TextReference)
loop [Text]
rest
          Maybe (NamedRef TextReference)
Nothing ->
            -- If we don't find a match for a suffix, there's no way we could match on an even
            -- longer suffix, so we bail.
            MaybeT Transaction (NamedRef TextReference)
forall a. MaybeT Transaction a
forall (f :: * -> *) a. Alternative f => f a
empty
  let suffixes :: [Text]
suffixes =
        ReversedName
revSuffix
          ReversedName -> (ReversedName -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& forall target source. From source target => source -> target
into @[Text]
          [Text] -> ([Text] -> [[Text]]) -> [[Text]]
forall a b. a -> (a -> b) -> b
& [Text] -> [[Text]]
forall a. [a] -> [[a]]
List.inits
          [[Text]] -> ([[Text]] -> [NonEmpty Text]) -> [NonEmpty Text]
forall a b. a -> (a -> b) -> b
& ([Text] -> Maybe (NonEmpty Text)) -> [[Text]] -> [NonEmpty Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty
          [NonEmpty Text] -> ([NonEmpty Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (NonEmpty Text -> Text) -> [NonEmpty Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ReversedName -> Text
toSuffixGlob (ReversedName -> Text)
-> (NonEmpty Text -> ReversedName) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @ReversedName)
  MaybeT Transaction (NamedRef TextReference)
-> Transaction (Maybe (NamedRef TextReference))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Transaction (NamedRef TextReference)
 -> Transaction (Maybe (NamedRef TextReference)))
-> MaybeT Transaction (NamedRef TextReference)
-> Transaction (Maybe (NamedRef TextReference))
forall a b. (a -> b) -> a -> b
$ [Text] -> MaybeT Transaction (NamedRef TextReference)
loop [Text]
suffixes

-- | Associate name lookup indexes for dependencies to specific mounting points within another name lookup.
associateNameLookupMounts :: BranchHashId -> [(PathSegments, BranchHashId)] -> Transaction ()
associateNameLookupMounts :: BranchHashId -> [(PathSegments, BranchHashId)] -> Transaction ()
associateNameLookupMounts BranchHashId
rootBranchHashId [(PathSegments, BranchHashId)]
mounts = do
  [(PathSegments, BranchHashId)]
-> ((PathSegments, BranchHashId) -> Transaction ())
-> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(PathSegments, BranchHashId)]
mounts \(PathSegments
mountPath, BranchHashId
mountedBranchHashId) -> do
    let mountPathText :: Text
mountPathText = PathSegments -> Text
pathSegmentsToText PathSegments
mountPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        reversedMountPathText :: Text
reversedMountPathText = PathSegments -> Text
pathSegmentsToText ([Text] -> PathSegments
PathSegments ([Text] -> PathSegments)
-> (PathSegments -> [Text]) -> PathSegments -> PathSegments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> (PathSegments -> [Text]) -> PathSegments -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegments -> [Text]
forall a b. Coercible a b => a -> b
coerce (PathSegments -> PathSegments) -> PathSegments -> PathSegments
forall a b. (a -> b) -> a -> b
$ PathSegments
mountPath) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
          INSERT INTO name_lookup_mounts (parent_root_branch_hash_id, mounted_root_branch_hash_id, mount_path, reversed_mount_path)
          VALUES (:rootBranchHashId, :mountedBranchHashId, :mountPathText, :reversedMountPathText)
        |]

-- | Fetch the name lookup mounts for a given name lookup index.
listNameLookupMounts :: BranchHashId -> Transaction [(PathSegments, BranchHashId)]
listNameLookupMounts :: BranchHashId -> Transaction [(PathSegments, BranchHashId)]
listNameLookupMounts BranchHashId
rootBranchHashId =
  do
    Sql -> Transaction [(Text, BranchHashId)]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT mount_path, mounted_root_branch_hash_id
        FROM name_lookup_mounts
        WHERE parent_root_branch_hash_id = :rootBranchHashId
      |]
    Transaction [(Text, BranchHashId)]
-> ([(Text, BranchHashId)] -> [(PathSegments, BranchHashId)])
-> Transaction [(PathSegments, BranchHashId)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Text, BranchHashId) -> (PathSegments, BranchHashId))
-> [(Text, BranchHashId)] -> [(PathSegments, BranchHashId)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      \(Text
mountPathText, BranchHashId
mountedRootBranchHashId) ->
        let mountPath :: PathSegments
mountPath = Text -> PathSegments
textToPathSegments (HasCallStack => Text -> Text
Text -> Text
Text.init Text
mountPathText)
         in (PathSegments
mountPath, BranchHashId
mountedRootBranchHashId)

-- | @before x y@ returns whether or not @x@ occurred before @y@, i.e. @x@ is an ancestor of @y@.
before :: CausalHashId -> CausalHashId -> Transaction Bool
before :: CausalHashId -> CausalHashId -> Transaction Bool
before CausalHashId
x CausalHashId
y =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        $selectAncestorsOfY
        WHERE ancestor.id = :x
      )
    |]
  where
    selectAncestorsOfY :: Sql
selectAncestorsOfY = CausalHashId -> Sql
ancestorSql CausalHashId
y

lca :: CausalHashId -> CausalHashId -> Transaction (Maybe CausalHashId)
lca :: CausalHashId -> CausalHashId -> Transaction (Maybe CausalHashId)
lca CausalHashId
alice CausalHashId
bob =
  Sql -> Transaction (Maybe CausalHashId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol
    [sql|
      WITH RECURSIVE history_one (causal_id) AS (
        SELECT :alice
        UNION
        SELECT causal_parent.parent_id
        FROM history_one
          JOIN causal_parent ON history_one.causal_id = causal_parent.causal_id
      ),
      history_two (causal_id) AS (
        SELECT :bob
        UNION
        SELECT causal_parent.parent_id
        FROM history_two
          JOIN causal_parent ON history_two.causal_id = causal_parent.causal_id
      ),
      common_ancestors (causal_id) AS (
        SELECT causal_id
        FROM history_one
        INTERSECT
        SELECT causal_id
        FROM history_two
        ORDER BY causal_id DESC
      )
      SELECT causal_id
      FROM common_ancestors
      WHERE NOT EXISTS (
        SELECT 1
        FROM causal_parent
        WHERE causal_parent.parent_id = common_ancestors.causal_id
          AND EXISTS (
            SELECT 1
            FROM common_ancestors c
            WHERE c.causal_id = causal_parent.causal_id
          )
      )
      LIMIT 1
    |]

ancestorSql :: CausalHashId -> Sql
ancestorSql :: CausalHashId -> Sql
ancestorSql CausalHashId
h =
  [sql|
    WITH RECURSIVE
      ancestor(id) AS (
        SELECT self_hash_id
          FROM causal
          WHERE self_hash_id = :h
        UNION
        SELECT parent_id
          FROM causal_parent
          JOIN ancestor ON ancestor.id = causal_id
      )
    SELECT * FROM ancestor
  |]

-- * share sync / temp entities

-- | Where an entity is stored.
data EntityLocation
  = -- | `object` / `causal`
    EntityInMainStorage
  | -- | `temp_entity`
    EntityInTempStorage
  deriving (EntityLocation -> EntityLocation -> Bool
(EntityLocation -> EntityLocation -> Bool)
-> (EntityLocation -> EntityLocation -> Bool) -> Eq EntityLocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EntityLocation -> EntityLocation -> Bool
== :: EntityLocation -> EntityLocation -> Bool
$c/= :: EntityLocation -> EntityLocation -> Bool
/= :: EntityLocation -> EntityLocation -> Bool
Eq, Int -> EntityLocation -> ShowS
[EntityLocation] -> ShowS
EntityLocation -> [Char]
(Int -> EntityLocation -> ShowS)
-> (EntityLocation -> [Char])
-> ([EntityLocation] -> ShowS)
-> Show EntityLocation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EntityLocation -> ShowS
showsPrec :: Int -> EntityLocation -> ShowS
$cshow :: EntityLocation -> [Char]
show :: EntityLocation -> [Char]
$cshowList :: [EntityLocation] -> ShowS
showList :: [EntityLocation] -> ShowS
Show, Eq EntityLocation
Eq EntityLocation =>
(EntityLocation -> EntityLocation -> Ordering)
-> (EntityLocation -> EntityLocation -> Bool)
-> (EntityLocation -> EntityLocation -> Bool)
-> (EntityLocation -> EntityLocation -> Bool)
-> (EntityLocation -> EntityLocation -> Bool)
-> (EntityLocation -> EntityLocation -> EntityLocation)
-> (EntityLocation -> EntityLocation -> EntityLocation)
-> Ord EntityLocation
EntityLocation -> EntityLocation -> Bool
EntityLocation -> EntityLocation -> Ordering
EntityLocation -> EntityLocation -> EntityLocation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EntityLocation -> EntityLocation -> Ordering
compare :: EntityLocation -> EntityLocation -> Ordering
$c< :: EntityLocation -> EntityLocation -> Bool
< :: EntityLocation -> EntityLocation -> Bool
$c<= :: EntityLocation -> EntityLocation -> Bool
<= :: EntityLocation -> EntityLocation -> Bool
$c> :: EntityLocation -> EntityLocation -> Bool
> :: EntityLocation -> EntityLocation -> Bool
$c>= :: EntityLocation -> EntityLocation -> Bool
>= :: EntityLocation -> EntityLocation -> Bool
$cmax :: EntityLocation -> EntityLocation -> EntityLocation
max :: EntityLocation -> EntityLocation -> EntityLocation
$cmin :: EntityLocation -> EntityLocation -> EntityLocation
min :: EntityLocation -> EntityLocation -> EntityLocation
Ord)

-- | Where is an entity stored?
entityLocation :: Hash32 -> Transaction (Maybe EntityLocation)
entityLocation :: Hash32 -> Transaction (Maybe EntityLocation)
entityLocation Hash32
hash =
  Hash32 -> Transaction Bool
entityExists Hash32
hash Transaction Bool
-> (Bool -> Transaction (Maybe EntityLocation))
-> Transaction (Maybe EntityLocation)
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 -> Maybe EntityLocation -> Transaction (Maybe EntityLocation)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EntityLocation -> Maybe EntityLocation
forall a. a -> Maybe a
Just EntityLocation
EntityInMainStorage)
    Bool
False -> do
      let theSql :: Sql
theSql = [sql| SELECT EXISTS (SELECT 1 FROM temp_entity WHERE hash = :hash) |]
      Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol Sql
theSql Transaction Bool
-> (Bool -> Maybe EntityLocation)
-> Transaction (Maybe EntityLocation)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Bool
True -> EntityLocation -> Maybe EntityLocation
forall a. a -> Maybe a
Just EntityLocation
EntityInTempStorage
        Bool
False -> Maybe EntityLocation
forall a. Maybe a
Nothing

-- | Does this entity already exist in the database, i.e. in the `object` or `causal` table?
entityExists :: Hash32 -> Transaction Bool
entityExists :: Hash32 -> Transaction Bool
entityExists Hash32
hash = do
  -- first get hashId if exists
  Hash32 -> Transaction (Maybe HashId)
loadHashId Hash32
hash 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
    -- then check if is causal hash or if object exists for hash id
    Just HashId
hashId -> HashId -> Transaction Bool
isCausalHash HashId
hashId Transaction Bool -> Transaction Bool -> Transaction Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ HashId -> Transaction Bool
isObjectHash HashId
hashId

-- | Checks whether the codebase contains the actual branch value for a given causal hash.
checkBranchExistsForCausalHash :: CausalHash -> Transaction Bool
checkBranchExistsForCausalHash :: CausalHash -> Transaction Bool
checkBranchExistsForCausalHash CausalHash
ch = do
  CausalHash -> Transaction (Maybe CausalHashId)
loadCausalHashIdByCausalHash CausalHash
ch Transaction (Maybe CausalHashId)
-> (Maybe CausalHashId -> 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 CausalHashId
Nothing -> Bool -> Transaction Bool
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just CausalHashId
chId ->
      Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
        [sql|
          SELECT EXISTS (
            SELECT 1
            FROM causal c JOIN object o ON c.value_hash_id = o.primary_hash_id
            WHERE c.self_hash_id = :chId
          )
        |]

-- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows.
--
-- Preconditions:
--   1. The entity does not already exist in "main" storage (`object` / `causal`)
--   2. The entity does not already exist in `temp_entity`.
insertTempEntity :: Hash32 -> TempEntity -> NEMap Hash32 Text -> Transaction ()
insertTempEntity :: Hash32 -> TempEntity -> NEMap Hash32 Text -> Transaction ()
insertTempEntity Hash32
entityHash TempEntity
entity NEMap Hash32 Text
missingDependencies = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO temp_entity (hash, blob, type_id)
      VALUES (:entityHash, :entityBlob, :entityType)
      ON CONFLICT DO NOTHING
    |]

  NonEmpty (Hash32, Text)
-> ((Hash32, Text) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (NEMap Hash32 Text -> NonEmpty (Hash32, Text)
forall k a. NEMap k a -> NonEmpty (k, a)
NEMap.toList NEMap Hash32 Text
missingDependencies) \(Hash32
depHash, Text
depHashJwt) ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO temp_entity_missing_dependency (dependent, dependency, dependencyJwt)
        VALUES (:entityHash, :depHash, :depHashJwt)
      |]
  where
    entityBlob :: ByteString
    entityBlob :: ByteString
entityBlob =
      Put -> ByteString
runPutS (TempEntity -> Put
forall (m :: * -> *). MonadPut m => TempEntity -> m ()
Serialization.putTempEntity TempEntity
entity)

    entityType :: TempEntityType
    entityType :: TempEntityType
entityType =
      TempEntity -> TempEntityType
forall text hash defn patch branchh branch causal.
SyncEntity' text hash defn patch branchh branch causal
-> TempEntityType
Entity.entityType TempEntity
entity

-- | Delete a row from the `temp_entity` table, if it exists.
deleteTempEntity :: Hash32 -> Transaction ()
deleteTempEntity :: Hash32 -> Transaction ()
deleteTempEntity Hash32
hash =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE
      FROM temp_entity
      WHERE hash = :hash
    |]

-- | Clears the `temp_entity` and `temp_entity_missing_dependency` tables.
-- The hashjwts stored in temp entity tables can sometimes go stale, so we clear them out.
-- This is safe because temp entities are generally considered ephemeral
-- except during an active pull.
clearTempEntityTables :: Transaction ()
clearTempEntityTables :: Transaction ()
clearTempEntityTables = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DELETE FROM temp_entity_missing_dependency |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute [sql| DELETE FROM temp_entity |]

-- | "Elaborate" a set of `temp_entity` hashes.
--
-- Given a set of `temp_entity` hashes, returns the (known) set of transitive dependencies that haven't already been
-- downloaded (i.e. aren't in the `temp_entity` table)
--
-- For example, if we have temp entities A and B, where A depends on B and B depends on C...
--
--   | temp_entity |   | temp_entity_missing_dependency |
--   |=============|   |================================|
--   | hash        |   | dependent    | dependency      |
--   |-------------|   |--------------|-----------------|
--   | A           |   | A            | B               |
--   | B           |   | B            | C               |
--
-- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive
-- dependencies {A,B,C} and subtract the set we already have, {A,B}).
elaborateHashes :: NonEmpty Hash32 -> Transaction [Text]
elaborateHashes :: NonEmpty Hash32 -> Transaction [Text]
elaborateHashes (forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @(NonEmpty (Only Hash32)) -> NonEmpty (Only Hash32)
hashes) =
  Sql -> Transaction [Text]
forall a. (FromField a, HasCallStack) => Sql -> Transaction [a]
queryListCol
    [sql|
      WITH RECURSIVE
        new_temp_entity_dependents (hash) AS (VALUES :hashes),
        elaborated_dependency (hash, hashJwt) AS (
          SELECT temd.dependency, temd.dependencyJwt
          FROM new_temp_entity_dependents AS new
            JOIN temp_entity_missing_dependency AS temd
              ON temd.dependent = new.hash

          UNION
          SELECT temd.dependency, temd.dependencyJwt
          FROM temp_entity_missing_dependency AS temd
            JOIN elaborated_dependency AS ed
              ON temd.dependent = ed.hash
        )
      SELECT hashJwt FROM elaborated_dependency
      WHERE NOT EXISTS (
        SELECT 1 FROM temp_entity
        WHERE temp_entity.hash = elaborated_dependency.hash
      )
    |]

moveTempEntityToMain ::
  HashHandle ->
  Hash32 ->
  Transaction ()
moveTempEntityToMain :: HashHandle -> Hash32 -> Transaction ()
moveTempEntityToMain HashHandle
hh Hash32
hash = do
  TempEntity
entity <- Hash32 -> Transaction TempEntity
expectTempEntity Hash32
hash
  Hash32 -> Transaction ()
deleteTempEntity Hash32
hash
  Either CausalHashId ObjectId
_ <- HashHandle
-> Hash32
-> TempEntity
-> Transaction (Either CausalHashId ObjectId)
saveTempEntityInMain HashHandle
hh Hash32
hash TempEntity
entity
  pure ()

-- | Save a temp entity in main storage.
--
-- Precondition: all of its dependencies are already in main storage.
saveTempEntityInMain :: HashHandle -> Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId)
saveTempEntityInMain :: HashHandle
-> Hash32
-> TempEntity
-> Transaction (Either CausalHashId ObjectId)
saveTempEntityInMain HashHandle
hh Hash32
hash TempEntity
entity = do
  SyncEntity
entity' <- TempEntity -> Transaction SyncEntity
tempToSyncEntity TempEntity
entity
  HashHandle
-> Hash32
-> SyncEntity
-> Transaction (Either CausalHashId ObjectId)
saveSyncEntity HashHandle
hh Hash32
hash SyncEntity
entity'

saveSyncEntity ::
  HashHandle ->
  Hash32 ->
  SyncEntity ->
  Transaction (Either CausalHashId ObjectId)
saveSyncEntity :: HashHandle
-> Hash32
-> SyncEntity
-> Transaction (Either CausalHashId ObjectId)
saveSyncEntity HashHandle
hh Hash32
hash SyncEntity
entity = do
  case SyncEntity
entity of
    Entity.TC SyncTermFormat' TextId ObjectId
stf -> do
      LocallyIndexedComponent
lic :: TermFormat.LocallyIndexedComponent <- do
        let TermFormat.SyncTerm SyncLocallyIndexedComponent' TextId ObjectId
x = SyncTermFormat' TextId ObjectId
stf
        (DecodeError -> Transaction LocallyIndexedComponent)
-> (LocallyIndexedComponent -> Transaction LocallyIndexedComponent)
-> Either DecodeError LocallyIndexedComponent
-> Transaction LocallyIndexedComponent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO LocallyIndexedComponent -> Transaction LocallyIndexedComponent
forall a. HasCallStack => IO a -> Transaction a
unsafeIO (IO LocallyIndexedComponent -> Transaction LocallyIndexedComponent)
-> (DecodeError -> IO LocallyIndexedComponent)
-> DecodeError
-> Transaction LocallyIndexedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> IO LocallyIndexedComponent
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO) LocallyIndexedComponent -> Transaction LocallyIndexedComponent
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError LocallyIndexedComponent
 -> Transaction LocallyIndexedComponent)
-> Either DecodeError LocallyIndexedComponent
-> Transaction LocallyIndexedComponent
forall a b. (a -> b) -> a -> b
$ SyncLocallyIndexedComponent' TextId ObjectId
-> Either DecodeError LocallyIndexedComponent
forall t d.
HasCallStack =>
SyncLocallyIndexedComponent' t d
-> Either DecodeError (LocallyIndexedComponent' t d)
unsyncTermComponent SyncLocallyIndexedComponent' TextId ObjectId
x

      [(Term Symbol, Type Symbol)]
tc :: [(C.Term Symbol, C.Term.Type Symbol)] <-
        ((LocalIds' TextId ObjectId, Term, Type)
 -> Transaction (Term Symbol, Type Symbol))
-> [(LocalIds' TextId ObjectId, Term, Type)]
-> Transaction [(Term Symbol, Type Symbol)]
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
          (\(LocalIds' TextId ObjectId
a, Term
b, Type
c) -> LocalIds' TextId ObjectId
-> Term -> Type -> Transaction (Term Symbol, Type Symbol)
s2cTermWithType LocalIds' TextId ObjectId
a Term
b Type
c)
          (Vector (LocalIds' TextId ObjectId, Term, Type)
-> [(LocalIds' TextId ObjectId, Term, Type)]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector (LocalIds' TextId ObjectId, Term, Type)
 -> [(LocalIds' TextId ObjectId, Term, Type)])
-> Vector (LocalIds' TextId ObjectId, Term, Type)
-> [(LocalIds' TextId ObjectId, Term, Type)]
forall a b. (a -> b) -> a -> b
$ LocallyIndexedComponent
-> Vector (LocalIds' TextId ObjectId, Term, Type)
forall t d.
LocallyIndexedComponent' t d -> Vector (LocalIds' t d, Term, Type)
TermFormat.unLocallyIndexedComponent LocallyIndexedComponent
lic)
      let bytes :: ByteString
bytes = Put -> ByteString
runPutS (SyncTermFormat' TextId ObjectId -> Put
forall (m :: * -> *).
MonadPut m =>
SyncTermFormat' TextId ObjectId -> m ()
Serialization.recomposeTermFormat SyncTermFormat' TextId ObjectId
stf)
      ObjectId
objId <- HashHandle
-> Maybe ByteString
-> Hash
-> [(Term Symbol, Type Symbol)]
-> Transaction ObjectId
saveTermComponent HashHandle
hh (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes) (Hash32 -> Hash
Hash32.toHash Hash32
hash) [(Term Symbol, Type Symbol)]
tc
      pure (ObjectId -> Either CausalHashId ObjectId
forall a b. b -> Either a b
Right ObjectId
objId)
    Entity.DC SyncDeclFormat' TextId ObjectId
sdf -> do
      LocallyIndexedComponent
lic :: S.Decl.LocallyIndexedComponent <- do
        let S.Decl.SyncDecl SyncLocallyIndexedComponent' TextId ObjectId
xs = SyncDeclFormat' TextId ObjectId
sdf
        (DecodeError -> Transaction LocallyIndexedComponent)
-> (LocallyIndexedComponent -> Transaction LocallyIndexedComponent)
-> Either DecodeError LocallyIndexedComponent
-> Transaction LocallyIndexedComponent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO LocallyIndexedComponent -> Transaction LocallyIndexedComponent
forall a. HasCallStack => IO a -> Transaction a
unsafeIO (IO LocallyIndexedComponent -> Transaction LocallyIndexedComponent)
-> (DecodeError -> IO LocallyIndexedComponent)
-> DecodeError
-> Transaction LocallyIndexedComponent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> IO LocallyIndexedComponent
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO) LocallyIndexedComponent -> Transaction LocallyIndexedComponent
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError LocallyIndexedComponent
 -> Transaction LocallyIndexedComponent)
-> Either DecodeError LocallyIndexedComponent
-> Transaction LocallyIndexedComponent
forall a b. (a -> b) -> a -> b
$ SyncLocallyIndexedComponent' TextId ObjectId
-> Either DecodeError LocallyIndexedComponent
forall t d.
SyncLocallyIndexedComponent' t d
-> Either DecodeError (LocallyIndexedComponent' t d)
unsyncDeclComponent SyncLocallyIndexedComponent' TextId ObjectId
xs

      [Decl Symbol]
dc :: [C.Decl.Decl Symbol] <-
        ((LocalIds' TextId ObjectId, Decl Symbol)
 -> Transaction (Decl Symbol))
-> [(LocalIds' TextId ObjectId, Decl Symbol)]
-> Transaction [Decl Symbol]
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
          (\(LocalIds' TextId ObjectId
localIds, Decl Symbol
decl) -> LocalIds' TextId ObjectId
-> Decl Symbol -> Transaction (Decl Symbol)
s2cDecl LocalIds' TextId ObjectId
localIds Decl Symbol
decl)
          (Vector (LocalIds' TextId ObjectId, Decl Symbol)
-> [(LocalIds' TextId ObjectId, Decl Symbol)]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector (LocalIds' TextId ObjectId, Decl Symbol)
 -> [(LocalIds' TextId ObjectId, Decl Symbol)])
-> Vector (LocalIds' TextId ObjectId, Decl Symbol)
-> [(LocalIds' TextId ObjectId, Decl Symbol)]
forall a b. (a -> b) -> a -> b
$ LocallyIndexedComponent
-> Vector (LocalIds' TextId ObjectId, Decl Symbol)
forall t d.
LocallyIndexedComponent' t d -> Vector (LocalIds' t d, Decl Symbol)
S.Decl.unLocallyIndexedComponent LocallyIndexedComponent
lic)

      let bytes :: ByteString
bytes = Put -> ByteString
runPutS (SyncDeclFormat' TextId ObjectId -> Put
forall (m :: * -> *).
MonadPut m =>
SyncDeclFormat' TextId ObjectId -> m ()
Serialization.recomposeDeclFormat SyncDeclFormat' TextId ObjectId
sdf)
      ObjectId
objId <- HashHandle
-> Maybe ByteString
-> Hash
-> [Decl Symbol]
-> Transaction ObjectId
saveDeclComponent HashHandle
hh (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes) (Hash32 -> Hash
Hash32.toHash Hash32
hash) [Decl Symbol]
dc

      pure (ObjectId -> Either CausalHashId ObjectId
forall a b. b -> Either a b
Right ObjectId
objId)
    Entity.N SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
sbf -> do
      HashId
hashId <- Hash32 -> Transaction HashId
saveHash Hash32
hash
      let bytes :: ByteString
bytes = Put -> ByteString
runPutS (SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> Put
forall (m :: * -> *).
MonadPut m =>
SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
-> m ()
Serialization.recomposeBranchFormat SyncBranchFormat'
  BranchObjectId
  TextId
  ObjectId
  PatchObjectId
  (BranchObjectId, CausalHashId)
sbf)
      ObjectId -> Either CausalHashId ObjectId
forall a b. b -> Either a b
Right (ObjectId -> Either CausalHashId ObjectId)
-> Transaction ObjectId
-> Transaction (Either CausalHashId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashHandle
-> HashId -> ObjectType -> ByteString -> Transaction ObjectId
saveObject HashHandle
hh HashId
hashId ObjectType
ObjectType.Namespace ByteString
bytes
    Entity.P SyncPatchFormat' PatchObjectId TextId HashId ObjectId
spf -> do
      HashId
hashId <- Hash32 -> Transaction HashId
saveHash Hash32
hash
      let bytes :: ByteString
bytes = Put -> ByteString
runPutS (SyncPatchFormat' PatchObjectId TextId HashId ObjectId -> Put
forall (m :: * -> *).
MonadPut m =>
SyncPatchFormat' PatchObjectId TextId HashId ObjectId -> m ()
Serialization.recomposePatchFormat SyncPatchFormat' PatchObjectId TextId HashId ObjectId
spf)
      ObjectId -> Either CausalHashId ObjectId
forall a b. b -> Either a b
Right (ObjectId -> Either CausalHashId ObjectId)
-> Transaction ObjectId
-> Transaction (Either CausalHashId ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashHandle
-> HashId -> ObjectType -> ByteString -> Transaction ObjectId
saveObject HashHandle
hh HashId
hashId ObjectType
ObjectType.Patch ByteString
bytes
    Entity.C SyncCausalFormat
scf -> case SyncCausalFormat
scf of
      Sqlite.Causal.SyncCausalFormat {BranchHashId
$sel:valueHash:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> valueHash
valueHash :: BranchHashId
valueHash, Vector CausalHashId
$sel:parents:SyncCausalFormat :: forall causalHash valueHash.
SyncCausalFormat' causalHash valueHash -> Vector causalHash
parents :: Vector CausalHashId
parents} -> do
        HashId
hashId <- Hash32 -> Transaction HashId
saveHash Hash32
hash
        let causalHashId :: CausalHashId
causalHashId = HashId -> CausalHashId
CausalHashId HashId
hashId
        HashHandle
-> CausalHashId -> BranchHashId -> [CausalHashId] -> Transaction ()
saveCausal HashHandle
hh CausalHashId
causalHashId BranchHashId
valueHash (Vector CausalHashId -> [CausalHashId]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector CausalHashId
parents)
        pure $ CausalHashId -> Either CausalHashId ObjectId
forall a b. a -> Either a b
Left CausalHashId
causalHashId

s2cTermWithType :: LocalIds.LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol)
s2cTermWithType :: LocalIds' TextId ObjectId
-> Term -> Type -> Transaction (Term Symbol, Type Symbol)
s2cTermWithType LocalIds' TextId ObjectId
ids Term
tm Type
tp = do
  (LocalTextId -> Text
substText, LocalDefnId -> Hash
substHash) <- (TextId -> Transaction Text)
-> (ObjectId -> Transaction Hash)
-> LocalIds' TextId ObjectId
-> Transaction (LocalTextId -> Text, LocalDefnId -> Hash)
forall (m :: * -> *) t d.
Monad m =>
(t -> m Text)
-> (d -> m Hash)
-> LocalIds' t d
-> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups TextId -> Transaction Text
expectText ObjectId -> Transaction Hash
expectPrimaryHashByObjectId LocalIds' TextId ObjectId
ids
  (Term Symbol, Type Symbol)
-> Transaction (Term Symbol, Type Symbol)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> Term -> Term Symbol
x2cTerm LocalTextId -> Text
substText LocalDefnId -> Hash
substHash Term
tm, (LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> Type -> Type Symbol
x2cTType LocalTextId -> Text
substText LocalDefnId -> Hash
substHash Type
tp)

saveTermComponent ::
  HashHandle ->
  -- | The serialized term component if we already have it e.g. via sync
  Maybe ByteString ->
  -- | term component hash
  Hash ->
  -- | term component
  [(C.Term Symbol, C.Term.Type Symbol)] ->
  Transaction ObjectId
saveTermComponent :: HashHandle
-> Maybe ByteString
-> Hash
-> [(Term Symbol, Type Symbol)]
-> Transaction ObjectId
saveTermComponent hh :: HashHandle
hh@HashHandle {Type Symbol -> Reference
toReference :: Type Symbol -> Reference
$sel:toReference:HashHandle :: HashHandle -> Type Symbol -> Reference
toReference, Type Symbol -> Set Reference
toReferenceMentions :: Type Symbol -> Set Reference
$sel:toReferenceMentions:HashHandle :: HashHandle -> Type Symbol -> Set Reference
toReferenceMentions} Maybe ByteString
maybeEncodedTerms Hash
h [(Term Symbol, Type Symbol)]
terms = do
  Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (Transaction () -> Transaction ())
-> ([Char] -> Transaction ()) -> [Char] -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Transaction ()
forall (f :: * -> *). Applicative f => [Char] -> f ()
traceM ([Char] -> Transaction ()) -> [Char] -> Transaction ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Operations.saveTermComponent " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
forall a. Show a => a -> [Char]
show Hash
h
  [(LocalIds' TextId ObjectId, Term, Type)]
sTermElements <- ((Term Symbol, Type Symbol)
 -> Transaction (LocalIds' TextId ObjectId, Term, Type))
-> [(Term Symbol, Type Symbol)]
-> Transaction [(LocalIds' TextId ObjectId, Term, Type)]
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 ((Term Symbol
 -> Type Symbol
 -> Transaction (LocalIds' TextId ObjectId, Term, Type))
-> (Term Symbol, Type Symbol)
-> Transaction (LocalIds' TextId ObjectId, Term, Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Term Symbol
-> Type Symbol
-> Transaction (LocalIds' TextId ObjectId, Term, Type)
c2sTerm) [(Term Symbol, Type Symbol)]
terms
  HashId
hashId <- Hash -> Transaction HashId
saveHashHash Hash
h
  let bytes :: ByteString
bytes = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
mkByteString Maybe ByteString
maybeEncodedTerms
      mkByteString :: ByteString
mkByteString =
        let li :: LocallyIndexedComponent
li = Vector (LocalIds' TextId ObjectId, Term, Type)
-> LocallyIndexedComponent
forall t d.
Vector (LocalIds' t d, Term, Type) -> LocallyIndexedComponent' t d
S.Term.LocallyIndexedComponent (Vector (LocalIds' TextId ObjectId, Term, Type)
 -> LocallyIndexedComponent)
-> Vector (LocalIds' TextId ObjectId, Term, Type)
-> LocallyIndexedComponent
forall a b. (a -> b) -> a -> b
$ [(LocalIds' TextId ObjectId, Term, Type)]
-> Vector (LocalIds' TextId ObjectId, Term, Type)
forall a. [a] -> Vector a
Vector.fromList [(LocalIds' TextId ObjectId, Term, Type)]
sTermElements
         in Put (TermFormat' TextId ObjectId)
-> TermFormat' TextId ObjectId -> ByteString
forall a. Put a -> a -> ByteString
S.putBytes TermFormat' TextId ObjectId -> m ()
Put (TermFormat' TextId ObjectId)
Serialization.putTermFormat (TermFormat' TextId ObjectId -> ByteString)
-> TermFormat' TextId ObjectId -> ByteString
forall a b. (a -> b) -> a -> b
$ LocallyIndexedComponent -> TermFormat' TextId ObjectId
forall t d. LocallyIndexedComponent' t d -> TermFormat' t d
S.Term.Term LocallyIndexedComponent
li
  ObjectId
oId <- HashHandle
-> HashId -> ObjectType -> ByteString -> Transaction ObjectId
saveObject HashHandle
hh HashId
hashId ObjectType
ObjectType.TermComponent ByteString
bytes
  -- populate dependents index
  let unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
      unlocalizeRefs :: ((LocalIds' TextId ObjectId, Term, Type), Pos)
-> (Set Reference, Id)
unlocalizeRefs ((LocalIds Vector TextId
tIds Vector ObjectId
oIds, Term
tm, Type
tp), Pos
i) =
        let self :: Id
self = ObjectId -> Pos -> Id
forall h. h -> Pos -> Id' h
C.Reference.Id ObjectId
oId Pos
i
            Set Reference
dependencies :: Set S.Reference =
              let ([TypeRef]
tmRefs, [TypeRef]
tpRefs, [TermLink]
tmLinks, [TypeRef]
tpLinks) = Term -> ([TypeRef], [TypeRef], [TermLink], [TypeRef])
forall v text termRef typeRef termLink typeLink vt a.
Ord v =>
Term (F' text termRef typeRef termLink typeLink vt) v a
-> ([termRef], [typeRef], [termLink], [typeLink])
TermUtil.dependencies Term
tm
                  tpRefs' :: [TypeRef]
tpRefs' = Set TypeRef -> [TypeRef]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Set TypeRef -> [TypeRef]) -> Set TypeRef -> [TypeRef]
forall a b. (a -> b) -> a -> b
$ Type -> Set TypeRef
forall v r a. (Ord v, Ord r) => Term (F' r) v a -> Set r
C.Type.dependencies Type
tp
                  getTermSRef :: S.Term.TermRef -> S.Reference
                  getTermSRef :: TypeRef -> Reference
getTermSRef = \case
                    ReferenceBuiltin LocalTextId
t -> TextId -> Reference
forall t h. t -> Reference' t h
ReferenceBuiltin (Vector TextId
tIds Vector TextId -> Int -> TextId
forall a. Vector a -> Int -> a
Vector.! LocalTextId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalTextId
t)
                    C.Reference.Derived Maybe LocalDefnId
Nothing Pos
i -> ObjectId -> Pos -> Reference
forall h t. h -> Pos -> Reference' t h
C.Reference.Derived ObjectId
oId Pos
i -- index self-references
                    C.Reference.Derived (Just LocalDefnId
h) Pos
i -> ObjectId -> Pos -> Reference
forall h t. h -> Pos -> Reference' t h
C.Reference.Derived (Vector ObjectId
oIds Vector ObjectId -> Int -> ObjectId
forall a. Vector a -> Int -> a
Vector.! LocalDefnId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalDefnId
h) Pos
i
                  getTypeSRef :: S.Term.TypeRef -> S.Reference
                  getTypeSRef :: TypeRef -> Reference
getTypeSRef = \case
                    ReferenceBuiltin LocalTextId
t -> TextId -> Reference
forall t h. t -> Reference' t h
ReferenceBuiltin (Vector TextId
tIds Vector TextId -> Int -> TextId
forall a. Vector a -> Int -> a
Vector.! LocalTextId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalTextId
t)
                    C.Reference.Derived LocalDefnId
h Pos
i -> ObjectId -> Pos -> Reference
forall h t. h -> Pos -> Reference' t h
C.Reference.Derived (Vector ObjectId
oIds Vector ObjectId -> Int -> ObjectId
forall a. Vector a -> Int -> a
Vector.! LocalDefnId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalDefnId
h) Pos
i
                  getSTypeLink :: TypeRef -> Reference
getSTypeLink = TypeRef -> Reference
getTypeSRef
                  getSTermLink :: S.Term.TermLink -> S.Reference
                  getSTermLink :: TermLink -> Reference
getSTermLink = \case
                    C.Referent.Con TypeRef
ref Pos
_conId -> TypeRef -> Reference
getTypeSRef TypeRef
ref
                    C.Referent.Ref TypeRef
ref -> TypeRef -> Reference
getTermSRef TypeRef
ref
               in [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
Set.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$
                    (TypeRef -> Reference) -> [TypeRef] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map TypeRef -> Reference
getTermSRef [TypeRef]
tmRefs
                      [Reference] -> [Reference] -> [Reference]
forall a. [a] -> [a] -> [a]
++ (TermLink -> Reference) -> [TermLink] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map TermLink -> Reference
getSTermLink [TermLink]
tmLinks
                      [Reference] -> [Reference] -> [Reference]
forall a. [a] -> [a] -> [a]
++ (TypeRef -> Reference) -> [TypeRef] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map TypeRef -> Reference
getTypeSRef ([TypeRef]
tpRefs [TypeRef] -> [TypeRef] -> [TypeRef]
forall a. [a] -> [a] -> [a]
++ [TypeRef]
tpRefs')
                      [Reference] -> [Reference] -> [Reference]
forall a. [a] -> [a] -> [a]
++ (TypeRef -> Reference) -> [TypeRef] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map TypeRef -> Reference
getSTypeLink [TypeRef]
tpLinks
         in (Set Reference
dependencies, Id
self)
  [(Set Reference, Id)]
-> ((Set Reference, Id) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((((LocalIds' TextId ObjectId, Term, Type), Pos)
 -> (Set Reference, Id))
-> [((LocalIds' TextId ObjectId, Term, Type), Pos)]
-> [(Set Reference, Id)]
forall a b. (a -> b) -> [a] -> [b]
map ((LocalIds' TextId ObjectId, Term, Type), Pos)
-> (Set Reference, Id)
unlocalizeRefs ([(LocalIds' TextId ObjectId, Term, Type)]
sTermElements [(LocalIds' TextId ObjectId, Term, Type)]
-> [Pos] -> [((LocalIds' TextId ObjectId, Term, Type), Pos)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Pos
0 ..])) \(Set Reference
dependencies, Id
dependent) ->
    [Reference] -> Id -> Transaction ()
addToDependentsIndex (Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList Set Reference
dependencies) Id
dependent
  [(Type Symbol, Pos)]
-> ((Type Symbol, Pos) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (((Term Symbol, Type Symbol) -> Type Symbol
forall a b. (a, b) -> b
snd ((Term Symbol, Type Symbol) -> Type Symbol)
-> [(Term Symbol, Type Symbol)] -> [Type Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Term Symbol, Type Symbol)]
terms) [Type Symbol] -> [Pos] -> [(Type Symbol, Pos)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Pos
0 ..]) \(Type Symbol
tp, Pos
i) -> do
    let self :: Id
self = Id -> Id
forall hTm hTp. Id' hTm -> Id' hTm hTp
C.Referent.RefId (ObjectId -> Pos -> Id
forall h. h -> Pos -> Id' h
C.Reference.Id ObjectId
oId Pos
i)
        typeForIndexing :: Reference
typeForIndexing = Type Symbol -> Reference
toReference Type Symbol
tp
        typeMentionsForIndexing :: Set Reference
typeMentionsForIndexing = Type Symbol -> Set Reference
toReferenceMentions Type Symbol
tp
    Id -> Reference -> Transaction ()
addTypeToIndexForTerm Id
self Reference
typeForIndexing
    Id -> Set Reference -> Transaction ()
addTypeMentionsToIndexForTerm Id
self Set Reference
typeMentionsForIndexing

  pure ObjectId
oId

-- | Unlocalize a decl.
s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol)
s2cDecl :: LocalIds' TextId ObjectId
-> Decl Symbol -> Transaction (Decl Symbol)
s2cDecl LocalIds' TextId ObjectId
ids Decl Symbol
decl = do
  TypeRef -> TypeRef
substTypeRef <- LocalIds' TextId ObjectId -> Transaction (TypeRef -> TypeRef)
localIdsToTypeRefLookup LocalIds' TextId ObjectId
ids
  pure $ (TypeRef -> TypeRef) -> Decl Symbol -> Decl Symbol
forall r r1. (r -> r1) -> DeclR r Symbol -> DeclR r1 Symbol
x2cDecl TypeRef -> TypeRef
substTypeRef Decl Symbol
decl

x2cDecl :: (r -> r1) -> (C.Decl.DeclR r Symbol -> C.Decl.DeclR r1 Symbol)
x2cDecl :: forall r r1. (r -> r1) -> DeclR r Symbol -> DeclR r1 Symbol
x2cDecl r -> r1
substTypeRef (C.Decl.DataDeclaration DeclType
dt Modifier
m [Symbol]
b [TypeR r Symbol]
ct) = DeclType
-> Modifier -> [Symbol] -> [TypeR r1 Symbol] -> DeclR r1 Symbol
forall r v. DeclType -> Modifier -> [v] -> [TypeR r v] -> DeclR r v
C.Decl.DataDeclaration DeclType
dt Modifier
m [Symbol]
b ((r -> r1) -> TypeR r Symbol -> TypeR r1 Symbol
forall v r r' a.
Ord v =>
(r -> r') -> Term (F' r) v a -> Term (F' r') v a
C.Type.rmap r -> r1
substTypeRef (TypeR r Symbol -> TypeR r1 Symbol)
-> [TypeR r Symbol] -> [TypeR r1 Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeR r Symbol]
ct)

saveDeclComponent ::
  HashHandle ->
  Maybe ByteString ->
  Hash ->
  [C.Decl Symbol] ->
  Transaction ObjectId
saveDeclComponent :: HashHandle
-> Maybe ByteString
-> Hash
-> [Decl Symbol]
-> Transaction ObjectId
saveDeclComponent hh :: HashHandle
hh@HashHandle {Hash -> TypeD Symbol -> Reference
toReferenceDecl :: Hash -> TypeD Symbol -> Reference
$sel:toReferenceDecl:HashHandle :: HashHandle -> Hash -> TypeD Symbol -> Reference
toReferenceDecl, Hash -> TypeD Symbol -> Set Reference
toReferenceDeclMentions :: Hash -> TypeD Symbol -> Set Reference
$sel:toReferenceDeclMentions:HashHandle :: HashHandle -> Hash -> TypeD Symbol -> Set Reference
toReferenceDeclMentions} Maybe ByteString
maybeEncodedDecls Hash
h [Decl Symbol]
decls = do
  Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (Transaction () -> Transaction ())
-> ([Char] -> Transaction ()) -> [Char] -> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Transaction ()
forall (f :: * -> *). Applicative f => [Char] -> f ()
traceM ([Char] -> Transaction ()) -> [Char] -> Transaction ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Operations.saveDeclComponent " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash -> [Char]
forall a. Show a => a -> [Char]
show Hash
h
  [(LocalIds' TextId ObjectId, Decl Symbol)]
sDeclElements <- (Decl Symbol
 -> Transaction (LocalIds' TextId ObjectId, Decl Symbol))
-> [Decl Symbol]
-> Transaction [(LocalIds' TextId ObjectId, Decl Symbol)]
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 ((Text -> Transaction TextId)
-> (Hash -> Transaction ObjectId)
-> Decl Symbol
-> Transaction (LocalIds' TextId ObjectId, Decl Symbol)
forall (m :: * -> *) t d.
Monad m =>
(Text -> m t)
-> (Hash -> m d) -> Decl Symbol -> m (LocalIds' t d, Decl Symbol)
c2sDecl Text -> Transaction TextId
saveText Hash -> Transaction ObjectId
expectObjectIdForPrimaryHash) [Decl Symbol]
decls
  HashId
hashId <- Hash -> Transaction HashId
saveHashHash Hash
h
  let bytes :: ByteString
bytes = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
mkByteString Maybe ByteString
maybeEncodedDecls
      mkByteString :: ByteString
mkByteString =
        let li :: LocallyIndexedComponent
li = Vector (LocalIds' TextId ObjectId, Decl Symbol)
-> LocallyIndexedComponent
forall t d.
Vector (LocalIds' t d, Decl Symbol) -> LocallyIndexedComponent' t d
S.Decl.LocallyIndexedComponent (Vector (LocalIds' TextId ObjectId, Decl Symbol)
 -> LocallyIndexedComponent)
-> Vector (LocalIds' TextId ObjectId, Decl Symbol)
-> LocallyIndexedComponent
forall a b. (a -> b) -> a -> b
$ [(LocalIds' TextId ObjectId, Decl Symbol)]
-> Vector (LocalIds' TextId ObjectId, Decl Symbol)
forall a. [a] -> Vector a
Vector.fromList [(LocalIds' TextId ObjectId, Decl Symbol)]
sDeclElements
         in Put (DeclFormat' TextId ObjectId)
-> DeclFormat' TextId ObjectId -> ByteString
forall a. Put a -> a -> ByteString
S.putBytes DeclFormat' TextId ObjectId -> m ()
Put (DeclFormat' TextId ObjectId)
Serialization.putDeclFormat (DeclFormat' TextId ObjectId -> ByteString)
-> DeclFormat' TextId ObjectId -> ByteString
forall a b. (a -> b) -> a -> b
$ LocallyIndexedComponent -> DeclFormat' TextId ObjectId
forall text defn.
LocallyIndexedComponent' text defn -> DeclFormat' text defn
S.Decl.Decl LocallyIndexedComponent
li
  ObjectId
oId <- HashHandle
-> HashId -> ObjectType -> ByteString -> Transaction ObjectId
saveObject HashHandle
hh HashId
hashId ObjectType
ObjectType.DeclComponent ByteString
bytes
  -- populate dependents index
  let unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
      unlocalizeRefs :: ((LocalIds' TextId ObjectId, Decl Symbol), Pos)
-> (Set Reference, Id)
unlocalizeRefs ((LocalIds Vector TextId
tIds Vector ObjectId
oIds, Decl Symbol
decl), Pos
i) =
        let self :: Id
self = ObjectId -> Pos -> Id
forall h. h -> Pos -> Id' h
C.Reference.Id ObjectId
oId Pos
i
            Set TypeRef
dependencies :: Set S.Decl.TypeRef = Decl Symbol -> Set TypeRef
forall r v. (Ord r, Ord v) => DeclR r v -> Set r
C.Decl.dependencies Decl Symbol
decl
            getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference
            getSRef :: TypeRef -> Reference
getSRef = \case
              ReferenceBuiltin LocalTextId
t -> TextId -> Reference
forall t h. t -> Reference' t h
ReferenceBuiltin (Vector TextId
tIds Vector TextId -> Int -> TextId
forall a. Vector a -> Int -> a
Vector.! LocalTextId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalTextId
t)
              C.Reference.Derived Maybe LocalDefnId
Nothing Pos
i -> ObjectId -> Pos -> Reference
forall h t. h -> Pos -> Reference' t h
C.Reference.Derived ObjectId
oId Pos
i -- index self-references
              C.Reference.Derived (Just LocalDefnId
h) Pos
i -> ObjectId -> Pos -> Reference
forall h t. h -> Pos -> Reference' t h
C.Reference.Derived (Vector ObjectId
oIds Vector ObjectId -> Int -> ObjectId
forall a. Vector a -> Int -> a
Vector.! LocalDefnId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral LocalDefnId
h) Pos
i
         in ((TypeRef -> Reference) -> Set TypeRef -> Set Reference
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TypeRef -> Reference
getSRef Set TypeRef
dependencies, Id
self)
  [(Set Reference, Id)]
-> ((Set Reference, Id) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((((LocalIds' TextId ObjectId, Decl Symbol), Pos)
 -> (Set Reference, Id))
-> [((LocalIds' TextId ObjectId, Decl Symbol), Pos)]
-> [(Set Reference, Id)]
forall a b. (a -> b) -> [a] -> [b]
map ((LocalIds' TextId ObjectId, Decl Symbol), Pos)
-> (Set Reference, Id)
unlocalizeRefs ([(LocalIds' TextId ObjectId, Decl Symbol)]
sDeclElements [(LocalIds' TextId ObjectId, Decl Symbol)]
-> [Pos] -> [((LocalIds' TextId ObjectId, Decl Symbol), Pos)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Pos
0 ..])) \(Set Reference
dependencies, Id
dependent) ->
    [Reference] -> Id -> Transaction ()
addToDependentsIndex (Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList Set Reference
dependencies) Id
dependent
  [([TypeD Symbol], Pos)]
-> (([TypeD Symbol], Pos) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (((Decl Symbol -> [TypeD Symbol])
-> [Decl Symbol] -> [[TypeD Symbol]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Decl Symbol -> [TypeD Symbol]
forall r v. DeclR r v -> [TypeR r v]
C.Decl.constructorTypes [Decl Symbol]
decls) [[TypeD Symbol]] -> [Pos] -> [([TypeD Symbol], Pos)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Pos
0 ..]) \([TypeD Symbol]
ctors, Pos
i) ->
    [(TypeD Symbol, Pos)]
-> ((TypeD Symbol, Pos) -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([TypeD Symbol]
ctors [TypeD Symbol] -> [Pos] -> [(TypeD Symbol, Pos)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Pos
0 ..]) \(TypeD Symbol
tp, Pos
j) -> do
      let self :: Id
self = Id -> Pos -> Id
forall hTm hTp. Id' hTp -> Pos -> Id' hTm hTp
C.Referent.ConId (ObjectId -> Pos -> Id
forall h. h -> Pos -> Id' h
C.Reference.Id ObjectId
oId Pos
i) Pos
j
          typeForIndexing :: Reference
typeForIndexing = Hash -> TypeD Symbol -> Reference
toReferenceDecl Hash
h TypeD Symbol
tp
          typeMentionsForIndexing :: Set Reference
typeMentionsForIndexing = Hash -> TypeD Symbol -> Set Reference
toReferenceDeclMentions Hash
h TypeD Symbol
tp
      Id -> Reference -> Transaction ()
addTypeToIndexForTerm Id
self Reference
typeForIndexing
      Id -> Set Reference -> Transaction ()
addTypeMentionsToIndexForTerm Id
self Set Reference
typeMentionsForIndexing

  pure ObjectId
oId

-- | implementation detail of {s,w}2c*Term* & s2cDecl
localIdsToLookups :: (Monad m) => (t -> m Text) -> (d -> m Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups :: forall (m :: * -> *) t d.
Monad m =>
(t -> m Text)
-> (d -> m Hash)
-> LocalIds' t d
-> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups t -> m Text
loadText d -> m Hash
loadHash LocalIds' t d
localIds = do
  Vector Text
texts <- (t -> m Text) -> Vector t -> m (Vector Text)
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) -> Vector a -> f (Vector b)
traverse t -> m Text
loadText (Vector t -> m (Vector Text)) -> Vector t -> m (Vector Text)
forall a b. (a -> b) -> a -> b
$ LocalIds' t d -> Vector t
forall t h. LocalIds' t h -> Vector t
LocalIds.textLookup LocalIds' t d
localIds
  Vector Hash
hashes <- (d -> m Hash) -> Vector d -> m (Vector Hash)
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) -> Vector a -> f (Vector b)
traverse d -> m Hash
loadHash (Vector d -> m (Vector Hash)) -> Vector d -> m (Vector Hash)
forall a b. (a -> b) -> a -> b
$ LocalIds' t d -> Vector d
forall t h. LocalIds' t h -> Vector h
LocalIds.defnLookup LocalIds' t d
localIds
  let substText :: LocalTextId -> Text
substText (LocalTextId Pos
w) = Vector Text
texts Vector Text -> Int -> Text
forall a. Vector a -> Int -> a
Vector.! Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
w
      substHash :: LocalDefnId -> Hash
substHash (LocalDefnId Pos
w) = Vector Hash
hashes Vector Hash -> Int -> Hash
forall a. Vector a -> Int -> a
Vector.! Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
w
  (LocalTextId -> Text, LocalDefnId -> Hash)
-> m (LocalTextId -> Text, LocalDefnId -> Hash)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTextId -> Text
substText, LocalDefnId -> Hash
substHash)

-- | implementation detail of {s,w}2c*Term*
x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Term -> C.Term Symbol
x2cTerm :: (LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> Term -> Term Symbol
x2cTerm LocalTextId -> Text
substText LocalDefnId -> Hash
substHash =
  -- substitute the text and hashes back into the term
  (LocalTextId -> Text)
-> (TypeRef -> TypeRef)
-> (TypeRef -> Reference)
-> (TermLink -> TermLink)
-> (TypeRef -> Reference)
-> (Symbol -> Symbol)
-> Term
-> Term Symbol
forall text termRef typeRef termLink typeLink vt text' termRef'
       typeRef' termLink' typeLink' vt' v a.
(Ord v, Ord vt') =>
(text -> text')
-> (termRef -> termRef')
-> (typeRef -> typeRef')
-> (termLink -> termLink')
-> (typeLink -> typeLink')
-> (vt -> vt')
-> Term (F' text termRef typeRef termLink typeLink vt) v a
-> Term (F' text' termRef' typeRef' termLink' typeLink' vt') v a
C.Term.extraMap LocalTextId -> Text
substText TypeRef -> TypeRef
substTermRef TypeRef -> Reference
substTypeRef TermLink -> TermLink
substTermLink TypeRef -> Reference
substTypeLink Symbol -> Symbol
forall a. a -> a
id
  where
    substTermRef :: TypeRef -> TypeRef
substTermRef = (LocalTextId -> Text)
-> (Maybe LocalDefnId -> Maybe Hash) -> TypeRef -> TypeRef
forall a b c d.
(a -> b) -> (c -> d) -> Reference' a c -> Reference' b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap LocalTextId -> Text
substText ((LocalDefnId -> Hash) -> Maybe LocalDefnId -> Maybe Hash
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalDefnId -> Hash
substHash)
    substTypeRef :: TypeRef -> Reference
substTypeRef = (LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> TypeRef -> Reference
forall a b c d.
(a -> b) -> (c -> d) -> Reference' a c -> Reference' b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap LocalTextId -> Text
substText LocalDefnId -> Hash
substHash
    substTermLink :: TermLink -> TermLink
substTermLink = (TypeRef -> TypeRef)
-> (TypeRef -> Reference) -> TermLink -> TermLink
forall a b c d.
(a -> b) -> (c -> d) -> Referent' a c -> Referent' b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TypeRef -> TypeRef
substTermRef TypeRef -> Reference
substTypeRef
    substTypeLink :: TypeRef -> Reference
substTypeLink = TypeRef -> Reference
substTypeRef

-- | implementation detail of {s,w}2c*Term*
x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Type -> C.Term.Type Symbol
x2cTType :: (LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> Type -> Type Symbol
x2cTType LocalTextId -> Text
substText LocalDefnId -> Hash
substHash = (TypeRef -> Reference) -> Type -> Type Symbol
forall v r r' a.
Ord v =>
(r -> r') -> Term (F' r) v a -> Term (F' r') v a
C.Type.rmap ((LocalTextId -> Text)
-> (LocalDefnId -> Hash) -> TypeRef -> Reference
forall a b c d.
(a -> b) -> (c -> d) -> Reference' a c -> Reference' b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap LocalTextId -> Text
substText LocalDefnId -> Hash
substHash)

c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type)
c2sTerm :: Term Symbol
-> Type Symbol
-> Transaction (LocalIds' TextId ObjectId, Term, Type)
c2sTerm Term Symbol
tm Type Symbol
tp =
  (Text -> Transaction TextId)
-> (Hash -> Transaction ObjectId)
-> Term Symbol
-> Maybe (Type Symbol)
-> Transaction (LocalIds' TextId ObjectId, Term, Maybe Type)
forall (m :: * -> *) t d.
Monad m =>
(Text -> m t)
-> (Hash -> m d)
-> Term Symbol
-> Maybe (Type Symbol)
-> m (LocalIds' t d, Term, Maybe Type)
c2xTerm Text -> Transaction TextId
saveText Hash -> Transaction ObjectId
expectObjectIdForPrimaryHash Term Symbol
tm (Type Symbol -> Maybe (Type Symbol)
forall a. a -> Maybe a
Just Type Symbol
tp)
    Transaction (LocalIds' TextId ObjectId, Term, Maybe Type)
-> ((LocalIds' TextId ObjectId, Term, Maybe Type)
    -> (LocalIds' TextId ObjectId, Term, Type))
-> Transaction (LocalIds' TextId ObjectId, Term, Type)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(LocalIds' TextId ObjectId
w, Term
tm, Maybe Type
mayTp) -> (LocalIds' TextId ObjectId
w, Term
tm, Maybe Type -> Type
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust Maybe Type
mayTp)

addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction ()
addTypeToIndexForTerm :: Id -> Reference -> Transaction ()
addTypeToIndexForTerm Id
sTermId Reference
cTypeRef = do
  ReferenceH
sTypeRef <- Reference -> Transaction ReferenceH
saveReferenceH Reference
cTypeRef
  ReferenceH -> Id -> Transaction ()
addToTypeIndex ReferenceH
sTypeRef Id
sTermId

addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction ()
addTypeMentionsToIndexForTerm :: Id -> Set Reference -> Transaction ()
addTypeMentionsToIndexForTerm Id
sTermId Set Reference
cTypeMentionRefs = do
  (Reference -> Transaction ()) -> Set Reference -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((ReferenceH -> Id -> Transaction ())
-> Id -> ReferenceH -> Transaction ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReferenceH -> Id -> Transaction ()
addToTypeMentionsIndex Id
sTermId (ReferenceH -> Transaction ())
-> (Reference -> Transaction ReferenceH)
-> Reference
-> Transaction ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Reference -> Transaction ReferenceH
saveReferenceH) Set Reference
cTypeMentionRefs

localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef)
localIdsToTypeRefLookup :: LocalIds' TextId ObjectId -> Transaction (TypeRef -> TypeRef)
localIdsToTypeRefLookup LocalIds' TextId ObjectId
localIds = do
  (LocalTextId -> Text
substText, LocalDefnId -> Hash
substHash) <- (TextId -> Transaction Text)
-> (ObjectId -> Transaction Hash)
-> LocalIds' TextId ObjectId
-> Transaction (LocalTextId -> Text, LocalDefnId -> Hash)
forall (m :: * -> *) t d.
Monad m =>
(t -> m Text)
-> (d -> m Hash)
-> LocalIds' t d
-> m (LocalTextId -> Text, LocalDefnId -> Hash)
localIdsToLookups TextId -> Transaction Text
expectText ObjectId -> Transaction Hash
expectPrimaryHashByObjectId LocalIds' TextId ObjectId
localIds
  (TypeRef -> TypeRef) -> Transaction (TypeRef -> TypeRef)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TypeRef -> TypeRef) -> Transaction (TypeRef -> TypeRef))
-> (TypeRef -> TypeRef) -> Transaction (TypeRef -> TypeRef)
forall a b. (a -> b) -> a -> b
$ (LocalTextId -> Text)
-> (Maybe LocalDefnId -> Maybe Hash) -> TypeRef -> TypeRef
forall a b c d.
(a -> b) -> (c -> d) -> Reference' a c -> Reference' b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap LocalTextId -> Text
substText ((LocalDefnId -> Hash) -> Maybe LocalDefnId -> Maybe Hash
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalDefnId -> Hash
substHash)

c2sDecl ::
  forall m t d.
  (Monad m) =>
  (Text -> m t) ->
  (Hash -> m d) ->
  C.Decl Symbol ->
  m (LocalIds' t d, S.Decl.Decl Symbol)
c2sDecl :: forall (m :: * -> *) t d.
Monad m =>
(Text -> m t)
-> (Hash -> m d) -> Decl Symbol -> m (LocalIds' t d, Decl Symbol)
c2sDecl Text -> m t
saveText Hash -> m d
saveDefn (C.Decl.DataDeclaration DeclType
dt Modifier
m [Symbol]
b [TypeD Symbol]
cts) = do
  (Decl Symbol, (Seq Text, Seq Hash))
-> m (LocalIds' t d, Decl Symbol)
done ((Decl Symbol, (Seq Text, Seq Hash))
 -> m (LocalIds' t d, Decl Symbol))
-> m (Decl Symbol, (Seq Text, Seq Hash))
-> m (LocalIds' t d, Decl Symbol)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (WriterT (Seq Text, Seq Hash) m (Decl Symbol)
-> m (Decl Symbol, (Seq Text, Seq Hash))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Seq Text, Seq Hash) m (Decl Symbol)
 -> m (Decl Symbol, (Seq Text, Seq Hash)))
-> (StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (Decl Symbol)
    -> WriterT (Seq Text, Seq Hash) m (Decl Symbol))
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Decl Symbol)
-> m (Decl Symbol, (Seq Text, Seq Hash))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   (Map Text LocalTextId, Map Hash LocalDefnId)
   (WriterT (Seq Text, Seq Hash) m)
   (Decl Symbol)
 -> (Map Text LocalTextId, Map Hash LocalDefnId)
 -> WriterT (Seq Text, Seq Hash) m (Decl Symbol))
-> (Map Text LocalTextId, Map Hash LocalDefnId)
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Decl Symbol)
-> WriterT (Seq Text, Seq Hash) m (Decl Symbol)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Map Text LocalTextId, Map Hash LocalDefnId)
  (WriterT (Seq Text, Seq Hash) m)
  (Decl Symbol)
-> (Map Text LocalTextId, Map Hash LocalDefnId)
-> WriterT (Seq Text, Seq Hash) m (Decl Symbol)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Map Text LocalTextId, Map Hash LocalDefnId)
forall a. Monoid a => a
mempty) do
    [Term (F' TypeRef) Symbol ()]
cts' <- (TypeD Symbol
 -> StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (Term (F' TypeRef) Symbol ()))
-> [TypeD Symbol]
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     [Term (F' TypeRef) Symbol ()]
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 ((forall a1.
 F' TypeRef a1
 -> StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (F' TypeRef a1))
-> TypeD Symbol
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Term (F' TypeRef) Symbol ())
forall v (m :: * -> *) (g :: * -> *) (f :: * -> *) a.
(Ord v, Monad m, Traversable g) =>
(forall a1. f a1 -> m (g a1)) -> Term f v a -> m (Term g v a)
ABT.transformM FD a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (F a1)
forall a1.
F' TypeRef a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (F' TypeRef a1)
forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
FD a -> m (F a)
goType) [TypeD Symbol]
cts
    pure (DeclType
-> Modifier
-> [Symbol]
-> [Term (F' TypeRef) Symbol ()]
-> Decl Symbol
forall r v. DeclType -> Modifier -> [v] -> [TypeR r v] -> DeclR r v
C.Decl.DataDeclaration DeclType
dt Modifier
m [Symbol]
b [Term (F' TypeRef) Symbol ()]
cts')
  where
    goType ::
      forall m a.
      (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
      C.Type.FD a ->
      m (S.Decl.F a)
    goType :: forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
FD a -> m (F a)
goType = \case
      C.Type.Ref TypeRef
r -> TypeRef -> F a
forall r a. r -> F' r a
C.Type.Ref (TypeRef -> F a) -> m TypeRef -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Maybe Hash -> m (Maybe LocalDefnId)) -> TypeRef -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText ((Hash -> m LocalDefnId) -> Maybe Hash -> m (Maybe LocalDefnId)
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) -> Maybe a -> f (Maybe b)
traverse Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn) TypeRef
r
      C.Type.Arrow a
i a
o -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall r a. a -> a -> F' r a
C.Type.Arrow a
i a
o
      C.Type.Ann a
a Kind
k -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> Kind -> F a
forall r a. a -> Kind -> F' r a
C.Type.Ann a
a Kind
k
      C.Type.App a
f a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall r a. a -> a -> F' r a
C.Type.App a
f a
a
      C.Type.Effect a
e a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall r a. a -> a -> F' r a
C.Type.Effect a
e a
a
      C.Type.Effects [a]
es -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ [a] -> F a
forall r a. [a] -> F' r a
C.Type.Effects [a]
es
      C.Type.Forall a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> F a
forall r a. a -> F' r a
C.Type.Forall a
a
      C.Type.IntroOuter a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> F a
forall r a. a -> F' r a
C.Type.IntroOuter a
a
    done :: (S.Decl.Decl Symbol, (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol)
    done :: (Decl Symbol, (Seq Text, Seq Hash))
-> m (LocalIds' t d, Decl Symbol)
done (Decl Symbol
decl, (Seq Text
localTextValues, Seq Hash
localDefnValues)) = do
      Seq t
textIds <- (Text -> m t) -> Seq Text -> m (Seq t)
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) -> Seq a -> f (Seq b)
traverse Text -> m t
saveText Seq Text
localTextValues
      Seq d
defnIds <- (Hash -> m d) -> Seq Hash -> m (Seq d)
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) -> Seq a -> f (Seq b)
traverse Hash -> m d
saveDefn Seq Hash
localDefnValues
      let ids :: LocalIds' t d
ids =
            Vector t -> Vector d -> LocalIds' t d
forall t h. Vector t -> Vector h -> LocalIds' t h
LocalIds
              ([t] -> Vector t
forall a. [a] -> Vector a
Vector.fromList (Seq t -> [t]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq t
textIds))
              ([d] -> Vector d
forall a. [a] -> Vector a
Vector.fromList (Seq d -> [d]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq d
defnIds))
      (LocalIds' t d, Decl Symbol) -> m (LocalIds' t d, Decl Symbol)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalIds' t d
ids, Decl Symbol
decl)

-- | implementation detail of c2{s,w}Term
--  The Type is optional, because we don't store them for watch expression results.
c2xTerm :: forall m t d. (Monad m) => (Text -> m t) -> (Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
c2xTerm :: forall (m :: * -> *) t d.
Monad m =>
(Text -> m t)
-> (Hash -> m d)
-> Term Symbol
-> Maybe (Type Symbol)
-> m (LocalIds' t d, Term, Maybe Type)
c2xTerm Text -> m t
saveText Hash -> m d
saveDefn Term Symbol
tm Maybe (Type Symbol)
tp =
  ((Term, Maybe Type), (Seq Text, Seq Hash))
-> m (LocalIds' t d, Term, Maybe Type)
done (((Term, Maybe Type), (Seq Text, Seq Hash))
 -> m (LocalIds' t d, Term, Maybe Type))
-> m ((Term, Maybe Type), (Seq Text, Seq Hash))
-> m (LocalIds' t d, Term, Maybe Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (WriterT (Seq Text, Seq Hash) m (Term, Maybe Type)
-> m ((Term, Maybe Type), (Seq Text, Seq Hash))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Seq Text, Seq Hash) m (Term, Maybe Type)
 -> m ((Term, Maybe Type), (Seq Text, Seq Hash)))
-> (StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (Term, Maybe Type)
    -> WriterT (Seq Text, Seq Hash) m (Term, Maybe Type))
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Term, Maybe Type)
-> m ((Term, Maybe Type), (Seq Text, Seq Hash))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   (Map Text LocalTextId, Map Hash LocalDefnId)
   (WriterT (Seq Text, Seq Hash) m)
   (Term, Maybe Type)
 -> (Map Text LocalTextId, Map Hash LocalDefnId)
 -> WriterT (Seq Text, Seq Hash) m (Term, Maybe Type))
-> (Map Text LocalTextId, Map Hash LocalDefnId)
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Term, Maybe Type)
-> WriterT (Seq Text, Seq Hash) m (Term, Maybe Type)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Map Text LocalTextId, Map Hash LocalDefnId)
  (WriterT (Seq Text, Seq Hash) m)
  (Term, Maybe Type)
-> (Map Text LocalTextId, Map Hash LocalDefnId)
-> WriterT (Seq Text, Seq Hash) m (Term, Maybe Type)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Map Text LocalTextId, Map Hash LocalDefnId)
forall a. Monoid a => a
mempty) do
    Term
sterm <- (forall a1.
 F Symbol a1
 -> StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (F a1))
-> Term Symbol
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     Term
forall v (m :: * -> *) (g :: * -> *) (f :: * -> *) a.
(Ord v, Monad m, Traversable g) =>
(forall a1. f a1 -> m (g a1)) -> Term f v a -> m (Term g v a)
ABT.transformM F Symbol a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (F a1)
forall a1.
F Symbol a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (F a1)
forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
F Symbol a -> m (F a)
go Term Symbol
tm
    Maybe Type
stype <- (Type Symbol
 -> StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      Type)
-> Maybe (Type Symbol)
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (Maybe Type)
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) -> Maybe a -> f (Maybe b)
traverse ((forall a1.
 F' Reference a1
 -> StateT
      (Map Text LocalTextId, Map Hash LocalDefnId)
      (WriterT (Seq Text, Seq Hash) m)
      (FT a1))
-> Type Symbol
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     Type
forall v (m :: * -> *) (g :: * -> *) (f :: * -> *) a.
(Ord v, Monad m, Traversable g) =>
(forall a1. f a1 -> m (g a1)) -> Term f v a -> m (Term g v a)
ABT.transformM FT a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (FT a1)
forall a1.
F' Reference a1
-> StateT
     (Map Text LocalTextId, Map Hash LocalDefnId)
     (WriterT (Seq Text, Seq Hash) m)
     (FT a1)
forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
FT a -> m (FT a)
goType) Maybe (Type Symbol)
tp
    pure (Term
sterm, Maybe Type
stype)
  where
    go :: forall m a. (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a)
    go :: forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
F Symbol a -> m (F a)
go = \case
      C.Term.Int Int64
n -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Int64 -> F a
forall text termRef typeRef termLink typeLink vt a.
Int64 -> F' text termRef typeRef termLink typeLink vt a
C.Term.Int Int64
n
      C.Term.Nat Pos
n -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Pos -> F a
forall text termRef typeRef termLink typeLink vt a.
Pos -> F' text termRef typeRef termLink typeLink vt a
C.Term.Nat Pos
n
      C.Term.Float Double
n -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Double -> F a
forall text termRef typeRef termLink typeLink vt a.
Double -> F' text termRef typeRef termLink typeLink vt a
C.Term.Float Double
n
      C.Term.Boolean Bool
b -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Bool -> F a
forall text termRef typeRef termLink typeLink vt a.
Bool -> F' text termRef typeRef termLink typeLink vt a
C.Term.Boolean Bool
b
      C.Term.Text Text
t -> LocalTextId -> F a
forall text termRef typeRef termLink typeLink vt a.
text -> F' text termRef typeRef termLink typeLink vt a
C.Term.Text (LocalTextId -> F a) -> m LocalTextId -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Text
t
      C.Term.Char Char
ch -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Char -> F a
forall text termRef typeRef termLink typeLink vt a.
Char -> F' text termRef typeRef termLink typeLink vt a
C.Term.Char Char
ch
      C.Term.Ref TypeRef
r ->
        TypeRef -> F a
forall text termRef typeRef termLink typeLink vt a.
termRef -> F' text termRef typeRef termLink typeLink vt a
C.Term.Ref (TypeRef -> F a) -> m TypeRef -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Maybe Hash -> m (Maybe LocalDefnId)) -> TypeRef -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText ((Hash -> m LocalDefnId) -> Maybe Hash -> m (Maybe LocalDefnId)
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) -> Maybe a -> f (Maybe b)
traverse Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn) TypeRef
r
      C.Term.Constructor Reference
typeRef Pos
cid ->
        TypeRef -> Pos -> F a
forall text termRef typeRef termLink typeLink vt a.
typeRef -> Pos -> F' text termRef typeRef termLink typeLink vt a
C.Term.Constructor
          (TypeRef -> Pos -> F a) -> m TypeRef -> m (Pos -> F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
typeRef
          m (Pos -> F a) -> m Pos -> m (F a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pos -> m Pos
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pos
cid
      C.Term.Request Reference
typeRef Pos
cid ->
        TypeRef -> Pos -> F a
forall text termRef typeRef termLink typeLink vt a.
typeRef -> Pos -> F' text termRef typeRef termLink typeLink vt a
C.Term.Request (TypeRef -> Pos -> F a) -> m TypeRef -> m (Pos -> F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
typeRef m (Pos -> F a) -> m Pos -> m (F a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pos -> m Pos
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pos
cid
      C.Term.Handle a
a a
a2 -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.Handle a
a a
a2
      C.Term.App a
a a
a2 -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.App a
a a
a2
      C.Term.Ann a
a Type Symbol
typ -> a -> Type -> F a
forall text termRef typeRef termLink typeLink vt a.
a
-> TypeR typeRef vt
-> F' text termRef typeRef termLink typeLink vt a
C.Term.Ann a
a (Type -> F a) -> m Type -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a1. F' Reference a1 -> m (FT a1)) -> Type Symbol -> m Type
forall v (m :: * -> *) (g :: * -> *) (f :: * -> *) a.
(Ord v, Monad m, Traversable g) =>
(forall a1. f a1 -> m (g a1)) -> Term f v a -> m (Term g v a)
ABT.transformM FT a1 -> m (FT a1)
forall a1. F' Reference a1 -> m (FT a1)
forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
FT a -> m (FT a)
goType Type Symbol
typ
      C.Term.List Seq a
as -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ Seq a -> F a
forall text termRef typeRef termLink typeLink vt a.
Seq a -> F' text termRef typeRef termLink typeLink vt a
C.Term.List Seq a
as
      C.Term.If a
c a
t a
f -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.If a
c a
t a
f
      C.Term.And a
a a
a2 -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.And a
a a
a2
      C.Term.Or a
a a
a2 -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.Or a
a a
a2
      C.Term.Lam a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> F' text termRef typeRef termLink typeLink vt a
C.Term.Lam a
a
      C.Term.LetRec [a]
bs a
a -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ [a] -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
[a] -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.LetRec [a]
bs a
a
      C.Term.Let a
a a
a2 -> F a -> m (F a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (F a -> m (F a)) -> F a -> m (F a)
forall a b. (a -> b) -> a -> b
$ a -> a -> F a
forall text termRef typeRef termLink typeLink vt a.
a -> a -> F' text termRef typeRef termLink typeLink vt a
C.Term.Let a
a a
a2
      C.Term.Match a
a [MatchCase Text Reference a]
cs -> a -> [MatchCase LocalTextId TypeRef a] -> F a
forall text termRef typeRef termLink typeLink vt a.
a
-> [MatchCase text typeRef a]
-> F' text termRef typeRef termLink typeLink vt a
C.Term.Match a
a ([MatchCase LocalTextId TypeRef a] -> F a)
-> m [MatchCase LocalTextId TypeRef a] -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MatchCase Text Reference a -> m (MatchCase LocalTextId TypeRef a))
-> [MatchCase Text Reference a]
-> m [MatchCase LocalTextId TypeRef a]
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 MatchCase Text Reference a -> m (MatchCase LocalTextId TypeRef a)
forall (m :: * -> *) w s a.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
MatchCase Text Reference a -> m (MatchCase LocalTextId TypeRef a)
goCase [MatchCase Text Reference a]
cs
      C.Term.TermLink TermLink
r ->
        TermLink -> F a
forall text termRef typeRef termLink typeLink vt a.
termLink -> F' text termRef typeRef termLink typeLink vt a
C.Term.TermLink
          (TermLink -> F a) -> m TermLink -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeRef -> m TypeRef)
-> (Reference -> m TypeRef) -> TermLink -> m TermLink
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Referent' a b -> f (Referent' 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
            ((Text -> m LocalTextId)
-> (Maybe Hash -> m (Maybe LocalDefnId)) -> TypeRef -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText ((Hash -> m LocalDefnId) -> Maybe Hash -> m (Maybe LocalDefnId)
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) -> Maybe a -> f (Maybe b)
traverse Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn))
            ((Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn)
            TermLink
r
      C.Term.TypeLink Reference
r ->
        TypeRef -> F a
forall text termRef typeRef termLink typeLink vt a.
typeLink -> F' text termRef typeRef termLink typeLink vt a
C.Term.TypeLink (TypeRef -> F a) -> m TypeRef -> m (F a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
r
    goType ::
      forall m a.
      (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
      C.Type.FT a ->
      m (S.Term.FT a)
    goType :: forall (m :: * -> *) a.
(MonadWriter (Seq Text, Seq Hash) m,
 MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
FT a -> m (FT a)
goType = \case
      C.Type.Ref Reference
r -> TypeRef -> FT a
forall r a. r -> F' r a
C.Type.Ref (TypeRef -> FT a) -> m TypeRef -> m (FT a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
r
      C.Type.Arrow a
i a
o -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> a -> FT a
forall r a. a -> a -> F' r a
C.Type.Arrow a
i a
o
      C.Type.Ann a
a Kind
k -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> Kind -> FT a
forall r a. a -> Kind -> F' r a
C.Type.Ann a
a Kind
k
      C.Type.App a
f a
a -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> a -> FT a
forall r a. a -> a -> F' r a
C.Type.App a
f a
a
      C.Type.Effect a
e a
a -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> a -> FT a
forall r a. a -> a -> F' r a
C.Type.Effect a
e a
a
      C.Type.Effects [a]
es -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ [a] -> FT a
forall r a. [a] -> F' r a
C.Type.Effects [a]
es
      C.Type.Forall a
a -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> FT a
forall r a. a -> F' r a
C.Type.Forall a
a
      C.Type.IntroOuter a
a -> FT a -> m (FT a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FT a -> m (FT a)) -> FT a -> m (FT a)
forall a b. (a -> b) -> a -> b
$ a -> FT a
forall r a. a -> F' r a
C.Type.IntroOuter a
a
    goCase ::
      forall m w s a.
      ( MonadState s m,
        MonadWriter w m,
        Lens.Field1' s (Map Text LocalTextId),
        Lens.Field1' w (Seq Text),
        Lens.Field2' s (Map Hash LocalDefnId),
        Lens.Field2' w (Seq Hash)
      ) =>
      C.Term.MatchCase Text C.Term.TypeRef a ->
      m (C.Term.MatchCase LocalTextId S.Term.TypeRef a)
    goCase :: forall (m :: * -> *) w s a.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
MatchCase Text Reference a -> m (MatchCase LocalTextId TypeRef a)
goCase = \case
      C.Term.MatchCase Pattern Text Reference
pat Maybe a
guard a
body ->
        Pattern LocalTextId TypeRef
-> Maybe a -> a -> MatchCase LocalTextId TypeRef a
forall t r a. Pattern t r -> Maybe a -> a -> MatchCase t r a
C.Term.MatchCase (Pattern LocalTextId TypeRef
 -> Maybe a -> a -> MatchCase LocalTextId TypeRef a)
-> m (Pattern LocalTextId TypeRef)
-> m (Maybe a -> a -> MatchCase LocalTextId TypeRef a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
pat m (Maybe a -> a -> MatchCase LocalTextId TypeRef a)
-> m (Maybe a) -> m (a -> MatchCase LocalTextId TypeRef a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
guard m (a -> MatchCase LocalTextId TypeRef a)
-> m a -> m (MatchCase LocalTextId TypeRef a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
body
    goPat ::
      forall m s w.
      ( MonadState s m,
        MonadWriter w m,
        Lens.Field1' s (Map Text LocalTextId),
        Lens.Field1' w (Seq Text),
        Lens.Field2' s (Map Hash LocalDefnId),
        Lens.Field2' w (Seq Hash)
      ) =>
      C.Term.Pattern Text C.Term.TypeRef ->
      m (C.Term.Pattern LocalTextId S.Term.TypeRef)
    goPat :: forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat = \case
      Pattern Text Reference
C.Term.PUnbound -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Pattern LocalTextId TypeRef
forall t r. Pattern t r
C.Term.PUnbound
      Pattern Text Reference
C.Term.PVar -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Pattern LocalTextId TypeRef
forall t r. Pattern t r
C.Term.PVar
      C.Term.PBoolean Bool
b -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Bool -> Pattern LocalTextId TypeRef
forall t r. Bool -> Pattern t r
C.Term.PBoolean Bool
b
      C.Term.PInt Int64
i -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Int64 -> Pattern LocalTextId TypeRef
forall t r. Int64 -> Pattern t r
C.Term.PInt Int64
i
      C.Term.PNat Pos
n -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Pos -> Pattern LocalTextId TypeRef
forall t r. Pos -> Pattern t r
C.Term.PNat Pos
n
      C.Term.PFloat Double
d -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Double -> Pattern LocalTextId TypeRef
forall t r. Double -> Pattern t r
C.Term.PFloat Double
d
      C.Term.PText Text
t -> LocalTextId -> Pattern LocalTextId TypeRef
forall t r. t -> Pattern t r
C.Term.PText (LocalTextId -> Pattern LocalTextId TypeRef)
-> m LocalTextId -> m (Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Text
t
      C.Term.PChar Char
c -> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef))
-> Pattern LocalTextId TypeRef -> m (Pattern LocalTextId TypeRef)
forall a b. (a -> b) -> a -> b
$ Char -> Pattern LocalTextId TypeRef
forall t r. Char -> Pattern t r
C.Term.PChar Char
c
      C.Term.PConstructor Reference
r Pos
i [Pattern Text Reference]
ps -> TypeRef
-> Pos
-> [Pattern LocalTextId TypeRef]
-> Pattern LocalTextId TypeRef
forall t r. r -> Pos -> [Pattern t r] -> Pattern t r
C.Term.PConstructor (TypeRef
 -> Pos
 -> [Pattern LocalTextId TypeRef]
 -> Pattern LocalTextId TypeRef)
-> m TypeRef
-> m (Pos
      -> [Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
r m (Pos
   -> [Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef)
-> m Pos
-> m ([Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pos -> m Pos
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pos
i m ([Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef)
-> m [Pattern LocalTextId TypeRef]
-> m (Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern Text Reference -> m (Pattern LocalTextId TypeRef))
-> [Pattern Text Reference] -> m [Pattern LocalTextId TypeRef]
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 Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat [Pattern Text Reference]
ps
      C.Term.PAs Pattern Text Reference
p -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef
forall t r. Pattern t r -> Pattern t r
C.Term.PAs (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
p
      C.Term.PEffectPure Pattern Text Reference
p -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef
forall t r. Pattern t r -> Pattern t r
C.Term.PEffectPure (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
p
      C.Term.PEffectBind Reference
r Pos
i [Pattern Text Reference]
bindings Pattern Text Reference
k -> TypeRef
-> Pos
-> [Pattern LocalTextId TypeRef]
-> Pattern LocalTextId TypeRef
-> Pattern LocalTextId TypeRef
forall t r. r -> Pos -> [Pattern t r] -> Pattern t r -> Pattern t r
C.Term.PEffectBind (TypeRef
 -> Pos
 -> [Pattern LocalTextId TypeRef]
 -> Pattern LocalTextId TypeRef
 -> Pattern LocalTextId TypeRef)
-> m TypeRef
-> m (Pos
      -> [Pattern LocalTextId TypeRef]
      -> Pattern LocalTextId TypeRef
      -> Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m LocalTextId)
-> (Hash -> m LocalDefnId) -> Reference -> m TypeRef
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> m LocalTextId
forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText Hash -> m LocalDefnId
forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn Reference
r m (Pos
   -> [Pattern LocalTextId TypeRef]
   -> Pattern LocalTextId TypeRef
   -> Pattern LocalTextId TypeRef)
-> m Pos
-> m ([Pattern LocalTextId TypeRef]
      -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pos -> m Pos
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pos
i m ([Pattern LocalTextId TypeRef]
   -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m [Pattern LocalTextId TypeRef]
-> m (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern Text Reference -> m (Pattern LocalTextId TypeRef))
-> [Pattern Text Reference] -> m [Pattern LocalTextId TypeRef]
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 Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat [Pattern Text Reference]
bindings m (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
k
      C.Term.PSequenceLiteral [Pattern Text Reference]
ps -> [Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef
forall t r. [Pattern t r] -> Pattern t r
C.Term.PSequenceLiteral ([Pattern LocalTextId TypeRef] -> Pattern LocalTextId TypeRef)
-> m [Pattern LocalTextId TypeRef]
-> m (Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern Text Reference -> m (Pattern LocalTextId TypeRef))
-> [Pattern Text Reference] -> m [Pattern LocalTextId TypeRef]
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 Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat [Pattern Text Reference]
ps
      C.Term.PSequenceOp Pattern Text Reference
l SeqOp
op Pattern Text Reference
r -> Pattern LocalTextId TypeRef
-> SeqOp
-> Pattern LocalTextId TypeRef
-> Pattern LocalTextId TypeRef
forall t r. Pattern t r -> SeqOp -> Pattern t r -> Pattern t r
C.Term.PSequenceOp (Pattern LocalTextId TypeRef
 -> SeqOp
 -> Pattern LocalTextId TypeRef
 -> Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
-> m (SeqOp
      -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
l m (SeqOp
   -> Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m SeqOp
-> m (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SeqOp -> m SeqOp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeqOp
op m (Pattern LocalTextId TypeRef -> Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
-> m (Pattern LocalTextId TypeRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
forall (m :: * -> *) s w.
(MonadState s m, MonadWriter w m, Field1' s (Map Text LocalTextId),
 Field1' w (Seq Text), Field2' s (Map Hash LocalDefnId),
 Field2' w (Seq Hash)) =>
Pattern Text Reference -> m (Pattern LocalTextId TypeRef)
goPat Pattern Text Reference
r

    done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type)
    done :: ((Term, Maybe Type), (Seq Text, Seq Hash))
-> m (LocalIds' t d, Term, Maybe Type)
done ((Term
tm, Maybe Type
tp), (Seq Text
localTextValues, Seq Hash
localDefnValues)) = do
      Seq t
textIds <- (Text -> m t) -> Seq Text -> m (Seq t)
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) -> Seq a -> f (Seq b)
traverse Text -> m t
saveText Seq Text
localTextValues
      Seq d
defnIds <- (Hash -> m d) -> Seq Hash -> m (Seq d)
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) -> Seq a -> f (Seq b)
traverse Hash -> m d
saveDefn Seq Hash
localDefnValues
      let ids :: LocalIds' t d
ids =
            Vector t -> Vector d -> LocalIds' t d
forall t h. Vector t -> Vector h -> LocalIds' t h
LocalIds
              ([t] -> Vector t
forall a. [a] -> Vector a
Vector.fromList (Seq t -> [t]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq t
textIds))
              ([d] -> Vector d
forall a. [a] -> Vector a
Vector.fromList (Seq d -> [d]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq d
defnIds))
      (LocalIds' t d, Term, Maybe Type)
-> m (LocalIds' t d, Term, Maybe Type)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalIds' t d
ids, Term -> Term
forall (f :: * -> *) a. Functor f => f a -> f ()
void Term
tm, Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Type
tp)

-- | Save the text and hash parts of a Reference to the database and substitute their ids.
saveReferenceH :: C.Reference -> Transaction S.ReferenceH
saveReferenceH :: Reference -> Transaction ReferenceH
saveReferenceH = (Text -> Transaction TextId)
-> (Hash -> Transaction HashId)
-> Reference
-> Transaction ReferenceH
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Reference' a b -> f (Reference' 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 Text -> Transaction TextId
saveText Hash -> Transaction HashId
saveHashHash

lookupText ::
  forall m s w t.
  ( MonadState s m,
    MonadWriter w m,
    Lens.Field1' s (Map t LocalTextId),
    Lens.Field1' w (Seq t),
    Ord t
  ) =>
  t ->
  m LocalTextId
lookupText :: forall (m :: * -> *) s w t.
(MonadState s m, MonadWriter w m, Field1' s (Map t LocalTextId),
 Field1' w (Seq t), Ord t) =>
t -> m LocalTextId
lookupText = Lens' s (Map t LocalTextId)
-> Lens' w (Seq t) -> (Pos -> LocalTextId) -> t -> m LocalTextId
forall s (m :: * -> *) w t t'.
(MonadState s m, MonadWriter w m, Ord t) =>
Lens' s (Map t t') -> Lens' w (Seq t) -> (Pos -> t') -> t -> m t'
lookup_ (Map t LocalTextId -> f (Map t LocalTextId)) -> s -> f s
forall s t a b. Field1 s t a b => Lens s t a b
Lens' s (Map t LocalTextId)
Lens._1 (Seq t -> f (Seq t)) -> w -> f w
forall s t a b. Field1 s t a b => Lens s t a b
Lens' w (Seq t)
Lens._1 Pos -> LocalTextId
LocalTextId

lookupDefn ::
  forall m s w d.
  ( MonadState s m,
    MonadWriter w m,
    Lens.Field2' s (Map d LocalDefnId),
    Lens.Field2' w (Seq d),
    Ord d
  ) =>
  d ->
  m LocalDefnId
lookupDefn :: forall (m :: * -> *) s w d.
(MonadState s m, MonadWriter w m, Field2' s (Map d LocalDefnId),
 Field2' w (Seq d), Ord d) =>
d -> m LocalDefnId
lookupDefn = Lens' s (Map d LocalDefnId)
-> Lens' w (Seq d) -> (Pos -> LocalDefnId) -> d -> m LocalDefnId
forall s (m :: * -> *) w t t'.
(MonadState s m, MonadWriter w m, Ord t) =>
Lens' s (Map t t') -> Lens' w (Seq t) -> (Pos -> t') -> t -> m t'
lookup_ (Map d LocalDefnId -> f (Map d LocalDefnId)) -> s -> f s
forall s t a b. Field2 s t a b => Lens s t a b
Lens' s (Map d LocalDefnId)
Lens._2 (Seq d -> f (Seq d)) -> w -> f w
forall s t a b. Field2 s t a b => Lens s t a b
Lens' w (Seq d)
Lens._2 Pos -> LocalDefnId
LocalDefnId

-- | shared implementation of lookupTextHelper and lookupDefnHelper
--  Look up a value in the LUT, or append it.
lookup_ ::
  (MonadState s m, MonadWriter w m, Ord t) =>
  Lens' s (Map t t') ->
  Lens' w (Seq t) ->
  (Word64 -> t') ->
  t ->
  m t'
lookup_ :: forall s (m :: * -> *) w t t'.
(MonadState s m, MonadWriter w m, Ord t) =>
Lens' s (Map t t') -> Lens' w (Seq t) -> (Pos -> t') -> t -> m t'
lookup_ Lens' s (Map t t')
stateLens Lens' w (Seq t)
writerLens Pos -> t'
mk t
t = do
  Map t t'
map <- Getting (Map t t') s (Map t t') -> m (Map t t')
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting (Map t t') s (Map t t')
Lens' s (Map t t')
stateLens
  case t -> Map t t' -> Maybe t'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup t
t Map t t'
map of
    Maybe t'
Nothing -> do
      let id :: t'
id = Pos -> t'
mk (Pos -> t') -> (Int -> Pos) -> Int -> t'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> t') -> Int -> t'
forall a b. (a -> b) -> a -> b
$ Map t t' -> Int
forall k a. Map k a -> Int
Map.size Map t t'
map
      (Map t t' -> Identity (Map t t')) -> s -> Identity s
Lens' s (Map t t')
stateLens ((Map t t' -> Identity (Map t t')) -> s -> Identity s)
-> (Map t t' -> Map t t') -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
Lens.%= t -> t' -> Map t t' -> Map t t'
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert t
t t'
id
      w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (w -> m ()) -> w -> m ()
forall a b. (a -> b) -> a -> b
$ ASetter w w (Seq t) (Seq t) -> Seq t -> w -> w
forall s t a b. ASetter s t a b -> b -> s -> t
Lens.set ASetter w w (Seq t) (Seq t)
Lens' w (Seq t)
writerLens (t -> Seq t
forall a. a -> Seq a
Seq.singleton t
t) w
forall a. Monoid a => a
mempty
      pure t'
id
    Just t'
t' -> t' -> m t'
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t'
t'

-- | Save statistics about a given branch.
saveNamespaceStats :: BranchHashId -> NamespaceStats -> Transaction ()
saveNamespaceStats :: BranchHashId -> NamespaceStats -> Transaction ()
saveNamespaceStats BranchHashId
bhId NamespaceStats
stats = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO namespace_statistics (
        namespace_hash_id,
        num_contained_terms,
        num_contained_types,
        num_contained_patches
      )
      VALUES (:bhId, @stats, @, @)
    |]

-- | Looks up statistics for a given branch, there's no guarantee that we have
-- computed and saved stats for any given branch.
loadNamespaceStatsByHashId :: BranchHashId -> Transaction (Maybe NamespaceStats)
loadNamespaceStatsByHashId :: BranchHashId -> Transaction (Maybe NamespaceStats)
loadNamespaceStatsByHashId BranchHashId
bhId = do
  Sql -> Transaction (Maybe NamespaceStats)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT num_contained_terms, num_contained_types, num_contained_patches
      FROM namespace_statistics
      WHERE namespace_hash_id = :bhId
    |]

getDeprecatedRootReflog :: Int -> Transaction [Reflog.Entry CausalHashId Text]
getDeprecatedRootReflog :: Int -> Transaction [Entry CausalHashId Text]
getDeprecatedRootReflog Int
numEntries =
  Sql -> Transaction [Entry CausalHashId Text]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT time, from_root_causal_id, to_root_causal_id, reason
      FROM reflog
      ORDER BY time DESC
      LIMIT :numEntries
    |]

appendProjectBranchReflog :: ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
appendProjectBranchReflog :: Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
appendProjectBranchReflog Entry ProjectId ProjectBranchId CausalHashId
entry =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO project_branch_reflog (project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason)
      VALUES (@entry, @, @, @, @, @)
    |]

-- | Get x number of entries from the project reflog for the provided project
getProjectReflog :: Int -> ProjectId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getProjectReflog :: Int
-> ProjectId
-> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
getProjectReflog Int
numEntries ProjectId
projectId =
  Sql -> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
      FROM project_branch_reflog
      WHERE project_id = :projectId
      ORDER BY
        time DESC,
        -- Strictly for breaking ties in transcripts with the same time,
        -- this will break ties in the correct order, sorting later inserted rows first.
        ROWID DESC
      LIMIT :numEntries
    |]

-- | Get x number of entries from the project reflog for the provided branch.
getProjectBranchReflog :: Int -> ProjectBranchId -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getProjectBranchReflog :: Int
-> ProjectBranchId
-> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
getProjectBranchReflog Int
numEntries ProjectBranchId
projectBranchId =
  Sql -> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
      FROM project_branch_reflog
      WHERE project_branch_id = :projectBranchId
      ORDER BY
        time DESC,
        -- Strictly for breaking ties in transcripts with the same time,
        -- this will break ties in the correct order, sorting later inserted rows first.
        ROWID DESC
      LIMIT :numEntries
    |]

-- | Get x number of entries from the global reflog spanning all projects
getGlobalReflog :: Int -> Transaction [ProjectReflog.Entry ProjectId ProjectBranchId CausalHashId]
getGlobalReflog :: Int -> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
getGlobalReflog Int
numEntries =
  Sql -> Transaction [Entry ProjectId ProjectBranchId CausalHashId]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT project_id, project_branch_id, time, from_root_causal_id, to_root_causal_id, reason
      FROM project_branch_reflog
      ORDER BY
        time DESC,
        -- Strictly for breaking ties in transcripts with the same time,
        -- this will break ties in the correct order, sorting later inserted rows first.
        ROWID DESC
      LIMIT :numEntries
    |]

-- | Does a project exist with this id?
projectExists :: ProjectId -> Transaction Bool
projectExists :: ProjectId -> Transaction Bool
projectExists ProjectId
projectId =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM project
        WHERE id = :projectId
      )
    |]

-- | Check if any projects exist
doProjectsExist :: Transaction Bool
doProjectsExist :: Transaction Bool
doProjectsExist =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql| SELECT EXISTS (SELECT 1 FROM project) |]

-- | Does a project exist by this name?
projectExistsByName :: ProjectName -> Transaction Bool
projectExistsByName :: ProjectName -> Transaction Bool
projectExistsByName ProjectName
name =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT EXISTS (
        SELECT 1
        FROM project
        WHERE name = :name
      )
    |]

loadProject :: ProjectId -> Transaction (Maybe Project)
loadProject :: ProjectId -> Transaction (Maybe Project)
loadProject ProjectId
pid = Sql -> Transaction (Maybe Project)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow (ProjectId -> Sql
loadProjectSql ProjectId
pid)

expectProject :: ProjectId -> Transaction Project
expectProject :: ProjectId -> Transaction Project
expectProject ProjectId
pid = Sql -> Transaction Project
forall a. (FromRow a, HasCallStack) => Sql -> Transaction a
queryOneRow (ProjectId -> Sql
loadProjectSql ProjectId
pid)

loadProjectSql :: ProjectId -> Sql
loadProjectSql :: ProjectId -> Sql
loadProjectSql ProjectId
pid =
  [sql|
    SELECT
      id,
      name
    FROM
      project
    WHERE
      id = :pid
  |]

loadProjectByName :: ProjectName -> Transaction (Maybe Project)
loadProjectByName :: ProjectName -> Transaction (Maybe Project)
loadProjectByName ProjectName
name =
  Sql -> Transaction (Maybe Project)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        id,
        name
      FROM
        project
      WHERE
        name = :name
    |]

-- | Load all projects.
loadAllProjects :: Transaction [Project]
loadAllProjects :: Transaction [Project]
loadAllProjects =
  Sql -> Transaction [Project]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT id, name
      FROM project
      ORDER BY name ASC
    |]

-- | Load all projects whose name matches a prefix.
loadAllProjectsBeginningWith :: Maybe Text -> Transaction [Project]
loadAllProjectsBeginningWith :: Maybe Text -> Transaction [Project]
loadAllProjectsBeginningWith Maybe Text
mayPrefix = do
  let prefixGlob :: Text
prefixGlob = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" (\Text
prefix -> (Text -> Text
globEscape Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*")) Maybe Text
mayPrefix
  Sql -> Transaction [Project]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
        SELECT id, name
        FROM project
        WHERE name GLOB :prefixGlob
        ORDER BY name ASC
      |]

-- | Insert a `project` row.
insertProject :: ProjectId -> ProjectName -> Transaction ()
insertProject :: ProjectId -> ProjectName -> Transaction ()
insertProject ProjectId
uuid ProjectName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO project (id, name)
      VALUES (:uuid, :name)
    |]

-- | Rename a `project` row.
--
-- Precondition: the new name is available.
renameProject :: ProjectId -> ProjectName -> Transaction ()
renameProject :: ProjectId -> ProjectName -> Transaction ()
renameProject ProjectId
projectId ProjectName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE project
      SET name = :name
      WHERE id = :projectId
    |]

-- | Does a project branch exist by this name?
projectBranchExistsByName :: ProjectId -> ProjectBranchName -> Transaction Bool
projectBranchExistsByName :: ProjectId -> ProjectBranchName -> Transaction Bool
projectBranchExistsByName ProjectId
projectId ProjectBranchName
name =
  Sql -> Transaction Bool
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT
        EXISTS (
          SELECT
            1
          FROM
            project_branch
          WHERE
            project_id = :projectId
            AND name = :name)
    |]

loadProjectBranch :: ProjectId -> ProjectBranchId -> Transaction (Maybe ProjectBranch)
loadProjectBranch :: ProjectId -> ProjectBranchId -> Transaction (Maybe ProjectBranch)
loadProjectBranch ProjectId
projectId ProjectBranchId
branchId =
  Sql -> Transaction (Maybe ProjectBranch)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow (ProjectId -> ProjectBranchId -> Sql
loadProjectBranchSql ProjectId
projectId ProjectBranchId
branchId)

expectProjectBranch :: ProjectId -> ProjectBranchId -> Transaction ProjectBranch
expectProjectBranch :: ProjectId -> ProjectBranchId -> Transaction ProjectBranch
expectProjectBranch ProjectId
projectId ProjectBranchId
branchId =
  Sql -> Transaction ProjectBranch
forall a. (FromRow a, HasCallStack) => Sql -> Transaction a
queryOneRow (ProjectId -> ProjectBranchId -> Sql
loadProjectBranchSql ProjectId
projectId ProjectBranchId
branchId)

loadProjectBranchSql :: ProjectId -> ProjectBranchId -> Sql
loadProjectBranchSql :: ProjectId -> ProjectBranchId -> Sql
loadProjectBranchSql ProjectId
projectId ProjectBranchId
branchId =
  [sql|
    SELECT
      project_branch.project_id,
      project_branch.branch_id,
      project_branch.name,
      project_branch_parent.parent_branch_id
    FROM
      project_branch
      LEFT JOIN project_branch_parent ON project_branch.project_id = project_branch_parent.project_id
        AND project_branch.branch_id = project_branch_parent.branch_id
    WHERE
      project_branch.project_id = :projectId
      AND project_branch.branch_id = :branchId
  |]

loadProjectBranchByName :: ProjectId -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
loadProjectBranchByName :: ProjectId -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
loadProjectBranchByName ProjectId
projectId ProjectBranchName
name =
  Sql -> Transaction (Maybe ProjectBranch)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        project_branch.project_id,
        project_branch.branch_id,
        project_branch.name,
        project_branch_parent.parent_branch_id
      FROM
        project_branch
        LEFT JOIN project_branch_parent ON project_branch.project_id = project_branch_parent.project_id
          AND project_branch.branch_id = project_branch_parent.branch_id
      WHERE
        project_branch.project_id = :projectId
        AND project_branch.name = :name
    |]

loadProjectBranchByNames :: ProjectName -> ProjectBranchName -> Transaction (Maybe ProjectBranch)
loadProjectBranchByNames :: ProjectName
-> ProjectBranchName -> Transaction (Maybe ProjectBranch)
loadProjectBranchByNames ProjectName
projectName ProjectBranchName
branchName =
  Sql -> Transaction (Maybe ProjectBranch)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        project_branch.project_id,
        project_branch.branch_id,
        project_branch.name,
        project_branch_parent.parent_branch_id
      FROM
        project
        JOIN project_branch ON project.id = project_branch.project_id
        LEFT JOIN project_branch_parent ON project_branch.project_id = project_branch_parent.project_id
          AND project_branch.branch_id = project_branch_parent.branch_id
      WHERE
        project.name = :projectName
        AND project_branch.name = :branchName
    |]

-- | Load all branch id/name pairs in a project whose name matches an optional prefix.
loadAllProjectBranchesBeginningWith :: ProjectId -> Maybe Text -> Transaction [(ProjectBranchId, ProjectBranchName)]
loadAllProjectBranchesBeginningWith :: ProjectId
-> Maybe Text -> Transaction [(ProjectBranchId, ProjectBranchName)]
loadAllProjectBranchesBeginningWith ProjectId
projectId Maybe Text
mayPrefix =
  let prefixGlob :: Text
prefixGlob = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" (\Text
prefix -> (Text -> Text
globEscape Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*")) Maybe Text
mayPrefix
   in Sql -> Transaction [(ProjectBranchId, ProjectBranchName)]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
        [sql|
        SELECT project_branch.branch_id, project_branch.name
        FROM project_branch
        WHERE project_branch.project_id = :projectId
          AND project_branch.name GLOB :prefixGlob
        ORDER BY project_branch.name ASC
      |]

-- | Load ALL project/branch name pairs
-- Useful for autocomplete/fuzzy-finding
loadAllProjectBranchNamePairs :: Transaction [(ProjectAndBranch ProjectName ProjectBranchName, ProjectAndBranch ProjectId ProjectBranchId)]
loadAllProjectBranchNamePairs :: Transaction
  [(ProjectAndBranch ProjectName ProjectBranchName,
    ProjectAndBranch ProjectId ProjectBranchId)]
loadAllProjectBranchNamePairs =
  Sql
-> Transaction
     [(ProjectName, ProjectBranchName, ProjectId, ProjectBranchId)]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT
        project.name,
        project_branch.name,
        project.id,
        project_branch.branch_id
      FROM
        project
        JOIN project_branch ON project.id = project_branch.project_id
      ORDER BY project.name ASC, project_branch.name ASC
    |]
    Transaction
  [(ProjectName, ProjectBranchName, ProjectId, ProjectBranchId)]
-> ([(ProjectName, ProjectBranchName, ProjectId, ProjectBranchId)]
    -> [(ProjectAndBranch ProjectName ProjectBranchName,
         ProjectAndBranch ProjectId ProjectBranchId)])
-> Transaction
     [(ProjectAndBranch ProjectName ProjectBranchName,
       ProjectAndBranch ProjectId ProjectBranchId)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((ProjectName, ProjectBranchName, ProjectId, ProjectBranchId)
 -> (ProjectAndBranch ProjectName ProjectBranchName,
     ProjectAndBranch ProjectId ProjectBranchId))
-> [(ProjectName, ProjectBranchName, ProjectId, ProjectBranchId)]
-> [(ProjectAndBranch ProjectName ProjectBranchName,
     ProjectAndBranch ProjectId ProjectBranchId)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \(ProjectName
projectName, ProjectBranchName
branchName, ProjectId
projectId, ProjectBranchId
branchId) ->
      ( ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
projectName ProjectBranchName
branchName,
        ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectId
projectId ProjectBranchId
branchId
      )

-- | Load info about all branches in a project, for display by the @branches@ command.
--
-- Each branch name maps to a possibly-empty collection of associated remote branches.
loadAllProjectBranchInfo :: ProjectId -> Transaction (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
loadAllProjectBranchInfo :: ProjectId
-> Transaction
     (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
loadAllProjectBranchInfo ProjectId
projectId =
  ([(ProjectBranchName, Maybe URI, Maybe ProjectName,
   Maybe ProjectBranchName)]
 -> Map
      ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
-> Transaction
     [(ProjectBranchName, Maybe URI, Maybe ProjectName,
       Maybe ProjectBranchName)]
-> Transaction
     (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ProjectBranchName, Maybe URI, Maybe ProjectName,
  Maybe ProjectBranchName)]
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
postprocess (Transaction
   [(ProjectBranchName, Maybe URI, Maybe ProjectName,
     Maybe ProjectBranchName)]
 -> Transaction
      (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))))
-> Transaction
     [(ProjectBranchName, Maybe URI, Maybe ProjectName,
       Maybe ProjectBranchName)]
-> Transaction
     (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
forall a b. (a -> b) -> a -> b
$
    Sql
-> Transaction
     [(ProjectBranchName, Maybe URI, Maybe ProjectName,
       Maybe ProjectBranchName)]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
        SELECT
          pb.name AS local_branch_name,
          rpb.host AS host,
          rp.name AS remote_project_name,
          rpb.name AS remote_branch_name
        FROM project_branch AS pb
        LEFT JOIN project_branch_remote_mapping AS pbrm ON pb.project_id = pbrm.local_project_id
          AND pb.branch_id = pbrm.local_branch_id
        LEFT JOIN remote_project AS rp ON pbrm.remote_project_id = rp.id
        LEFT JOIN remote_project_branch AS rpb ON pbrm.remote_project_id = rpb.project_id
          AND pbrm.remote_branch_id = rpb.branch_id
        WHERE pb.project_id = :projectId
        ORDER BY local_branch_name ASC, host ASC, remote_project_name ASC, remote_branch_name ASC
      |]
  where
    -- Each input tuple is the local branch name, plus either:
    --
    --   1. One of 1+ (host, remote project, remote branch) triplets, indicating this local branch is associated with 1+
    --      remote branches (with distinct hosts)
    --
    --      *or*
    --
    --   2. Three Nothings, indicating this local branch is associated with 0 remote branches.
    postprocess ::
      [(ProjectBranchName, Maybe URI, Maybe ProjectName, Maybe ProjectBranchName)] ->
      Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
    postprocess :: [(ProjectBranchName, Maybe URI, Maybe ProjectName,
  Maybe ProjectBranchName)]
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
postprocess =
      (Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
 -> (ProjectBranchName, Maybe URI, Maybe ProjectName,
     Maybe ProjectBranchName)
 -> Map
      ProjectBranchName (Map URI (ProjectName, ProjectBranchName)))
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
-> [(ProjectBranchName, Maybe URI, Maybe ProjectName,
     Maybe ProjectBranchName)]
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
-> (ProjectBranchName, Maybe URI, Maybe ProjectName,
    Maybe ProjectBranchName)
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
f Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
forall k a. Map k a
Map.empty
      where
        f ::
          Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName)) ->
          (ProjectBranchName, Maybe URI, Maybe ProjectName, Maybe ProjectBranchName) ->
          Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
        f :: Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
-> (ProjectBranchName, Maybe URI, Maybe ProjectName,
    Maybe ProjectBranchName)
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
f !Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
acc (ProjectBranchName
localBranchName, Maybe URI
maybeHost, Maybe ProjectName
maybeRemoteProjectName, Maybe ProjectBranchName
maybeRemoteBranchName) =
          (Maybe (Map URI (ProjectName, ProjectBranchName))
 -> Map URI (ProjectName, ProjectBranchName))
-> ProjectBranchName
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
-> Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
forall k v. Ord k => (Maybe v -> v) -> k -> Map k v -> Map k v
Map.upsert Maybe (Map URI (ProjectName, ProjectBranchName))
-> Map URI (ProjectName, ProjectBranchName)
g ProjectBranchName
localBranchName Map ProjectBranchName (Map URI (ProjectName, ProjectBranchName))
acc
          where
            g :: Maybe (Map URI (ProjectName, ProjectBranchName)) -> Map URI (ProjectName, ProjectBranchName)
            g :: Maybe (Map URI (ProjectName, ProjectBranchName))
-> Map URI (ProjectName, ProjectBranchName)
g Maybe (Map URI (ProjectName, ProjectBranchName))
maybeRemoteBranches =
              case (Maybe URI
maybeHost, Maybe ProjectName
maybeRemoteProjectName, Maybe ProjectBranchName
maybeRemoteBranchName) of
                -- One more remote (host, project name, branch name) tuple to collect, either as a singleton map
                -- (because it's the first we've seen for this local branch), or as a map insert (because it's not).
                (Just URI
host, Just ProjectName
remoteProjectName, Just ProjectBranchName
remoteBranchName) ->
                  case Maybe (Map URI (ProjectName, ProjectBranchName))
maybeRemoteBranches of
                    Maybe (Map URI (ProjectName, ProjectBranchName))
Nothing -> URI
-> (ProjectName, ProjectBranchName)
-> Map URI (ProjectName, ProjectBranchName)
forall k a. k -> a -> Map k a
Map.singleton URI
host (ProjectName
remoteProjectName, ProjectBranchName
remoteBranchName)
                    Just Map URI (ProjectName, ProjectBranchName)
remoteBranches -> URI
-> (ProjectName, ProjectBranchName)
-> Map URI (ProjectName, ProjectBranchName)
-> Map URI (ProjectName, ProjectBranchName)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert URI
host (ProjectName
remoteProjectName, ProjectBranchName
remoteBranchName) Map URI (ProjectName, ProjectBranchName)
remoteBranches
                -- We know these three are all Nothing (this local branch has no associated remote branches)
                -- No need to pattern match on maybeRemoteBranches; we know it's Nothing, too
                (Maybe URI, Maybe ProjectName, Maybe ProjectBranchName)
_ -> Map URI (ProjectName, ProjectBranchName)
forall k a. Map k a
Map.empty

loadProjectAndBranchNames :: ProjectId -> ProjectBranchId -> Transaction (Maybe (ProjectName, ProjectBranchName))
loadProjectAndBranchNames :: ProjectId
-> ProjectBranchId
-> Transaction (Maybe (ProjectName, ProjectBranchName))
loadProjectAndBranchNames ProjectId
projectId ProjectBranchId
branchId =
  Sql -> Transaction (Maybe (ProjectName, ProjectBranchName))
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        project.name,
        project_branch.name
      FROM
        project
        JOIN project_branch ON project.id = project_branch.project_id
      WHERE
        project_branch.project_id = :projectId
        AND project_branch.branch_id = :branchId
    |]

-- | Insert a project branch.
insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction ()
insertProjectBranch :: HasCallStack =>
Text -> CausalHashId -> ProjectBranch -> Transaction ()
insertProjectBranch Text
description CausalHashId
causalHashId (ProjectBranch ProjectId
projectId ProjectBranchId
branchId ProjectBranchName
branchName Maybe ProjectBranchId
maybeParentBranchId) = do
  -- Ensure we never point at a causal we don't have the branch for.
  BranchObjectId
_ <- CausalHashId -> Transaction BranchObjectId
expectBranchObjectIdByCausalHashId CausalHashId
causalHashId

  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
        VALUES (:projectId, :branchId, :branchName, :causalHashId)
    |]
  Maybe ProjectBranchId
-> (ProjectBranchId -> Transaction ()) -> Transaction ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProjectBranchId
maybeParentBranchId \ProjectBranchId
parentBranchId ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        INSERT INTO project_branch_parent (project_id, parent_branch_id, branch_id)
          VALUES (:projectId, :parentBranchId, :branchId)
      |]
  UTCTime
time <- IO UTCTime -> Transaction UTCTime
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO UTCTime -> Transaction UTCTime)
-> IO UTCTime -> Transaction UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
Time.getCurrentTime
  Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
appendProjectBranchReflog (Entry ProjectId ProjectBranchId CausalHashId -> Transaction ())
-> Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
forall a b. (a -> b) -> a -> b
$
    ProjectReflog.Entry
      { $sel:project:Entry :: ProjectId
project = ProjectId
projectId,
        $sel:branch:Entry :: ProjectBranchId
branch = ProjectBranchId
branchId,
        UTCTime
time :: UTCTime
$sel:time:Entry :: UTCTime
time,
        $sel:fromRootCausalHash:Entry :: Maybe CausalHashId
fromRootCausalHash = Maybe CausalHashId
forall a. Maybe a
Nothing,
        $sel:toRootCausalHash:Entry :: CausalHashId
toRootCausalHash = CausalHashId
causalHashId,
        $sel:reason:Entry :: Text
reason = Text
description
      }

-- | Rename a project branch.
--
-- Precondition: the new name is available.
renameProjectBranch :: ProjectId -> ProjectBranchId -> ProjectBranchName -> Transaction ()
renameProjectBranch :: ProjectId -> ProjectBranchId -> ProjectBranchName -> Transaction ()
renameProjectBranch ProjectId
projectId ProjectBranchId
branchId ProjectBranchName
branchName = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE project_branch
      SET name = :branchName
      WHERE project_id = :projectId
        AND branch_id = :branchId
    |]

deleteProject :: ProjectId -> Transaction ()
deleteProject :: ProjectId -> Transaction ()
deleteProject ProjectId
projectId = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project_branch_remote_mapping
      WHERE local_project_id = :projectId
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project_branch_parent
      WHERE project_id = :projectId
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project_branch
      WHERE project_id = :projectId
    |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project
      WHERE id = :projectId
    |]

-- | Delete a project branch.
--
-- Re-parenting happens in the obvious way:
--
--   Before:
--
--     main <- topic <- topic2
--
--  After deleting `topic`:
--
--    main <- topic2
deleteProjectBranch :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction ()
deleteProjectBranch :: HasCallStack => ProjectId -> ProjectBranchId -> Transaction ()
deleteProjectBranch ProjectId
projectId ProjectBranchId
branchId = do
  Maybe ProjectBranchId
maybeParentBranchId :: Maybe ProjectBranchId <-
    Sql -> Transaction (Maybe ProjectBranchId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol
      [sql|
        SELECT parent_branch_id
        FROM project_branch_parent
        WHERE project_id = :projectId AND branch_id = :branchId
      |]
  -- If the branch being deleted has a parent, then reparent its children. Otherwise, the 'on delete cascade' foreign
  -- key from `project_branch_parent` will take care of deleting its children's parent entries.
  Maybe ProjectBranchId
-> (ProjectBranchId -> Transaction ()) -> Transaction ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProjectBranchId
maybeParentBranchId \ProjectBranchId
parentBranchId ->
    HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
      [sql|
        UPDATE project_branch_parent
        SET parent_branch_id = :parentBranchId
        WHERE project_id = :projectId AND parent_branch_id = :branchId
      |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project_branch
      WHERE project_id = :projectId AND branch_id = :branchId
    |]

-- | Set project branch HEAD
setProjectBranchHead :: Text -> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction ()
setProjectBranchHead :: Text
-> ProjectId -> ProjectBranchId -> CausalHashId -> Transaction ()
setProjectBranchHead Text
description ProjectId
projectId ProjectBranchId
branchId CausalHashId
causalHashId = do
  -- Ensure we never point at a causal we don't have the branch for.
  BranchObjectId
_ <- CausalHashId -> Transaction BranchObjectId
expectBranchObjectIdByCausalHashId CausalHashId
causalHashId
  CausalHashId
oldRootCausalHashId <- HasCallStack =>
ProjectId -> ProjectBranchId -> Transaction CausalHashId
ProjectId -> ProjectBranchId -> Transaction CausalHashId
expectProjectBranchHead ProjectId
projectId ProjectBranchId
branchId
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE project_branch
      SET causal_hash_id = :causalHashId
      WHERE project_id = :projectId AND branch_id = :branchId
    |]
  UTCTime
time <- IO UTCTime -> Transaction UTCTime
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO UTCTime -> Transaction UTCTime)
-> IO UTCTime -> Transaction UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
Time.getCurrentTime
  Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
appendProjectBranchReflog (Entry ProjectId ProjectBranchId CausalHashId -> Transaction ())
-> Entry ProjectId ProjectBranchId CausalHashId -> Transaction ()
forall a b. (a -> b) -> a -> b
$
    ProjectReflog.Entry
      { $sel:project:Entry :: ProjectId
project = ProjectId
projectId,
        $sel:branch:Entry :: ProjectBranchId
branch = ProjectBranchId
branchId,
        $sel:time:Entry :: UTCTime
time = UTCTime
time,
        $sel:fromRootCausalHash:Entry :: Maybe CausalHashId
fromRootCausalHash = CausalHashId -> Maybe CausalHashId
forall a. a -> Maybe a
Just CausalHashId
oldRootCausalHashId,
        $sel:toRootCausalHash:Entry :: CausalHashId
toRootCausalHash = CausalHashId
causalHashId,
        $sel:reason:Entry :: Text
reason = Text
description
      }

expectProjectBranchHead :: (HasCallStack) => ProjectId -> ProjectBranchId -> Transaction CausalHashId
expectProjectBranchHead :: HasCallStack =>
ProjectId -> ProjectBranchId -> Transaction CausalHashId
expectProjectBranchHead ProjectId
projectId ProjectBranchId
branchId =
  Sql -> Transaction CausalHashId
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT causal_hash_id
      FROM project_branch
      WHERE project_id = :projectId AND branch_id = :branchId
    |]

data LoadRemoteBranchFlag
  = IncludeSelfRemote
  | ExcludeSelfRemote
  deriving stock (Int -> LoadRemoteBranchFlag -> ShowS
[LoadRemoteBranchFlag] -> ShowS
LoadRemoteBranchFlag -> [Char]
(Int -> LoadRemoteBranchFlag -> ShowS)
-> (LoadRemoteBranchFlag -> [Char])
-> ([LoadRemoteBranchFlag] -> ShowS)
-> Show LoadRemoteBranchFlag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadRemoteBranchFlag -> ShowS
showsPrec :: Int -> LoadRemoteBranchFlag -> ShowS
$cshow :: LoadRemoteBranchFlag -> [Char]
show :: LoadRemoteBranchFlag -> [Char]
$cshowList :: [LoadRemoteBranchFlag] -> ShowS
showList :: [LoadRemoteBranchFlag] -> ShowS
Show, LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool
(LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool)
-> (LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool)
-> Eq LoadRemoteBranchFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool
== :: LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool
$c/= :: LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool
/= :: LoadRemoteBranchFlag -> LoadRemoteBranchFlag -> Bool
Eq)

-- | Determine the remote mapping for a local project/branch by
-- looking at the mapping for the given pair, then falling back to the
-- project of the nearest ancestor.
loadRemoteProjectBranch ::
  ProjectId ->
  URI ->
  ProjectBranchId ->
  Transaction (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
loadRemoteProjectBranch :: ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
loadRemoteProjectBranch ProjectId
p URI
u ProjectBranchId
b = do
  LoadRemoteBranchFlag
-> ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
loadRemoteProjectBranchGen LoadRemoteBranchFlag
IncludeSelfRemote ProjectId
p URI
u ProjectBranchId
b Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
-> (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64)
    -> Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
-> Transaction
     (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((RemoteProjectId, RemoteProjectBranchId, Int64)
 -> (RemoteProjectId, Maybe RemoteProjectBranchId))
-> Maybe (RemoteProjectId, RemoteProjectBranchId, Int64)
-> Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RemoteProjectId, RemoteProjectBranchId, Int64)
-> (RemoteProjectId, Maybe RemoteProjectBranchId)
forall {a} {a}. (a, a, Int64) -> (a, Maybe a)
fixup
  where
    -- If the depth is 0 then the local project/branch we provided has
    -- a remote mapping. Otherwise we found some ancestor's remote
    -- mapping and we only wish to retain the project portion.
    fixup :: (a, a, Int64) -> (a, Maybe a)
fixup = \case
      (a
project, a
branch, Int64
depth) -> case Int64
depth of
        Int64
0 -> (a
project, a -> Maybe a
forall a. a -> Maybe a
Just a
branch)
        Int64
_ -> (a
project, Maybe a
forall a. Maybe a
Nothing)

-- | Load the default merge target for a local branch (i.e. The nearest
-- ancestor's remote mapping)
loadDefaultMergeTargetForLocalProjectBranch ::
  ProjectId ->
  URI ->
  ProjectBranchId ->
  Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId))
loadDefaultMergeTargetForLocalProjectBranch :: ProjectId
-> URI
-> ProjectBranchId
-> Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId))
loadDefaultMergeTargetForLocalProjectBranch ProjectId
p URI
u ProjectBranchId
b = do
  LoadRemoteBranchFlag
-> ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
loadRemoteProjectBranchGen LoadRemoteBranchFlag
ExcludeSelfRemote ProjectId
p URI
u ProjectBranchId
b Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
-> (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64)
    -> Maybe (RemoteProjectId, RemoteProjectBranchId))
-> Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((RemoteProjectId, RemoteProjectBranchId, Int64)
 -> (RemoteProjectId, RemoteProjectBranchId))
-> Maybe (RemoteProjectId, RemoteProjectBranchId, Int64)
-> Maybe (RemoteProjectId, RemoteProjectBranchId)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RemoteProjectId, RemoteProjectBranchId, Int64)
-> (RemoteProjectId, RemoteProjectBranchId)
forall {a} {b} {c}. (a, b, c) -> (a, b)
fixup
  where
    fixup :: (a, b, c) -> (a, b)
fixup = \case
      (a
project, b
branch, c
_) -> (a
project, b
branch)

-- Parameterized query for finding the remote mapping for a branch and
-- the default merge target for a branch.
loadRemoteProjectBranchGen ::
  LoadRemoteBranchFlag ->
  ProjectId ->
  URI ->
  ProjectBranchId ->
  Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
loadRemoteProjectBranchGen :: LoadRemoteBranchFlag
-> ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
loadRemoteProjectBranchGen LoadRemoteBranchFlag
loadRemoteBranchFlag ProjectId
pid URI
remoteUri ProjectBranchId
bid =
  Sql
-> Transaction
     (Maybe (RemoteProjectId, RemoteProjectBranchId, Int64))
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow Sql
theSql
  where
    theSql :: Sql
theSql =
      [sql|
        WITH RECURSIVE t AS (
          SELECT
            pb.project_id,
            pb.branch_id,
            pbp.parent_branch_id,
            pbrm.remote_project_id,
            pbrm.remote_branch_id,
            0 AS depth
          FROM
            project_branch AS pb
            LEFT JOIN project_branch_parent AS pbp USING (project_id, branch_id)
            LEFT JOIN project_branch_remote_mapping AS pbrm ON pbrm.local_project_id = pb.project_id
              AND pbrm.local_branch_id = pb.branch_id
              AND pbrm.remote_host = :remoteUri
          WHERE
            pb.project_id = :pid
            AND pb.branch_id = :bid
          UNION ALL
          SELECT
            t.project_id,
            t.parent_branch_id,
            pbp.parent_branch_id,
            pbrm.remote_project_id,
            pbrm.remote_branch_id,
            t.depth + 1
          FROM
            t
          LEFT JOIN project_branch_parent AS pbp ON pbp.project_id = t.project_id
            AND pbp.branch_id = t.parent_branch_id
          LEFT JOIN project_branch_remote_mapping AS pbrm ON pbrm.local_project_id = t.project_id
          AND pbrm.local_branch_id = t.parent_branch_id
          AND pbrm.remote_host = :remoteUri
          WHERE t.parent_branch_id IS NOT NULL
        )
        SELECT
          remote_project_id,
          remote_branch_id,
          depth
        FROM
          t
        $whereClause
        ORDER BY
          depth
        LIMIT 1
      |]

    whereClause :: Sql
    whereClause :: Sql
whereClause =
      let clauses :: Sql
clauses =
            (Sql -> Sql -> Sql) -> Sql -> [Sql] -> Sql
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
              (\Sql
a Sql
b -> [sql| $a AND $b |])
              [sql| TRUE |]
              [ [sql| remote_project_id IS NOT NULL |],
                Sql
selfRemoteFilter
              ]
       in [sql| WHERE $clauses |]

    selfRemoteFilter :: Sql
selfRemoteFilter = case LoadRemoteBranchFlag
loadRemoteBranchFlag of
      LoadRemoteBranchFlag
IncludeSelfRemote -> [sql| TRUE |]
      LoadRemoteBranchFlag
ExcludeSelfRemote -> [sql| depth > 0 |]

loadRemoteProject :: RemoteProjectId -> URI -> Transaction (Maybe RemoteProject)
loadRemoteProject :: RemoteProjectId -> URI -> Transaction (Maybe RemoteProject)
loadRemoteProject RemoteProjectId
rpid URI
host =
  Sql -> Transaction (Maybe RemoteProject)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        id,
        host,
        name
      FROM
        remote_project
      WHERE
        id = :rpid
        and host = :host
    |]

ensureRemoteProject :: RemoteProjectId -> URI -> ProjectName -> Transaction ()
ensureRemoteProject :: RemoteProjectId -> URI -> ProjectName -> Transaction ()
ensureRemoteProject RemoteProjectId
rpid URI
host ProjectName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO remote_project (
        id,
        host,
        name)
      VALUES (
        :rpid,
        :host,
        :name)
      ON CONFLICT (
        id,
        host)
        -- should this update the name instead?
        DO NOTHING
    |]

expectRemoteProjectName :: RemoteProjectId -> URI -> Transaction ProjectName
expectRemoteProjectName :: RemoteProjectId -> URI -> Transaction ProjectName
expectRemoteProjectName RemoteProjectId
projectId URI
host =
  Sql -> Transaction ProjectName
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT
        name
      FROM
        remote_project
      WHERE
        id = :projectId
        AND host = :host
    |]

setRemoteProjectName :: RemoteProjectId -> ProjectName -> Transaction ()
setRemoteProjectName :: RemoteProjectId -> ProjectName -> Transaction ()
setRemoteProjectName RemoteProjectId
rpid ProjectName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE
        remote_project
      SET
        name = :name
      WHERE
        id = :rpid
    |]

loadRemoteBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> Transaction (Maybe RemoteProjectBranch)
loadRemoteBranch :: RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> Transaction (Maybe RemoteProjectBranch)
loadRemoteBranch RemoteProjectId
rpid URI
host RemoteProjectBranchId
rbid =
  Sql -> Transaction (Maybe RemoteProjectBranch)
forall a. (FromRow a, HasCallStack) => Sql -> Transaction (Maybe a)
queryMaybeRow
    [sql|
      SELECT
        project_id,
        branch_id,
        host,
        name
      FROM
        remote_project_branch
      WHERE
        project_id = :rpid
        AND branch_id = :rbid
        AND host = :host
    |]

ensureRemoteProjectBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction ()
ensureRemoteProjectBranch :: RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> ProjectBranchName
-> Transaction ()
ensureRemoteProjectBranch RemoteProjectId
rpid URI
host RemoteProjectBranchId
rbid ProjectBranchName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO remote_project_branch (
        project_id,
        host,
        branch_id,
        name)
      VALUES (
        :rpid,
        :host,
        :rbid,
        :name)
      ON CONFLICT (
        project_id,
        branch_id,
        host)
        -- should this update the name instead?
        DO NOTHING
        |]

expectRemoteProjectBranchName :: URI -> RemoteProjectId -> RemoteProjectBranchId -> Transaction ProjectBranchName
expectRemoteProjectBranchName :: URI
-> RemoteProjectId
-> RemoteProjectBranchId
-> Transaction ProjectBranchName
expectRemoteProjectBranchName URI
host RemoteProjectId
projectId RemoteProjectBranchId
branchId =
  Sql -> Transaction ProjectBranchName
forall a. (FromField a, HasCallStack) => Sql -> Transaction a
queryOneCol
    [sql|
      SELECT
        name
      FROM
        remote_project_branch
      WHERE
        host = :host
        AND project_id = :projectId
        AND branch_id = :branchId
    |]

setRemoteProjectBranchName :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction ()
setRemoteProjectBranchName :: RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> ProjectBranchName
-> Transaction ()
setRemoteProjectBranchName RemoteProjectId
rpid URI
host RemoteProjectBranchId
rbid ProjectBranchName
name =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      UPDATE
        remote_project_branch
      SET
        name = :name
      WHERE
        project_id = :rpid
        AND host = :host
        AND branch_id = :rbid
    |]

insertBranchRemoteMapping ::
  ProjectId ->
  ProjectBranchId ->
  RemoteProjectId ->
  URI ->
  RemoteProjectBranchId ->
  Transaction ()
insertBranchRemoteMapping :: ProjectId
-> ProjectBranchId
-> RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> Transaction ()
insertBranchRemoteMapping ProjectId
pid ProjectBranchId
bid RemoteProjectId
rpid URI
host RemoteProjectBranchId
rbid =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO project_branch_remote_mapping (
        local_project_id,
        local_branch_id,
        remote_project_id,
        remote_branch_id,
        remote_host)
      VALUES (
        :pid,
        :bid,
        :rpid,
        :rbid,
        :host)
        |]

ensureBranchRemoteMapping ::
  ProjectId ->
  ProjectBranchId ->
  RemoteProjectId ->
  URI ->
  RemoteProjectBranchId ->
  Transaction ()
ensureBranchRemoteMapping :: ProjectId
-> ProjectBranchId
-> RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> Transaction ()
ensureBranchRemoteMapping ProjectId
pid ProjectBranchId
bid RemoteProjectId
rpid URI
host RemoteProjectBranchId
rbid =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO project_branch_remote_mapping (
        local_project_id,
        local_branch_id,
        remote_project_id,
        remote_branch_id,
        remote_host)
      VALUES (
        :pid,
        :bid,
        :rpid,
        :rbid,
        :host)
      ON CONFLICT (
        local_project_id,
        local_branch_id,
        remote_host)
        DO NOTHING
    |]

deleteBranchRemoteMapping ::
  ProjectId ->
  ProjectBranchId ->
  URI ->
  Transaction ()
deleteBranchRemoteMapping :: ProjectId -> ProjectBranchId -> URI -> Transaction ()
deleteBranchRemoteMapping ProjectId
pid ProjectBranchId
bid URI
host =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      DELETE FROM project_branch_remote_mapping
      WHERE local_project_id = :pid
        AND local_branch_id = :bid
        AND remote_host = :host
    |]

-- | Convert reversed name segments into glob for searching based on suffix
--
-- >>> toSuffixGlob ("foo" NonEmpty.:| ["bar"])
-- "foo.bar.*"
toSuffixGlob :: ReversedName -> Text
toSuffixGlob :: ReversedName -> Text
toSuffixGlob ReversedName
suffix = Text -> Text
globEscape (Text -> [Text] -> Text
Text.intercalate Text
"." (forall target source. From source target => source -> target
into @[Text] ReversedName
suffix)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".*"

-- | Convert reversed segments into the DB representation of a reversed_name.
--
-- >>> toReversedName (NonEmpty.fromList ["foo", "bar"])
-- "foo.bar."
toReversedName :: ReversedName -> Text
toReversedName :: ReversedName -> Text
toReversedName ReversedName
revSegs = Text -> [Text] -> Text
Text.intercalate Text
"." (forall target source. From source target => source -> target
into @[Text] ReversedName
revSegs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | Convert a namespace into the appropriate glob for searching within that namespace
--
-- >>> toNamespaceGlob "foo.bar"
-- "foo.bar.*"
--
-- >>> toNamespaceGlob ""
-- "*"
toNamespaceGlob :: PathSegments -> Text
toNamespaceGlob :: PathSegments -> Text
toNamespaceGlob = \case
  PathSegments [] -> Text
"*"
  PathSegments
namespace -> Text -> Text
globEscape (PathSegments -> Text
pathSegmentsToText PathSegments
namespace) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".*"

-- | Thrown if we try to get the segments of an empty name, shouldn't ever happen since empty names
-- are invalid.
data EmptyName = EmptyName String
  deriving stock (EmptyName -> EmptyName -> Bool
(EmptyName -> EmptyName -> Bool)
-> (EmptyName -> EmptyName -> Bool) -> Eq EmptyName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EmptyName -> EmptyName -> Bool
== :: EmptyName -> EmptyName -> Bool
$c/= :: EmptyName -> EmptyName -> Bool
/= :: EmptyName -> EmptyName -> Bool
Eq, Int -> EmptyName -> ShowS
[EmptyName] -> ShowS
EmptyName -> [Char]
(Int -> EmptyName -> ShowS)
-> (EmptyName -> [Char])
-> ([EmptyName] -> ShowS)
-> Show EmptyName
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmptyName -> ShowS
showsPrec :: Int -> EmptyName -> ShowS
$cshow :: EmptyName -> [Char]
show :: EmptyName -> [Char]
$cshowList :: [EmptyName] -> ShowS
showList :: [EmptyName] -> ShowS
Show)
  deriving anyclass (Show EmptyName
Typeable EmptyName
(Show EmptyName, Typeable EmptyName) =>
SqliteExceptionReason EmptyName
forall e. (Show e, Typeable e) => SqliteExceptionReason e
SqliteExceptionReason)

-- | Convert a reversed name into reversed segments.
--
-- >>> reversedNameToReversedSegments "foo.bar."
-- Right ("foo" :| ["bar"])
reversedNameToReversedSegments :: (HasCallStack) => Text -> Either EmptyName ReversedName
reversedNameToReversedSegments :: HasCallStack => Text -> Either EmptyName ReversedName
reversedNameToReversedSegments Text
txt =
  Text
txt
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"."
    -- Names have a trailing dot, so we need to drop the last empty segment
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [Text] -> [Text]
forall a. [a] -> [a]
List.dropEnd1
    [Text]
-> ([Text] -> Maybe (NonEmpty Text)) -> Maybe (NonEmpty Text)
forall a b. a -> (a -> b) -> b
& [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty
    Maybe (NonEmpty Text)
-> (Maybe (NonEmpty Text) -> Either EmptyName ReversedName)
-> Either EmptyName ReversedName
forall a b. a -> (a -> b) -> b
& Either EmptyName ReversedName
-> (NonEmpty Text -> Either EmptyName ReversedName)
-> Maybe (NonEmpty Text)
-> Either EmptyName ReversedName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EmptyName -> Either EmptyName ReversedName
forall a b. a -> Either a b
Left ([Char] -> EmptyName
EmptyName ([Char] -> EmptyName) -> [Char] -> EmptyName
forall a b. (a -> b) -> a -> b
$ CallStack -> [Char]
forall a. Show a => a -> [Char]
show CallStack
HasCallStack => CallStack
callStack)) (ReversedName -> Either EmptyName ReversedName
forall a b. b -> Either a b
Right (ReversedName -> Either EmptyName ReversedName)
-> (NonEmpty Text -> ReversedName)
-> NonEmpty Text
-> Either EmptyName ReversedName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @ReversedName)

setMostRecentBranch :: ProjectId -> ProjectBranchId -> Transaction ()
setMostRecentBranch :: ProjectId -> ProjectBranchId -> Transaction ()
setMostRecentBranch ProjectId
projectId ProjectBranchId
branchId =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO most_recent_branch (
        project_id,
        branch_id)
      VALUES (
        :projectId,
        :branchId)
      ON CONFLICT
        DO UPDATE SET
          project_id = excluded.project_id,
          branch_id = excluded.branch_id
  |]

loadMostRecentBranch :: ProjectId -> Transaction (Maybe ProjectBranchId)
loadMostRecentBranch :: ProjectId -> Transaction (Maybe ProjectBranchId)
loadMostRecentBranch ProjectId
projectId =
  Sql -> Transaction (Maybe ProjectBranchId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol
    [sql|
      SELECT
        branch_id
      FROM
        most_recent_branch
      WHERE
        project_id = :projectId
    |]

-- | Searches for all names within the given name lookup which contain the provided list of segments
-- in order.
-- Search is case insensitive.
fuzzySearchTerms :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))]
fuzzySearchTerms :: Bool
-> BranchHashId
-> Int
-> PathSegments
-> [Text]
-> Transaction [NamedRef (TextReferent, Maybe ConstructorType)]
fuzzySearchTerms Bool
includeDependencies BranchHashId
bhId Int
limit PathSegments
namespace [Text]
querySegments = do
  -- Union in the dependencies if required.
  let dependenciesSql :: Sql
dependenciesSql =
        if Bool
includeDependencies
          then
            [sql|
      UNION ALL
        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM name_lookup_mounts mount
          INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE
          mount.parent_root_branch_hash_id = :bhId
          -- We have a pre-condition that the namespace must not be within any of the mounts,
          -- so this is sufficient to determine whether the entire sub-index is within the
          -- required namespace prefix.
          AND mount.mount_path GLOB :namespaceGlob
          AND (mount.mount_path || namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\'
          |]
          else [sql||]
  (NamedRef (TextReferent :. Only (Maybe ConstructorType))
 -> NamedRef (TextReferent, Maybe ConstructorType))
-> [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
-> [NamedRef (TextReferent, Maybe ConstructorType)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
unRow
    ([NamedRef (TextReferent :. Only (Maybe ConstructorType))]
 -> [NamedRef (TextReferent, Maybe ConstructorType)])
-> Transaction
     [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
-> Transaction [NamedRef (TextReferent, Maybe ConstructorType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sql
-> Transaction
     [NamedRef (TextReferent :. Only (Maybe ConstructorType))]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
      [sql|
      SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type
        FROM scoped_term_name_lookup
      WHERE
        root_branch_hash_id = :bhId
        AND namespace GLOB :namespaceGlob
        AND (namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\'
      $dependenciesSql
        LIMIT :limit
    |]
  where
    namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespace
    preparedQuery :: Text
preparedQuery = Char -> [Text] -> Text
prepareFuzzyQuery Char
'\\' [Text]
querySegments
    unRow :: NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType)) -> NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)
    unRow :: NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
unRow = ((TextReferent :. Only (Maybe ConstructorType))
 -> (TextReferent, Maybe ConstructorType))
-> NamedRef (TextReferent :. Only (Maybe ConstructorType))
-> NamedRef (TextReferent, Maybe ConstructorType)
forall a b. (a -> b) -> NamedRef a -> NamedRef b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \(TextReferent
a :. Only Maybe ConstructorType
b) -> (TextReferent
a, Maybe ConstructorType
b)

-- | Searches for all names within the given name lookup which contain the provided list of segments
-- in order.
--
-- Search is case insensitive.
fuzzySearchTypes :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef S.TextReference)]
fuzzySearchTypes :: Bool
-> BranchHashId
-> Int
-> PathSegments
-> [Text]
-> Transaction [NamedRef TextReference]
fuzzySearchTypes Bool
includeDependencies BranchHashId
bhId Int
limit PathSegments
namespace [Text]
querySegments = do
  -- Union in the dependencies if required.
  let dependenciesSql :: Sql
dependenciesSql =
        if Bool
includeDependencies
          then
            [sql|
      UNION ALL
        SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash, reference_component_index
        FROM name_lookup_mounts mount
          INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id
        WHERE
          mount.parent_root_branch_hash_id = :bhId
          -- We have a pre-condition that the namespace must not be within any of the mounts,
          -- so this is sufficient to determine whether the entire sub-index is within the
          -- required namespace prefix.
          AND mount.mount_path GLOB :namespaceGlob
          AND (mount.mount_path || namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\'
          |]
          else [sql||]
  Sql -> Transaction [NamedRef TextReference]
forall a. (FromRow a, HasCallStack) => Sql -> Transaction [a]
queryListRow
    [sql|
      SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index
        FROM scoped_type_name_lookup
      WHERE
        root_branch_hash_id = :bhId
        AND namespace GLOB :namespaceGlob
        AND (namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\'

      $dependenciesSql

        LIMIT :limit
    |]
  where
    namespaceGlob :: Text
namespaceGlob = PathSegments -> Text
toNamespaceGlob PathSegments
namespace
    preparedQuery :: Text
preparedQuery = Char -> [Text] -> Text
prepareFuzzyQuery Char
'\\' [Text]
querySegments

-- | >>> prepareFuzzyQuery ["foo", "bar"]
-- "%foo%bar%"
--
-- >>> prepareFuzzyQuery ["foo", "", "bar"]
-- "%foo%bar%"
--
-- >>> prepareFuzzyQuery ["foo%", "bar "]
-- "%foo\\%%bar%"
prepareFuzzyQuery :: Char -> [Text] -> Text
prepareFuzzyQuery :: Char -> [Text] -> Text
prepareFuzzyQuery Char
escapeChar [Text]
query =
  [Text]
query
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Text -> Text
likeEscape Char
escapeChar (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip)
    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& \[Text]
q -> Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"%" [Text]
q Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

-- fuzzySearchTypes :: Text -> Transaction [NamedRef Reference.TextReference]

data JsonParseFailure = JsonParseFailure
  { JsonParseFailure -> Text
bytes :: !Text,
    JsonParseFailure -> Text
failure :: !Text
  }
  deriving stock (Int -> JsonParseFailure -> ShowS
[JsonParseFailure] -> ShowS
JsonParseFailure -> [Char]
(Int -> JsonParseFailure -> ShowS)
-> (JsonParseFailure -> [Char])
-> ([JsonParseFailure] -> ShowS)
-> Show JsonParseFailure
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonParseFailure -> ShowS
showsPrec :: Int -> JsonParseFailure -> ShowS
$cshow :: JsonParseFailure -> [Char]
show :: JsonParseFailure -> [Char]
$cshowList :: [JsonParseFailure] -> ShowS
showList :: [JsonParseFailure] -> ShowS
Show)
  deriving anyclass (Show JsonParseFailure
Typeable JsonParseFailure
(Show JsonParseFailure, Typeable JsonParseFailure) =>
SqliteExceptionReason JsonParseFailure
forall e. (Show e, Typeable e) => SqliteExceptionReason e
SqliteExceptionReason)

-- | Get the most recent namespace the user has visited.
expectCurrentProjectPath :: (HasCallStack) => Transaction (ProjectId, ProjectBranchId, [NameSegment])
expectCurrentProjectPath :: HasCallStack =>
Transaction (ProjectId, ProjectBranchId, [NameSegment])
expectCurrentProjectPath =
  Sql
-> ((ProjectId, ProjectBranchId, Text)
    -> Either
         JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment]))
-> Transaction (ProjectId, ProjectBranchId, [NameSegment])
forall a e r.
(FromRow a, SqliteExceptionReason e, HasCallStack) =>
Sql -> (a -> Either e r) -> Transaction r
queryOneRowCheck
    [sql|
      SELECT project_id, branch_id, path
      FROM current_project_path
    |]
    (ProjectId, ProjectBranchId, Text)
-> Either
     JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
check
  where
    check :: (ProjectId, ProjectBranchId, Text) -> Either JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
    check :: (ProjectId, ProjectBranchId, Text)
-> Either
     JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
check (ProjectId
projId, ProjectBranchId
branchId, Text
pathText) =
      case ByteString -> Either [Char] [Text]
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecodeStrict (Text -> ByteString
Text.encodeUtf8 Text
pathText) of
        Left [Char]
failure -> JsonParseFailure
-> Either
     JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
forall a b. a -> Either a b
Left JsonParseFailure {$sel:bytes:JsonParseFailure :: Text
bytes = Text
pathText, $sel:failure:JsonParseFailure :: Text
failure = [Char] -> Text
Text.pack [Char]
failure}
        Right [Text]
namespace -> (ProjectId, ProjectBranchId, [NameSegment])
-> Either
     JsonParseFailure (ProjectId, ProjectBranchId, [NameSegment])
forall a b. b -> Either a b
Right (ProjectId
projId, ProjectBranchId
branchId, (Text -> NameSegment) -> [Text] -> [NameSegment]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NameSegment
NameSegment [Text]
namespace)

-- | Set the most recent namespace the user has visited.
setCurrentProjectPath ::
  ProjectId ->
  ProjectBranchId ->
  [NameSegment] ->
  Transaction ()
setCurrentProjectPath :: ProjectId -> ProjectBranchId -> [NameSegment] -> Transaction ()
setCurrentProjectPath ProjectId
projId ProjectBranchId
branchId [NameSegment]
path = do
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql| DELETE FROM current_project_path |]
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO current_project_path(project_id, branch_id, path)
      VALUES (:projId, :branchId, :jsonPath)
    |]
  where
    jsonPath :: Text
    jsonPath :: Text
jsonPath =
      Text -> Text
Text.Lazy.toStrict ([Text] -> Text
forall a. ToJSON a => a -> Text
Aeson.encodeToLazyText ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NameSegment -> Text
NameSegment.toUnescapedText (NameSegment -> Text) -> [NameSegment] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameSegment]
path)

-- | Get the causal hash result from squashing the provided branch hash if we've squashed it
-- at some point in the past.
tryGetSquashResult :: BranchHashId -> Transaction (Maybe CausalHashId)
tryGetSquashResult :: BranchHashId -> Transaction (Maybe CausalHashId)
tryGetSquashResult BranchHashId
bhId = do
  Sql -> Transaction (Maybe CausalHashId)
forall a.
(FromField a, HasCallStack) =>
Sql -> Transaction (Maybe a)
queryMaybeCol
    [sql|
      SELECT
        squashed_causal_hash_id
      FROM
        squash_results
      WHERE
        branch_hash_id = :bhId
    |]

-- | Save the result of running a squash on the provided branch hash id.
saveSquashResult :: BranchHashId -> CausalHashId -> Transaction ()
saveSquashResult :: BranchHashId -> CausalHashId -> Transaction ()
saveSquashResult BranchHashId
bhId CausalHashId
chId =
  HasCallStack => Sql -> Transaction ()
Sql -> Transaction ()
execute
    [sql|
      INSERT INTO squash_results (
        branch_hash_id,
        squashed_causal_hash_id)
      VALUES (
        :bhId,
        :chId
        )
      ON CONFLICT DO NOTHING
    |]