Server-side merge

Postgres.hs

@@ -0,0 +1,41 @@
+-- | Efficiently fetch a Names object for a given set of labeled dependencies.
+module Share.Names.Postgres (namesForReferences) where
+
+import Control.Lens
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Share.Postgres qualified as PG
+import Share.Postgres.NameLookups.Conversions qualified as CV
+import Share.Postgres.NameLookups.Ops qualified as NameLookupOps
+import Share.Postgres.NameLookups.Types (NamesPerspective)
+import Share.Postgres.NameLookups.Types qualified as NameLookups
+import Share.Postgres.Refs.Types
+import Share.Prelude
+import Unison.HashQualifiedPrime qualified as HQ'
+import Unison.LabeledDependency (LabeledDependency)
+import Unison.Name (Name)
+import Unison.Names (Names)
+import Unison.Names qualified as Names
+import Unison.PrettyPrintEnv qualified as PPE
+import Unison.PrettyPrintEnvDecl qualified as PPED
+import Unison.Reference qualified as V1
+import Unison.Referent qualified as V1
+
+namesForReferences :: forall m. (PG.QueryM m) => NamesPerspective -> Set LabeledDependency -> m PPED.PrettyPrintEnvDecl
+namesForReferences namesPerspective refs = do
+  withPGRefs <-
+    Set.toList refs
+      & CV.labeledDependencies1ToPG
+  (termNames, typeNames) <- foldMapM namesForReference withPGRefs
+  pure $ Names.fromTermsAndTypes termNames typeNames
+  where
+    namesForReference :: Either (V1.Referent, PGReferent) (V1.Reference, PGReference) -> m ([(Name, Name, V1.Referent)], [(Name, Name, V1.Reference)])
+    namesForReference = \case
+      Left (ref, pgref) -> do
+        termNames <- fmap (bothMap NameLookups.reversedNameToName) <$> NameLookupOps.termNamesForRefWithinNamespace namesPerspective pgref Nothing
+        let termNames' = termNames <&> \(fqn, suffixed) -> (fqn, ref)
+        pure $ (termNames', [])
+      Right (ref, pgref) -> do
+        typeNames <- fmap (bothMap NameLookups.reversedNameToName) <$> NameLookupOps.typeNamesForRefWithinNamespace namesPerspective pgref Nothing
+        let typeNames' = typeNames <&> \(fqn, suffixed) -> (fqn, ref)
+        pure $ ([], typeNames')

package.yaml

@@ -109,6 +109,7 @@ dependencies:
 - share-auth
 - unison-hashing-v2
 - unison-codebase-sqlite-hashing-v2
+- unison-merge
 - unison-parser-typechecker
 - unison-prelude
 - unison-pretty-printer

share-api.cabal

@@ -42,7 +42,10 @@ library
       Share.IDs
       Share.Metrics
       Share.Monitoring
+      Share.Names.Postgres
       Share.NamespaceDiffs
+      Share.NamespaceDiffs.Types
+      Share.NamespaceDiffs2
       Share.Postgres
       Share.Postgres.Admin
       Share.Postgres.Authorization.Queries
@@ -80,6 +83,7 @@ library
       Share.Postgres.Users.Queries
       Share.Prelude
       Share.Prelude.Orphans
+      Share.PrettyPrintEnvDecl.Postgres
       Share.Project
       Share.Redis
       Share.Release
@@ -150,7 +154,6 @@ library
       Share.Web.UCM.Sync.HashJWT
       Share.Web.UCM.Sync.Impl
       Share.Web.UCM.Sync.Types
-      Unison.PrettyPrintEnvDecl.Postgres
       Unison.Server.NameSearch.Postgres
       Unison.Server.Share.Definitions
       Unison.Server.Share.DefinitionSummary
@@ -269,6 +272,7 @@ library
     , unison-core1
     , unison-hash
     , unison-hashing-v2
+    , unison-merge
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer
@@ -411,6 +415,7 @@ executable share-api
     , unison-core1
     , unison-hash
     , unison-hashing-v2
+    , unison-merge
     , unison-parser-typechecker
     , unison-prelude
     , unison-pretty-printer

src/Share/BackgroundJobs/Search/DefinitionSync.hs

@@ -34,6 +34,7 @@ import Share.Postgres.Queries qualified as PG
 import Share.Postgres.Releases.Queries qualified as RQ
 import Share.Postgres.Search.DefinitionSearch.Queries qualified as DDQ
 import Share.Prelude
+import Share.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres
 import Share.Project (Project (..))
 import Share.Release (Release (..))
 import Share.Utils.Logging qualified as Logging
@@ -50,7 +51,6 @@ import Unison.Name qualified as Name
 import Unison.NameSegment (libSegment)
 import Unison.PrettyPrintEnv qualified as PPE
 import Unison.PrettyPrintEnvDecl qualified as PPED
-import Unison.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres
 import Unison.Reference (TypeReference)
 import Unison.Reference qualified as Reference
 import Unison.Server.Share.DefinitionSummary qualified as Summary
@@ -121,10 +121,10 @@ syncRelease authZReceipt releaseId = fmap (fromMaybe []) . runMaybeT $ do
     let codebaseLoc = Codebase.codebaseLocationForProjectRelease ownerUserId
     let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
     Codebase.codebaseMToTransaction codebase $ do
-      termsCursor <- lift $ NLOps.termsWithinNamespace nlReceipt bhId
+      termsCursor <- lift $ NLOps.projectTermsWithinRoot nlReceipt bhId
 
       termErrs <- syncTerms namesPerspective bhId projectId releaseId termsCursor
-      typesCursor <- lift $ NLOps.typesWithinNamespace nlReceipt bhId
+      typesCursor <- lift $ NLOps.projectTypesWithinRoot nlReceipt bhId
       typeErrs <- syncTypes namesPerspective projectId releaseId typesCursor
       pure (termErrs <> typeErrs)
 

src/Share/Codebase.hs

@@ -31,6 +31,7 @@ module Share.Codebase
     expectTypeOfTerms,
     expectTypeOfReferent,
     expectTypeOfReferents,
+    expectTypeOfConstructor,
     loadTypeOfConstructor,
     loadTypeOfReferent,
     loadTypeDeclaration,

src/Share/Names/Postgres.hs

@@ -0,0 +1,38 @@
+-- | Efficiently fetch a Names object for a given set of labeled dependencies.
+module Share.Names.Postgres (namesForReferences) where
+
+import Control.Lens
+import Data.Set qualified as Set
+import Share.Postgres qualified as PG
+import Share.Postgres.NameLookups.Conversions qualified as CV
+import Share.Postgres.NameLookups.Ops qualified as NameLookupOps
+import Share.Postgres.NameLookups.Types (NamesPerspective)
+import Share.Postgres.NameLookups.Types qualified as NameLookups
+import Share.Postgres.Refs.Types
+import Share.Prelude
+import Unison.LabeledDependency (LabeledDependency)
+import Unison.Name (Name)
+import Unison.Names (Names)
+import Unison.Names qualified as Names
+import Unison.Reference qualified as V1
+import Unison.Referent qualified as V1
+
+namesForReferences :: forall m. (PG.QueryM m) => NamesPerspective -> Set LabeledDependency -> m Names
+namesForReferences namesPerspective refs = do
+  withPGRefs <-
+    Set.toList refs
+      & CV.labeledDependencies1ToPG
+  (termNames, typeNames) <- foldMapM namesForReference withPGRefs
+  pure $ Names.fromTermsAndTypes termNames typeNames
+  where
+    -- TODO: Can probably speed this up by skipping suffixification.
+    namesForReference :: Either (V1.Referent, PGReferent) (V1.Reference, PGReference) -> m ([(Name, V1.Referent)], [(Name, V1.Reference)])
+    namesForReference = \case
+      Left (ref, pgref) -> do
+        termNames <- fmap (bothMap NameLookups.reversedNameToName) <$> NameLookupOps.termNamesForRefWithinNamespace namesPerspective pgref Nothing
+        let termNames' = termNames <&> \(fqn, _suffixed) -> (fqn, ref)
+        pure $ (termNames', [])
+      Right (ref, pgref) -> do
+        typeNames <- fmap (bothMap NameLookups.reversedNameToName) <$> NameLookupOps.typeNamesForRefWithinNamespace namesPerspective pgref Nothing
+        let typeNames' = typeNames <&> \(fqn, _suffixed) -> (fqn, ref)
+        pure $ ([], typeNames')

src/Share/NamespaceDiffs.hs

@@ -23,17 +23,14 @@ import Data.Foldable qualified as Foldable
 import Data.List.NonEmpty qualified as NEList
 import Data.Map qualified as Map
 import Data.Set qualified as Set
-import Data.Set.NonEmpty (NESet)
 import Data.Set.NonEmpty qualified as NESet
-import Servant (err500)
+import Share.NamespaceDiffs.Types
 import Share.Postgres qualified as PG
 import Share.Postgres.IDs (BranchHashId)
 import Share.Postgres.NameLookups.Conversions qualified as Cv
 import Share.Postgres.NameLookups.Types (NameLookupReceipt)
 import Share.Postgres.NamespaceDiffs qualified as ND
 import Share.Prelude
-import Share.Utils.Logging qualified as Logging
-import Share.Web.Errors
 import U.Codebase.Reference qualified as V2
 import U.Codebase.Referent qualified as V2
 import Unison.Codebase.Path (Path)
@@ -44,129 +41,6 @@ import Unison.NameSegment (NameSegment)
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Relation (Relation)
 import Unison.Util.Relation qualified as Rel
-import Unison.Util.Set qualified as Set
-
--- | The differences between two namespaces.
-data DefinitionDiffs name r = DefinitionDiffs
-  { -- Brand new added terms, neither the name nor definition exist in the old namespace.
-    added :: Map name r,
-    -- Removed terms. These names for these definitions were removed, and there are no newly
-    -- added names for these definitions.
-    removed :: Map name r,
-    -- Updated terms. These names exist in both the old and new namespace, but the definitions
-    -- assigned to them have changed.
-    updated :: Map name (r {- old -}, r {- new -}),
-    -- Renamed terms. These definitions exist in both the old and new namespace, but the names have
-    -- changed.
-    renamed :: Map r (NESet name {- old names for this ref -}, NESet name {- new names for this ref -}),
-    -- New aliases. These definitions exist in both the old namespace, but have received new names
-    -- in the new namespace without removing the old ones.
-    newAliases :: Map r (NESet name {- Existing names for this ref -}, NESet name)
-  }
-  deriving stock (Eq, Show)
-
-data DefinitionDiff r = DefinitionDiff
-  { kind :: DefinitionDiffKind r,
-    -- The fully qualified name of the definition we're concerned with.
-    fqn :: Name
-  }
-  deriving stock (Eq, Show, Ord, Functor, Foldable, Traversable)
-
--- | Information about a single definition which is different.
-data DefinitionDiffKind r
-  = Added r
-  | NewAlias r (NESet Name {- existing names -})
-  | Removed r
-  | Updated r {- old -} r {- new -}
-  | -- This definition was removed away from this location and added at the provided names.
-    RenamedTo r (NESet Name)
-  | -- This definition was added at this location and removed from the provided names.
-    RenamedFrom r (NESet Name)
-  deriving stock (Eq, Show, Ord, Functor, Foldable, Traversable)
-
-instance (Ord r) => Semigroup (DefinitionDiffs Name r) where
-  d1 <> d2 =
-    DefinitionDiffs
-      { added = added d1 <> added d2,
-        removed = removed d1 <> removed d2,
-        updated = updated d1 <> updated d2,
-        renamed = Map.unionWith (\(a1, b1) (a2, b2) -> (a1 <> a2, b1 <> b2)) (renamed d1) (renamed d2),
-        newAliases = Map.unionWith (\(a1, b1) (a2, b2) -> (a1 <> a2, b1 <> b2)) (newAliases d1) (newAliases d2)
-      }
-
-instance (Ord r) => Monoid (DefinitionDiffs Name r) where
-  mempty =
-    DefinitionDiffs
-      { added = mempty,
-        removed = mempty,
-        updated = mempty,
-        renamed = mempty,
-        newAliases = mempty
-      }
-
--- | A compressed tree of differences between two namespaces.
--- All intermediate namespaces with no differences are compressed into the keys of the
--- first child that has differences.
---
--- E.g.
---
--- If there's a change at `a.b.c` and `a.x.y`, the tree will look like:
---
--- @@
--- a
--- ├── b.c = DiffAtPath
--- └── x.y = DiffAtPath
--- @@
---
--- If there's a change at a.b.c and a.b.x, the tree will look like:
--- @@
--- a
--- └── b
---    ├── c = DiffAtPath
---    └── x = DiffAtPath
--- @@
-type NamespaceTreeDiff referent reference = Cofree (Map Path) (Map NameSegment (DiffAtPath referent reference))
-
--- | The differences at a specific path in the namespace tree.
-data DiffAtPath referent reference = DiffAtPath
-  { termDiffsAtPath :: Set (DefinitionDiff referent),
-    typeDiffsAtPath :: Set (DefinitionDiff reference)
-  }
-  deriving stock (Eq, Show)
-
--- | A traversal over all the referents in a `DiffAtPath`.
-diffAtPathReferents_ :: (Ord referent') => Traversal (DiffAtPath referent reference) (DiffAtPath referent' reference) referent referent'
-diffAtPathReferents_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) =
-  termDiffsAtPath
-    & (Set.traverse . traverse) %%~ f
-    & fmap \termDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath}
-
--- | A traversal over all the references in a `DiffAtPath`.
-diffAtPathReferences_ :: (Ord reference') => Traversal (DiffAtPath referent reference) (DiffAtPath referent reference') reference reference'
-diffAtPathReferences_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) =
-  typeDiffsAtPath
-    & (Set.traverse . traverse) %%~ f
-    & fmap \typeDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath}
-
--- | Traversal over all the referents in a `NamespaceTreeDiff`.
-namespaceTreeDiffReferents_ :: (Ord referent') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent' reference) referent referent'
-namespaceTreeDiffReferents_ =
-  traversed . traversed . diffAtPathReferents_
-
--- | Traversal over all the references in a `NamespaceTreeDiff`.
-namespaceTreeDiffReferences_ :: (Ord reference') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent reference') reference reference'
-namespaceTreeDiffReferences_ = traversed . traversed . diffAtPathReferences_
-
-data NamespaceDiffError = ImpossibleError Text
-  deriving stock (Eq, Show)
-
-instance ToServerError NamespaceDiffError where
-  toServerError ImpossibleError {} = (ErrorID "namespace-diff:impossible-error", err500)
-
-instance Logging.Loggable NamespaceDiffError where
-  toLog (ImpossibleError t) =
-    Logging.textLog t
-      & Logging.withSeverity Logging.Error
 
 -- | Compute the tree of differences between two namespace hashes.
 -- Note: This ignores all dependencies in the lib namespace.