From 8124c7ae871c8dcb1d6196d187beb60ae2f01d8c Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 15 Aug 2025 19:06:58 -0400 Subject: [PATCH 01/14] more efficient diffs --- src/Share/Codebase/Types.hs | 3 + src/Share/NamespaceDiffs.hs | 286 +++++++++++----------- src/Share/Postgres/NameLookups/Ops.hs | 35 ++- src/Share/Postgres/NameLookups/Queries.hs | 38 ++- src/Share/Postgres/Orphans.hs | 4 + src/Share/Web/Share/Diffs/Impl.hs | 3 +- unison | 2 +- 7 files changed, 221 insertions(+), 150 deletions(-) diff --git a/src/Share/Codebase/Types.hs b/src/Share/Codebase/Types.hs index 5a82c666..39dde1ed 100644 --- a/src/Share/Codebase/Types.hs +++ b/src/Share/Codebase/Types.hs @@ -31,9 +31,12 @@ publicRoot :: Path.Path publicRoot = Path.singleton (NameSegment "public") -- | The scope of a given codebase transaction. +-- +-- If two @CodebaseEnv@ are equal, they correspond to the same codebase. data CodebaseEnv = CodebaseEnv { codebaseOwner :: UserId } + deriving stock (Eq) data CodeCache scope = CodeCache { codeCacheCodebaseEnv :: CodebaseEnv, diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 519444e2..85ad5b8c 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -49,19 +49,20 @@ import Share.Postgres.NameLookups.Ops qualified as NL import Share.Postgres.NameLookups.Types (NameLookupReceipt) import Share.Postgres.NameLookups.Types qualified as NL import Share.Postgres.NamesPerspective.Ops qualified as NPOps -import Share.Postgres.NamesPerspective.Types (NamesPerspective) import Share.Prelude -import Share.Utils.Lens (asListOfDeduped) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.DataDeclaration (Decl) +import Unison.DeclCoherencyCheck (checkDeclCoherency, lenientCheckDeclCoherency) import Unison.LabeledDependency (LabeledDependency) -import Unison.Merge (Mergeblob0, Mergeblob1, ThreeWay (..), TwoOrThreeWay (..), TwoWay (..)) import Unison.Merge qualified as Merge -import Unison.Merge.HumanDiffOp (HumanDiffOp (..)) -import Unison.Merge.Mergeblob1 qualified as Mergeblob1 +import Unison.Merge.EitherWay qualified as EitherWay +import Unison.Merge.Synhashed (Synhashed) import Unison.Merge.ThreeWay qualified as ThreeWay +import Unison.Merge.TwoOrThreeWay qualified as TwoOrThreeWay +import Unison.Merge.TwoWay qualified as TwoWay +import Unison.Merge.Updated qualified as Updated import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment (..)) @@ -72,15 +73,15 @@ import Unison.Parser.Ann (Ann) import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) -import Unison.Referent qualified as Referent import Unison.Symbol (Symbol) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Term (Term) import Unison.Type (Type) +import Unison.UnconflictedLocalDefnsView qualified as UnconflictedLocalDefnsView import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.Defns (Defns (..), DefnsF, DefnsF3, alignDefnsWith) -import Unison.Util.Nametree (Nametree (..)) +import Unison.Util.Defns qualified as Defns -- | Convert a `DefinitionDiffs` into a tree of differences. definitionDiffsToTree :: @@ -210,24 +211,13 @@ compressNameTree (diffs Cofree.:< children) = in diffs Cofree.:< compressedChildren computeThreeWayNamespaceDiff :: - TwoWay Codebase.CodebaseEnv -> - TwoOrThreeWay BranchHashId -> - TwoOrThreeWay NameLookupReceipt -> + Merge.TwoWay Codebase.CodebaseEnv -> + Merge.TwoOrThreeWay BranchHashId -> + Merge.TwoOrThreeWay NameLookupReceipt -> PG.Transaction NamespaceDiffError (GNamespaceAndLibdepsDiff NameSegment Referent Reference Name Name Name Name BranchHashId) -computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds3 nameLookupReceipts3 = PG.transactionSpan "computeThreeWayNamespaceDiff" mempty $ do - -- Load a flat definitions names (no lib) for Alice/Bob/LCA - defnsNames3 :: TwoOrThreeWay Names <- - sequence (NL.projectNamesWithoutLib <$> nameLookupReceipts3 <*> branchHashIds3) - - -- Unflatten each Names to a Nametree (leniently). Really, only the LCA is "allowed" to break the diff/merge rules of - -- no conflicted names, but we don't enforce that here. If Alice or Bob have a conflicted name for some reason, we'll - -- just silently pick one of the refs and move on. - let defnsNametrees3 :: TwoOrThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) - defnsNametrees3 = - Names.lenientToNametree <$> defnsNames3 - +computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG.transactionSpan "computeThreeWayNamespaceDiff" mempty $ do -- Load the shallow libdeps for Alice/Bob/LCA. This can fail with "lib at unexpected path" - libdeps3 :: TwoOrThreeWay (Map NameSegment BranchHashId) <- do + libdeps :: Merge.ThreeWay (Map NameSegment BranchHashId) <- do let f :: NameLookupReceipt -> BranchHashId -> PG.Transaction NamespaceDiffError (Map NameSegment BranchHashId) f nameLookupReceipt branchHashId = do mounts <- NL.listNameLookupMounts nameLookupReceipt branchHashId @@ -237,132 +227,110 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds3 nameLookupReceipts3 = [NameSegment.LibSegment, dep] -> pure (dep, libBhId) p -> throwError $ LibFoundAtUnexpectedPath (Path.fromList p) pure $ Map.fromList libDepsList - sequence (f <$> nameLookupReceipts3 <*> branchHashIds3) + TwoOrThreeWay.toThreeWay Map.empty <$> sequence (f <$> nameLookupReceipts <*> branchHashIds) + + -- Load all local definition names (outside lib) for Alice/Bob/LCA. + -- + -- FIXME In a normal diff+merge, we require that the local names are unconflicted: each name may only refer to one + -- thing. However, we currently don't represent that in the `NamespaceDiffError` type. We should, but for now, we + -- instead just ignore conflicted names, if they exist. + defnsList <- sequence (NL.projectNamesWithoutLib <$> nameLookupReceipts <*> branchHashIds) + let defns = + let f = foldr (uncurry Map.insert) Map.empty + in TwoOrThreeWay.toThreeWay + UnconflictedLocalDefnsView.empty + (UnconflictedLocalDefnsView.fromDefns . bimap f f <$> defnsList) - -- Make that 0th mergeblob - let blob0 :: Mergeblob0 BranchHashId - blob0 = - Merge.makeMergeblob0 - ThreeWay - { alice = defnsNametrees3.alice, - bob = defnsNametrees3.bob, - lca = fromMaybe Nametree {value = Defns Map.empty Map.empty, children = Map.empty} defnsNametrees3.lca - } - ThreeWay - { alice = libdeps3.alice, - bob = libdeps3.bob, - lca = fromMaybe Map.empty libdeps3.lca - } + -- Load decl name lookups for Alice/Bob/LCA. This can fail with "incoherent decl". + declNameLookups <- do + numConstructors <- + TwoOrThreeWay.toThreeWay Map.empty + <$> sequence (NL.projectConstructorCountsWithoutLib <$> nameLookupReceipts <*> branchHashIds) + declNameLookups <- + sequence $ + ( \v c e -> + checkDeclCoherency v.nametree c + & mapLeft (IncoherentDecl . e) + & liftEither + ) + <$> ThreeWay.forgetLca defns + <*> ThreeWay.forgetLca numConstructors + <*> Merge.TwoWay EitherWay.Alice EitherWay.Bob + let lcaDeclNameLookup = + lenientCheckDeclCoherency defns.lca.nametree numConstructors.lca + pure (TwoWay.gtoThreeWay lcaDeclNameLookup declNameLookups) - -- Hydrate defns in Alice/Bob/LCA - hydratedDefns3 :: - ThreeWay - ( DefnsF - (Map Name) - (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) - (TypeReferenceId, Decl Symbol Ann) - ) <- PG.transactionSpan "hydratedDefns3" mempty do - let hydrateTermsOf :: - Codebase.CodebaseEnv -> - Traversal s t TermReferenceId (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) -> - s -> - PG.Transaction e t - hydrateTermsOf codebase trav s = PG.transactionSpan "hydrateTerms" mempty do - s - & asListOfDeduped trav %%~ \refs -> do - v2Terms <- DefnsQ.expectTermsByRefIdsOf codebase traversed refs - let v2TermsWithRef = zip refs v2Terms - let refHashes = v2TermsWithRef <&> \(refId, (term, typ)) -> (refId, ((Reference.idToHash refId), term, typ)) - Codebase.convertTerms2to1Of (traversed . _2) refHashes - hydrateTypesOf :: - Codebase.CodebaseEnv -> - Traversal s t TypeReferenceId (TypeReferenceId, Decl Symbol Ann) -> - s -> - PG.Transaction e t - hydrateTypesOf codebase trav s = PG.transactionSpan "hydrateTypes" mempty do - s - & asListOf trav %%~ \typeReferenceIds -> do - typeIdsWithComponents <- zip typeReferenceIds <$> DefnsQ.expectTypeComponentElementsAndTypeIdsOf codebase traversed typeReferenceIds - DefnsQ.loadDeclByTypeComponentElementAndTypeIdsOf (traversed . _2) typeIdsWithComponents - <&> fmap \(refId, v2Decl) -> - let v1Decl = Cv.decl2to1 (Reference.idToHash refId) v2Decl - in (refId, v1Decl) - hydrateDefns :: - Codebase.CodebaseEnv -> - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - PG.Transaction - e - ( DefnsF - (Map Name) - (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) - (TypeReferenceId, Decl Symbol Ann) - ) - hydrateDefns codebase (Defns {terms, types}) = PG.transactionSpan "hydrateDefns" mempty do - let termReferenceIds = Map.mapMaybe Referent.toTermReferenceId (BiMultimap.range terms) - hydratedTerms <- hydrateTermsOf codebase traversed termReferenceIds - let typeReferenceIds = Map.mapMaybe Reference.toId (BiMultimap.range types) - hydratedTypes <- hydrateTypesOf codebase traversed typeReferenceIds - pure - Defns - { terms = hydratedTerms, - types = hydratedTypes - } + let hydrate :: + Merge.ThreeWay (DefnsF Set TermReferenceId TypeReferenceId) -> + PG.Transaction + e + ( Defns + (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann)) + (Map TypeReferenceId (Decl Symbol Ann)) + ) + hydrate Merge.ThreeWay {lca = lcaDefns, alice = aliceDefns, bob = bobDefns} = do + -- We assume LCA and Alice come from the same codebase, so hydrate them together. + let lcaAndAliceDefns = lcaDefns <> aliceDefns + lcaAndAliceHydratedDefns <- hydrateDefns codebaseEnvs2.alice lcaAndAliceDefns + + -- Only bother hydrating Bob defns that we haven't already found in Alice's codebase. + let bobDefnsNotInAlice = Defns.zipDefnsWith Set.difference Set.difference bobDefns lcaAndAliceDefns + bobHydratedDefns <- hydrateDefns codebaseEnvs2.bob bobDefnsNotInAlice - let -- Here we assume that the LCA is in the same codebase as Alice. - codebaseEnvs3 :: ThreeWay Codebase.CodebaseEnv - codebaseEnvs3 = - ThreeWay - { alice = codebaseEnvs2.alice, - bob = codebaseEnvs2.bob, - lca = codebaseEnvs2.alice - } - sequence (hydrateDefns <$> codebaseEnvs3 <*> blob0.defns) + pure (lcaAndAliceHydratedDefns <> bobHydratedDefns) - -- Get a names object that contains just enough names to compute the diff: - names3 :: TwoOrThreeWay Names <- do - -- Massage the hydrated definitions into a set of "labeled dependency" that contains the definitions themselves - -- and their direct references. - -- - -- FIXME: Mitchell wonders why self is necessary. Aren't direct dependency names enough? - let labeledDeps3 :: ThreeWay (Set LabeledDependency) - labeledDeps3 = - Mergeblob1.hydratedDefnsLabeledDependencies <$> hydratedDefns3 - -- Get a names perspective for Alice/Bob/LCA - namesPerspectives3 :: TwoOrThreeWay (NamesPerspective m) <- - for branchHashIds3 \branchHashId -> NPOps.namesPerspectiveForRoot branchHashId - sequence (PGNames.namesForReferences <$> namesPerspectives3 <*> ThreeWay.toTwoOrThreeWay labeledDeps3) + let loadNames :: Merge.ThreeWay (Set LabeledDependency) -> PG.Transaction NamespaceDiffError (Merge.ThreeWay Names) + loadNames dependencies = do + perspectives <- traverse NPOps.namesPerspectiveForRoot branchHashIds + names <- sequence (PGNames.namesForReferences <$> perspectives <*> ThreeWay.toTwoOrThreeWay dependencies) + pure (TwoOrThreeWay.toThreeWay Names.empty names) - blob1 :: Mergeblob1 BranchHashId <- do - let names3' = ThreeWay {alice = names3.alice, bob = names3.bob, lca = fromMaybe (mempty @Names) names3.lca} - case Merge.makeMergeblob1 blob0 names3' hydratedDefns3 of - Right blob -> pure blob - Left err -> throwError (IncoherentDecl err) + diffblob <- + Merge.makeDiffblob + Merge.DiffblobLog + { logDefns = \_ -> pure (), + logDiff = \_ -> pure (), + logDiffsFromLCA = \_ -> pure (), + logNarrowedDefns = \_ -> pure (), + logSynhashedNarrowedDefns = \_ -> pure () + } + hydrate + loadNames + defns + libdeps + declNameLookups -- Boilerplate conversion: make a "DefinitionDiffs" from the info in a "Mergeblob1". -- - -- (Mitchell says: I think Share and UCM should share a type here – perhaps DefinitionDiffs should be pushed down? Or - -- is it just isomorphic to something that already exists in UCM?) - -- -- We start focusing only on Bob here, the contributor, even though Alice could have a diff as well of course (since -- the LCA is arbitrarily behind Alice). let definitionDiffs :: DefnsF (DefinitionDiffs Name) Referent TypeReference definitionDiffs = - let f :: forall ref. (Ord ref) => Map Name (HumanDiffOp ref) -> DefinitionDiffs Name ref - f = - Map.toList >>> foldMap \(name, op) -> - case op of - HumanDiffOp'Add ref -> mempty {added = Map.singleton name ref} - HumanDiffOp'Delete ref -> mempty {removed = Map.singleton name ref} - HumanDiffOp'Update refs -> mempty {updated = Map.singleton name (refs.old, refs.new)} - HumanDiffOp'PropagatedUpdate refs -> mempty {propagated = Map.singleton name (refs.old, refs.new)} - HumanDiffOp'AliasOf ref names -> - mempty {newAliases = Map.singleton ref (names, NESet.singleton name)} - HumanDiffOp'RenamedFrom ref names -> - mempty {renamed = Map.singleton ref (names, NESet.singleton name)} - HumanDiffOp'RenamedTo ref names -> - mempty {renamed = Map.singleton ref (NESet.singleton name, names)} - in bimap f f blob1.humanDiffsFromLCA.bob + Defns.zipDefnsWith3 f f defns.lca.defns diffblob.simpleRenames.bob diffblob.diffsFromLCA.bob + <> bimap g g diffblob.propagatedUpdates.bob + where + f :: (Ord ref) => BiMultimap ref Name -> Merge.SimpleRenames -> Map Name (Merge.DiffOp (Synhashed ref)) -> DefinitionDiffs Name ref + f lca renames = + Map.toList >>> foldMap \(name, op) -> + case op of + Merge.DiffOp'Add ref -> + case Map.lookup name renames.backwards of + Nothing -> + case NESet.nonEmptySet (BiMultimap.lookupDom ref.value lca) of + Nothing -> mempty {added = Map.singleton name ref.value} + Just oldNames -> mempty {newAliases = Map.singleton ref.value (oldNames, NESet.singleton name)} + Just oldName -> mempty {renamed = Map.singleton ref.value (NESet.singleton oldName, NESet.singleton name)} + Merge.DiffOp'Delete ref -> + case Map.lookup name renames.forwards of + Nothing -> mempty {removed = Map.singleton name ref.value} + -- we include the rename when handling the add side + Just _newName -> mempty + Merge.DiffOp'Update refs -> mempty {updated = Map.singleton name (Updated.toPair (Updated.map (.value) refs))} + + g :: (Ord ref) => Map Name (Merge.Updated ref) -> DefinitionDiffs Name ref + g propagatedUpdates = + mempty {propagated = Map.map Updated.toPair propagatedUpdates} -- Convert definition diffs to two uncompressed trees of diffs (one for terms, one for types) let twoUncompressedTrees :: @@ -383,5 +351,49 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds3 nameLookupReceipts3 = pure NamespaceAndLibdepsDiff { defns = oneUncompressedTree, - libdeps = blob1.libdepsDiffs.bob + libdeps = diffblob.libdepsDiffs.bob } + +hydrateDefns :: + Codebase.CodebaseEnv -> + DefnsF Set TermReferenceId TypeReferenceId -> + PG.Transaction + e + ( Defns + (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann)) + (Map TypeReferenceId (Decl Symbol Ann)) + ) +hydrateDefns codebase Defns {terms, types} + | Set.null terms && Set.null types = pure (Defns Map.empty Map.empty) + | otherwise = + PG.transactionSpan "hydrateDefns" mempty do + Defns + <$> (if Set.null terms then pure Map.empty else Map.fromList <$> hydrateTermsOf codebase traversed (Set.toList terms)) + <*> (if Set.null types then pure Map.empty else Map.fromList <$> hydrateTypesOf codebase traversed (Set.toList types)) + +hydrateTermsOf :: + Codebase.CodebaseEnv -> + Traversal s t TermReferenceId (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) -> + s -> + PG.Transaction e t +hydrateTermsOf codebase trav s = PG.transactionSpan "hydrateTerms" mempty do + s + & asListOf trav %%~ \refs -> do + v2Terms <- DefnsQ.expectTermsByRefIdsOf codebase traversed refs + let v2TermsWithRef = zip refs v2Terms + let refHashes = v2TermsWithRef <&> \(refId, (term, typ)) -> (refId, (Reference.idToHash refId, term, typ)) + Codebase.convertTerms2to1Of (traversed . _2) refHashes + +hydrateTypesOf :: + Codebase.CodebaseEnv -> + Traversal s t TypeReferenceId (TypeReferenceId, Decl Symbol Ann) -> + s -> + PG.Transaction e t +hydrateTypesOf codebase trav s = PG.transactionSpan "hydrateTypes" mempty do + s + & asListOf trav %%~ \typeReferenceIds -> do + typeIdsWithComponents <- zip typeReferenceIds <$> DefnsQ.expectTypeComponentElementsAndTypeIdsOf codebase traversed typeReferenceIds + DefnsQ.loadDeclByTypeComponentElementAndTypeIdsOf (traversed . _2) typeIdsWithComponents + <&> fmap \(refId, v2Decl) -> + let v1Decl = Cv.decl2to1 (Reference.idToHash refId) v2Decl + in (refId, v1Decl) diff --git a/src/Share/Postgres/NameLookups/Ops.hs b/src/Share/Postgres/NameLookups/Ops.hs index 2e917dbf..4de466dc 100644 --- a/src/Share/Postgres/NameLookups/Ops.hs +++ b/src/Share/Postgres/NameLookups/Ops.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + module Share.Postgres.NameLookups.Ops ( fuzzySearchDefinitions, termNamesForRefsWithinNamespaceOf, @@ -11,12 +13,15 @@ module Share.Postgres.NameLookups.Ops Q.projectTypesWithinRoot, Q.listNameLookupMounts, projectNamesWithoutLib, + projectConstructorCountsWithoutLib, ) where import Control.Lens +import Data.Map.Strict qualified as Map import Data.Set qualified as Set -import Share.Postgres (QueryM) +import Data.Vector qualified as Vector +import Share.Postgres (Only (..), QueryM, (:.) (..)) import Share.Postgres qualified as PG import Share.Postgres.Cursors qualified as Cursor import Share.Postgres.Hashes.Queries qualified as HashQ @@ -31,12 +36,12 @@ import Share.Postgres.NamesPerspective.Types (NamesPerspective (..)) import Share.Postgres.Refs.Types import Share.Prelude import Share.Utils.Lens (asListOfDeduped) -import U.Codebase.Reference (Reference) import U.Codebase.Referent (ConstructorType, Referent) -import Unison.Names (Names) -import Unison.Names qualified as Names +import Unison.Name (Name) +import Unison.Reference (Reference, TypeReference, TypeReferenceId) import Unison.Reference qualified as V1 import Unison.Referent qualified as V1 +import Unison.Util.Defns (Defns (..), DefnsF) -- | Search for term or type names which contain the provided list of segments in order. -- Search is case insensitive. @@ -115,10 +120,24 @@ deleteNameLookupsExceptFor reachable = do -- | Build a 'Names' for all definitions within the given root, without any dependencies. -- Note: This loads everything into memory at once, so avoid this and prefer streaming when possible. -projectNamesWithoutLib :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m Names +projectNamesWithoutLib :: + (QueryM m) => + NameLookupReceipt -> + BranchHashId -> + m (DefnsF [] (Name, V1.Referent) (Name, TypeReference)) projectNamesWithoutLib !nlr rootBranchHashId = do termNamesCursor <- Q.projectTermsWithinRootV1 nlr rootBranchHashId - allTerms <- Cursor.foldBatched termNamesCursor 1000 (pure . toList) + terms <- Cursor.foldBatched termNamesCursor 1000 (pure . toList) typesCursor <- (Q.projectTypesWithinRoot nlr rootBranchHashId) - allTypes <- Cursor.foldBatched typesCursor 1000 (pure . toList) - pure $ Names.fromTermsAndTypes allTerms allTypes + types <- Cursor.foldBatched typesCursor 1000 (pure . toList) + pure Defns {terms, types} + +-- | Build a @Map TypeReferenceId Int@ constructor count map for all types within the given root, without any dependencies. +projectConstructorCountsWithoutLib :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m (Map TypeReferenceId Int) +projectConstructorCountsWithoutLib !nlr rootBranchHashId = do + cursor <- Q.projectConstructorCountsWithinRoot nlr rootBranchHashId + Cursor.foldBatched cursor 1000 (pure . Vector.foldl' f Map.empty) + where + f :: Map TypeReferenceId Int -> TypeReferenceId :. Only Int64 -> Map TypeReferenceId Int + f acc (ref :. Only count) = + Map.insert ref (fromIntegral @Int64 @Int count) acc diff --git a/src/Share/Postgres/NameLookups/Queries.hs b/src/Share/Postgres/NameLookups/Queries.hs index 95cc4ee9..dd204dd9 100644 --- a/src/Share/Postgres/NameLookups/Queries.hs +++ b/src/Share/Postgres/NameLookups/Queries.hs @@ -16,6 +16,7 @@ module Share.Postgres.NameLookups.Queries projectTermsWithinRoot, projectTermsWithinRootV1, projectTypesWithinRoot, + projectConstructorCountsWithinRoot, -- * Name lookup management listNameLookupMounts, @@ -41,11 +42,11 @@ import Share.Postgres.NamesPerspective.Types (NamesPerspective, perspectiveCurre import Share.Postgres.Refs.Types (PGReference, PGReferent, referenceFields, referentFields) import Share.Prelude import Share.Utils.Postgres (ordered) -import U.Codebase.Reference (Reference) import U.Codebase.Referent (ConstructorType) import U.Codebase.Referent qualified as V2 import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Name (Name) +import Unison.Reference (TypeReference, TypeReferenceId) import Unison.Referent qualified as V1 import Unison.Util.Monoid qualified as Monoid @@ -489,9 +490,9 @@ referent2to1 :: (HasCallStack) => (V2.Referent PG.:. PG.Only (Maybe V2.Construct referent2to1 (r PG.:. PG.Only mayCT) = Cv.referent2to1UsingCT (fromMaybe (error "Required constructor type for constructor but it was null") mayCT) r -- | Get a cursor over all non-lib types within the given root branch. -projectTypesWithinRoot :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m (PGCursor (Name, Reference)) +projectTypesWithinRoot :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m (PGCursor (Name, TypeReference)) projectTypesWithinRoot !_nlReceipt bhId = do - Cursors.newRowCursor @(NamedRef Reference) + Cursors.newRowCursor @(NamedRef TypeReference) "typesForSearchSyncCursor" [sql| SELECT reversed_name, reference_builtin, reference_component_hash.base32, reference_component_index @@ -501,6 +502,37 @@ projectTypesWithinRoot !_nlReceipt bhId = do |] <&> fmap (\NamedRef {reversedSegments, ref} -> (reversedNameToName reversedSegments, ref)) +-- | Get a cursor over all non-lib, non-builtin types and their corresponding constructor counts, within the given root branch. +projectConstructorCountsWithinRoot :: (QueryM m) => NameLookupReceipt -> BranchHashId -> m (PGCursor (TypeReferenceId :. Only Int64)) +projectConstructorCountsWithinRoot !_ bhId = + Cursors.newRowCursor + "constructorCountsCursor" + [sql| + WITH x AS ( + SELECT DISTINCT ON (scoped_type_name_lookup.type_id) + scoped_type_name_lookup.type_id, + component_hashes.base32, + scoped_type_name_lookup.reference_component_index + FROM scoped_type_name_lookup + JOIN component_hashes + ON scoped_type_name_lookup.reference_component_hash_id = component_hashes.id + WHERE scoped_type_name_lookup.root_branch_hash_id = #{bhId} + AND scoped_type_name_lookup.reference_builtin IS NULL + ) + SELECT + x.base32 AS hash, + x.reference_component_index AS component_index, + COALESCE(y.constructor_index + 1, 0) AS constructor_count + FROM x + LEFT JOIN LATERAL ( + SELECT constructors.constructor_index + FROM constructors + WHERE x.type_id = constructors.type_id + ORDER BY constructors.constructor_index DESC + LIMIT 1 + ) y ON true; + |] + ensureNameLookupForBranchId :: (QueryM m) => BranchHashId -> m NameLookupReceipt ensureNameLookupForBranchId branchHashId = PG.transactionSpan "ensureNameLookupForBranchId" mempty do UnsafeNameLookupReceipt diff --git a/src/Share/Postgres/Orphans.hs b/src/Share/Postgres/Orphans.hs index 282f8d25..392ad162 100644 --- a/src/Share/Postgres/Orphans.hs +++ b/src/Share/Postgres/Orphans.hs @@ -116,6 +116,10 @@ instance Hasql.EncodeValue Name where Hasql.encodeValue @Text & contramap Name.toText +instance Hasql.DecodeValue h => Hasql.DecodeRow (Id' h) where + decodeRow = + Id <$> decodeField @h <*> (either (error . show) id . tryInto @Word64 <$> decodeField @Int64) + instance (Hasql.DecodeValue t, Hasql.DecodeValue h, Show t, Show h) => Hasql.DecodeRow (Reference' t h) where decodeRow = do decodeReference (decodeField @(Maybe t)) (decodeField @(Maybe h)) (decodeField @(Maybe Int64)) diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index e72d5ae7..31b39858 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -31,6 +31,7 @@ import U.Codebase.Reference qualified as V2Reference import Unison.Codebase.SqliteCodebase.Conversions (referent1to2) import Unison.ConstructorReference (ConstructorReference) import Unison.Merge (TwoOrThreeWay (..), TwoWay (..)) +import Unison.Merge.DiffOp qualified as DiffOp import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.Referent qualified as Referent @@ -116,7 +117,7 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC diff3 <- PG.transactionSpan "hydrate-diff3" mempty $ HashQ.expectNamespaceHashesByNamespaceHashIdsOf - (NamespaceDiffs.namespaceAndLibdepsDiffLibdeps_ . traversed . traversed) + (NamespaceDiffs.namespaceAndLibdepsDiffLibdeps_ . traversed . DiffOp.traverse) diff2 -- Resolve the actual term/type definitions. Use the LCA as the "old" (because that's what we're rendering the -- diff relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we diff --git a/unison b/unison index 3ecad945..0138a901 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 3ecad945acf0dfdd8adf1b9486d74143063358db +Subproject commit 0138a901c30c815045c954466ab8db0dac7a416c From c57e82e6f26cbad21c140ff7d6c769a3e5df75c4 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Wed, 20 Aug 2025 20:12:11 -0400 Subject: [PATCH 02/14] Make post-diff "get term/type display objects" step more efficient --- src/Share/NamespaceDiffs.hs | 220 +++++++++++++++--------------- src/Share/NamespaceDiffs/Types.hs | 1 + src/Share/Web/Share/Diffs/Impl.hs | 188 ++++++++++++++++--------- 3 files changed, 230 insertions(+), 179 deletions(-) diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 85ad5b8c..08eaa3ba 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -13,6 +13,7 @@ module Share.NamespaceDiffs DefinitionDiff (..), DefinitionDiffKind (..), computeThreeWayNamespaceDiff, + makeNamespaceDiffTree, compressNameTree, namespaceTreeDiffReferences_, namespaceTreeDiffReferents_, @@ -26,6 +27,7 @@ module Share.NamespaceDiffs namespaceTreeTypeDiffKinds_, namespaceAndLibdepsDiffDefns_, namespaceAndLibdepsDiffLibdeps_, + definitionDiffKindRendered_, ) where @@ -70,7 +72,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) -import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) +import Unison.Reference (TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Symbol (Symbol) @@ -214,27 +216,30 @@ computeThreeWayNamespaceDiff :: Merge.TwoWay Codebase.CodebaseEnv -> Merge.TwoOrThreeWay BranchHashId -> Merge.TwoOrThreeWay NameLookupReceipt -> - PG.Transaction NamespaceDiffError (GNamespaceAndLibdepsDiff NameSegment Referent Reference Name Name Name Name BranchHashId) + PG.Transaction NamespaceDiffError (Merge.Diffblob BranchHashId) computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG.transactionSpan "computeThreeWayNamespaceDiff" mempty $ do -- Load the shallow libdeps for Alice/Bob/LCA. This can fail with "lib at unexpected path" libdeps :: Merge.ThreeWay (Map NameSegment BranchHashId) <- do - let f :: NameLookupReceipt -> BranchHashId -> PG.Transaction NamespaceDiffError (Map NameSegment BranchHashId) - f nameLookupReceipt branchHashId = do - mounts <- NL.listNameLookupMounts nameLookupReceipt branchHashId - libDepsList <- - for mounts \(NL.PathSegments path, libBhId) -> do - case NameSegment.unsafeParseText <$> path of - [NameSegment.LibSegment, dep] -> pure (dep, libBhId) - p -> throwError $ LibFoundAtUnexpectedPath (Path.fromList p) - pure $ Map.fromList libDepsList - TwoOrThreeWay.toThreeWay Map.empty <$> sequence (f <$> nameLookupReceipts <*> branchHashIds) + PG.transactionSpan "load libdeps" mempty do + let f :: NameLookupReceipt -> BranchHashId -> PG.Transaction NamespaceDiffError (Map NameSegment BranchHashId) + f nameLookupReceipt branchHashId = do + mounts <- NL.listNameLookupMounts nameLookupReceipt branchHashId + libDepsList <- + for mounts \(NL.PathSegments path, libBhId) -> do + case NameSegment.unsafeParseText <$> path of + [NameSegment.LibSegment, dep] -> pure (dep, libBhId) + p -> throwError $ LibFoundAtUnexpectedPath (Path.fromList p) + pure $ Map.fromList libDepsList + TwoOrThreeWay.toThreeWay Map.empty <$> sequence (f <$> nameLookupReceipts <*> branchHashIds) -- Load all local definition names (outside lib) for Alice/Bob/LCA. -- -- FIXME In a normal diff+merge, we require that the local names are unconflicted: each name may only refer to one -- thing. However, we currently don't represent that in the `NamespaceDiffError` type. We should, but for now, we -- instead just ignore conflicted names, if they exist. - defnsList <- sequence (NL.projectNamesWithoutLib <$> nameLookupReceipts <*> branchHashIds) + defnsList <- + PG.transactionSpan "load definitions names" mempty do + sequence (NL.projectNamesWithoutLib <$> nameLookupReceipts <*> branchHashIds) let defns = let f = foldr (uncurry Map.insert) Map.empty in TwoOrThreeWay.toThreeWay @@ -244,18 +249,20 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG -- Load decl name lookups for Alice/Bob/LCA. This can fail with "incoherent decl". declNameLookups <- do numConstructors <- - TwoOrThreeWay.toThreeWay Map.empty - <$> sequence (NL.projectConstructorCountsWithoutLib <$> nameLookupReceipts <*> branchHashIds) + PG.transactionSpan "load constructor counts" mempty do + TwoOrThreeWay.toThreeWay Map.empty + <$> sequence (NL.projectConstructorCountsWithoutLib <$> nameLookupReceipts <*> branchHashIds) declNameLookups <- - sequence $ - ( \v c e -> - checkDeclCoherency v.nametree c - & mapLeft (IncoherentDecl . e) - & liftEither - ) - <$> ThreeWay.forgetLca defns - <*> ThreeWay.forgetLca numConstructors - <*> Merge.TwoWay EitherWay.Alice EitherWay.Bob + PG.transactionSpan "check decl coherency" mempty do + sequence $ + ( \v c e -> + checkDeclCoherency v.nametree c + & mapLeft (IncoherentDecl . e) + & liftEither + ) + <$> ThreeWay.forgetLca defns + <*> ThreeWay.forgetLca numConstructors + <*> Merge.TwoWay EitherWay.Alice EitherWay.Bob let lcaDeclNameLookup = lenientCheckDeclCoherency defns.lca.nametree numConstructors.lca pure (TwoWay.gtoThreeWay lcaDeclNameLookup declNameLookups) @@ -271,90 +278,40 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG hydrate Merge.ThreeWay {lca = lcaDefns, alice = aliceDefns, bob = bobDefns} = do -- We assume LCA and Alice come from the same codebase, so hydrate them together. let lcaAndAliceDefns = lcaDefns <> aliceDefns - lcaAndAliceHydratedDefns <- hydrateDefns codebaseEnvs2.alice lcaAndAliceDefns + lcaAndAliceHydratedDefns <- hydrateDefns "hydrate alice & lca definitions" codebaseEnvs2.alice lcaAndAliceDefns -- Only bother hydrating Bob defns that we haven't already found in Alice's codebase. let bobDefnsNotInAlice = Defns.zipDefnsWith Set.difference Set.difference bobDefns lcaAndAliceDefns - bobHydratedDefns <- hydrateDefns codebaseEnvs2.bob bobDefnsNotInAlice + bobHydratedDefns <- hydrateDefns "hydrate bob definitions" codebaseEnvs2.bob bobDefnsNotInAlice pure (lcaAndAliceHydratedDefns <> bobHydratedDefns) let loadNames :: Merge.ThreeWay (Set LabeledDependency) -> PG.Transaction NamespaceDiffError (Merge.ThreeWay Names) loadNames dependencies = do - perspectives <- traverse NPOps.namesPerspectiveForRoot branchHashIds - names <- sequence (PGNames.namesForReferences <$> perspectives <*> ThreeWay.toTwoOrThreeWay dependencies) + perspectives <- + PG.transactionSpan "load names perspectives" mempty do + traverse NPOps.namesPerspectiveForRoot branchHashIds + names <- + PG.transactionSpan "load names" mempty do + sequence (PGNames.namesForReferences <$> perspectives <*> ThreeWay.toTwoOrThreeWay dependencies) pure (TwoOrThreeWay.toThreeWay Names.empty names) - diffblob <- - Merge.makeDiffblob - Merge.DiffblobLog - { logDefns = \_ -> pure (), - logDiff = \_ -> pure (), - logDiffsFromLCA = \_ -> pure (), - logNarrowedDefns = \_ -> pure (), - logSynhashedNarrowedDefns = \_ -> pure () - } - hydrate - loadNames - defns - libdeps - declNameLookups - - -- Boilerplate conversion: make a "DefinitionDiffs" from the info in a "Mergeblob1". - -- - -- We start focusing only on Bob here, the contributor, even though Alice could have a diff as well of course (since - -- the LCA is arbitrarily behind Alice). - - let definitionDiffs :: DefnsF (DefinitionDiffs Name) Referent TypeReference - definitionDiffs = - Defns.zipDefnsWith3 f f defns.lca.defns diffblob.simpleRenames.bob diffblob.diffsFromLCA.bob - <> bimap g g diffblob.propagatedUpdates.bob - where - f :: (Ord ref) => BiMultimap ref Name -> Merge.SimpleRenames -> Map Name (Merge.DiffOp (Synhashed ref)) -> DefinitionDiffs Name ref - f lca renames = - Map.toList >>> foldMap \(name, op) -> - case op of - Merge.DiffOp'Add ref -> - case Map.lookup name renames.backwards of - Nothing -> - case NESet.nonEmptySet (BiMultimap.lookupDom ref.value lca) of - Nothing -> mempty {added = Map.singleton name ref.value} - Just oldNames -> mempty {newAliases = Map.singleton ref.value (oldNames, NESet.singleton name)} - Just oldName -> mempty {renamed = Map.singleton ref.value (NESet.singleton oldName, NESet.singleton name)} - Merge.DiffOp'Delete ref -> - case Map.lookup name renames.forwards of - Nothing -> mempty {removed = Map.singleton name ref.value} - -- we include the rename when handling the add side - Just _newName -> mempty - Merge.DiffOp'Update refs -> mempty {updated = Map.singleton name (Updated.toPair (Updated.map (.value) refs))} - - g :: (Ord ref) => Map Name (Merge.Updated ref) -> DefinitionDiffs Name ref - g propagatedUpdates = - mempty {propagated = Map.map Updated.toPair propagatedUpdates} - - -- Convert definition diffs to two uncompressed trees of diffs (one for terms, one for types) - let twoUncompressedTrees :: - DefnsF3 - (Cofree (Map NameSegment)) - (Map NameSegment) - Set - (DefinitionDiff Referent Name Name) - (DefinitionDiff TypeReference Name Name) - twoUncompressedTrees = - bimap definitionDiffsToTree definitionDiffsToTree definitionDiffs - - -- Align terms and types trees into one tree (still uncompressed) - let oneUncompressedTree :: GNamespaceTreeDiff NameSegment Referent TypeReference Name Name Name Name - oneUncompressedTree = - alignDefnsWith combineTermsAndTypes twoUncompressedTrees - - pure - NamespaceAndLibdepsDiff - { defns = oneUncompressedTree, - libdeps = diffblob.libdepsDiffs.bob + Merge.makeDiffblob + Merge.DiffblobLog + { logDefns = \_ -> pure (), + logDiff = \_ -> pure (), + logDiffsFromLCA = \_ -> pure (), + logNarrowedDefns = \_ -> pure (), + logSynhashedNarrowedDefns = \_ -> pure () } + hydrate + loadNames + defns + libdeps + declNameLookups hydrateDefns :: + Text -> Codebase.CodebaseEnv -> DefnsF Set TermReferenceId TypeReferenceId -> PG.Transaction @@ -363,10 +320,10 @@ hydrateDefns :: (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) ) -hydrateDefns codebase Defns {terms, types} +hydrateDefns description codebase Defns {terms, types} | Set.null terms && Set.null types = pure (Defns Map.empty Map.empty) | otherwise = - PG.transactionSpan "hydrateDefns" mempty do + PG.transactionSpan description mempty do Defns <$> (if Set.null terms then pure Map.empty else Map.fromList <$> hydrateTermsOf codebase traversed (Set.toList terms)) <*> (if Set.null types then pure Map.empty else Map.fromList <$> hydrateTypesOf codebase traversed (Set.toList types)) @@ -376,24 +333,63 @@ hydrateTermsOf :: Traversal s t TermReferenceId (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) -> s -> PG.Transaction e t -hydrateTermsOf codebase trav s = PG.transactionSpan "hydrateTerms" mempty do - s - & asListOf trav %%~ \refs -> do - v2Terms <- DefnsQ.expectTermsByRefIdsOf codebase traversed refs - let v2TermsWithRef = zip refs v2Terms - let refHashes = v2TermsWithRef <&> \(refId, (term, typ)) -> (refId, (Reference.idToHash refId, term, typ)) - Codebase.convertTerms2to1Of (traversed . _2) refHashes +hydrateTermsOf codebase trav = + asListOf trav %%~ \refs -> do + v2Terms <- DefnsQ.expectTermsByRefIdsOf codebase traversed refs + let v2TermsWithRef = zip refs v2Terms + let refHashes = v2TermsWithRef <&> \(refId, (term, typ)) -> (refId, (Reference.idToHash refId, term, typ)) + Codebase.convertTerms2to1Of (traversed . _2) refHashes hydrateTypesOf :: Codebase.CodebaseEnv -> Traversal s t TypeReferenceId (TypeReferenceId, Decl Symbol Ann) -> s -> PG.Transaction e t -hydrateTypesOf codebase trav s = PG.transactionSpan "hydrateTypes" mempty do - s - & asListOf trav %%~ \typeReferenceIds -> do - typeIdsWithComponents <- zip typeReferenceIds <$> DefnsQ.expectTypeComponentElementsAndTypeIdsOf codebase traversed typeReferenceIds - DefnsQ.loadDeclByTypeComponentElementAndTypeIdsOf (traversed . _2) typeIdsWithComponents - <&> fmap \(refId, v2Decl) -> - let v1Decl = Cv.decl2to1 (Reference.idToHash refId) v2Decl - in (refId, v1Decl) +hydrateTypesOf codebase trav = + asListOf trav %%~ \typeReferenceIds -> do + typeIdsWithComponents <- zip typeReferenceIds <$> DefnsQ.expectTypeComponentElementsAndTypeIdsOf codebase traversed typeReferenceIds + DefnsQ.loadDeclByTypeComponentElementAndTypeIdsOf (traversed . _2) typeIdsWithComponents + <&> fmap \(refId, v2Decl) -> + let v1Decl = Cv.decl2to1 (Reference.idToHash refId) v2Decl + in (refId, v1Decl) + +-- Boilerplate conversion: make a "DefinitionDiffs" from the info in a "Mergeblob1". +-- +-- We start focusing only on Bob here, the contributor, even though Alice could have a diff as well of course (since +-- the LCA is arbitrarily behind Alice). +makeNamespaceDiffTree :: + Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> + DefnsF3 (Map Name) Merge.DiffOp Synhashed Referent TypeReference -> + DefnsF (Map Name) (Merge.Updated Referent) (Merge.Updated TypeReference) -> + Defns Merge.SimpleRenames Merge.SimpleRenames -> + GNamespaceTreeDiff NameSegment Referent TypeReference Name Name Name Name +makeNamespaceDiffTree lcaDefns diffFromLca propagatedUpdates simpleRenames = + ( Defns.zipDefnsWith3 f f lcaDefns simpleRenames diffFromLca + <> bimap g g propagatedUpdates + ) + -- Convert definition diffs to two uncompressed trees of diffs (one for terms, one for types) + & bimap definitionDiffsToTree definitionDiffsToTree + -- Align terms and types trees into one tree (still uncompressed) + & alignDefnsWith combineTermsAndTypes + where + f :: (Ord ref) => BiMultimap ref Name -> Merge.SimpleRenames -> Map Name (Merge.DiffOp (Synhashed ref)) -> DefinitionDiffs Name ref + f lca renames = + Map.toList >>> foldMap \(name, op) -> + case op of + Merge.DiffOp'Add ref -> + case Map.lookup name renames.backwards of + Nothing -> + case NESet.nonEmptySet (BiMultimap.lookupDom ref.value lca) of + Nothing -> mempty {added = Map.singleton name ref.value} + Just oldNames -> mempty {newAliases = Map.singleton ref.value (oldNames, NESet.singleton name)} + Just oldName -> mempty {renamed = Map.singleton ref.value (NESet.singleton oldName, NESet.singleton name)} + Merge.DiffOp'Delete ref -> + case Map.lookup name renames.forwards of + Nothing -> mempty {removed = Map.singleton name ref.value} + -- we include the rename when handling the add side + Just _newName -> mempty + Merge.DiffOp'Update refs -> mempty {updated = Map.singleton name (Updated.toPair (Updated.map (.value) refs))} + + g :: (Ord ref) => Map Name (Merge.Updated ref) -> DefinitionDiffs Name ref + g propagatedUpdates = + mempty {propagated = Map.map Updated.toPair propagatedUpdates} diff --git a/src/Share/NamespaceDiffs/Types.hs b/src/Share/NamespaceDiffs/Types.hs index b1ab6bdd..d99154ae 100644 --- a/src/Share/NamespaceDiffs/Types.hs +++ b/src/Share/NamespaceDiffs/Types.hs @@ -24,6 +24,7 @@ module Share.NamespaceDiffs.Types namespaceTreeTypeDiffKinds_, namespaceTreeDiffRenderedTerms_, namespaceTreeDiffRenderedTypes_, + definitionDiffKindRendered_, ) where diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index 31b39858..eea765e9 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -8,11 +8,16 @@ where import Control.Lens hiding ((.=)) import Control.Monad.Except import Data.Aeson qualified as Aeson +import Data.Either (partitionEithers) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Set.Lens (setOf) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Share.Codebase qualified as Codebase -import Share.NamespaceDiffs (DefinitionDiffKind (..), GNamespaceTreeDiff, NamespaceDiffError (..)) +import Share.NamespaceDiffs (DefinitionDiffKind (..), NamespaceDiffError (..)) import Share.NamespaceDiffs qualified as NamespaceDiffs +import Share.NamespaceDiffs.Types (GNamespaceTreeDiff) import Share.Postgres qualified as PG import Share.Postgres.Causal.Queries qualified as CausalQ import Share.Postgres.Contributions.Queries qualified as ContributionQ @@ -31,15 +36,19 @@ import U.Codebase.Reference qualified as V2Reference import Unison.Codebase.SqliteCodebase.Conversions (referent1to2) import Unison.ConstructorReference (ConstructorReference) import Unison.Merge (TwoOrThreeWay (..), TwoWay (..)) +import Unison.Merge qualified as Merge import Unison.Merge.DiffOp qualified as DiffOp import Unison.Name (Name) import Unison.NameSegment (NameSegment) +import Unison.Reference (TypeReference) +import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff import Unison.Server.Share.Definitions qualified as Definitions import Unison.Server.Types import Unison.ShortHash (ShortHash) import Unison.Syntax.Name qualified as Name +import Unison.UnconflictedLocalDefnsView qualified import Unison.Util.Pretty (Width) -- | Diff two causals and store the diff in the database. @@ -92,83 +101,116 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC (lcaBranchHashId, lcaBranchNLReceipt, lcaPerspective) <- PG.transactionSpan "getNewBranch" mempty $ getBranch lcaCausalId pure (Just lcaBranchHashId, Just lcaBranchNLReceipt, Just lcaPerspective) Nothing -> pure (Nothing, Nothing, Nothing) + -- Do the initial 3-way namespace diff - diff0 <- + diffblob <- NamespaceDiffs.computeThreeWayNamespaceDiff TwoWay {alice = oldCodebase, bob = newCodebase} TwoOrThreeWay {alice = oldBranchHashId, bob = newBranchHashId, lca = maybeLcaBranchHashId} TwoOrThreeWay {alice = oldBranchNLReceipt, bob = newBranchNLReceipt, lca = maybeLcaBranchNLReceipt} + + -- Boilerplate conversion: make a "DefinitionDiffs" from the info in a "Mergeblob1". + -- + -- We start focusing only on Bob here, the contributor, even though Alice could have a diff as well of course (since + -- the LCA is arbitrarily behind Alice). + let defns0 :: GNamespaceTreeDiff NameSegment Referent TypeReference Name Name Name Name + defns0 = + NamespaceDiffs.makeNamespaceDiffTree + diffblob.defns.lca.defns + diffblob.diffsFromLCA.bob + diffblob.propagatedUpdates.bob + diffblob.simpleRenames.bob + + let oldPerspective1 = + fromMaybe oldPerspective maybeLcaPerspective + + let termNamesToRender = + defns0 ^.. NamespaceDiffs.namespaceTreeTermDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_ + + let (oldTermNamesToRender, newTermNamesToRender) = + bimap Set.fromList Set.fromList (partitionEithers termNamesToRender) + + let termNamesToDiff = + setOf NamespaceDiffs.namespaceTreeDiffTermDiffs_ defns0 + + let typeNamesToRender = + defns0 ^.. NamespaceDiffs.namespaceTreeTypeDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_ + + let (oldTypeNamesToRender, newTypeNamesToRender) = + bimap Set.fromList Set.fromList (partitionEithers typeNamesToRender) + + let typeNamesToDiff = + setOf NamespaceDiffs.namespaceTreeDiffTypeDiffs_ defns0 + + oldTermDefinitionsByName <- do + PG.transactionSpan "load old terms" mempty do + deriveMapOf + (expectTermDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (Set.toList (Set.union oldTermNamesToRender termNamesToDiff)) + + newTermDefinitionsByName <- do + PG.transactionSpan "load new terms" mempty do + deriveMapOf + (expectTermDefinitionsOf newCodebase newRuntime newPerspective) + (Set.toList (Set.union newTermNamesToRender termNamesToDiff)) + + oldTypeDefinitionsByName <- do + PG.transactionSpan "load old types" mempty do + deriveMapOf + (expectTypeDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (Set.toList (Set.union oldTypeNamesToRender typeNamesToDiff)) + + newTypeDefinitionsByName <- do + PG.transactionSpan "load new types" mempty do + deriveMapOf + (expectTypeDefinitionsOf newCodebase newRuntime newPerspective) + (Set.toList (Set.union newTypeNamesToRender typeNamesToDiff)) + -- Resolve the term referents to tag + hash - diff1 <- PG.transactionSpan "hydrate-diff1" mempty $ do - diff0 - & asListOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferents_) - %%~ \refs -> do + defns1 :: NamespaceDiffs.GNamespaceTreeDiff NameSegment (TermTag, ShortHash) TypeReference Name Name Name Name <- + PG.transactionSpan "load term tags" mempty do + defns0 + & asListOf NamespaceDiffs.namespaceTreeDiffReferents_ %%~ \refs -> do termTags <- Codebase.termTagsByReferentsOf traversed (referent1to2 <$> refs) pure $ zip termTags (refs <&> Referent.toShortHash) + -- Resolve the type references to tag + hash - diff2 <- - PG.transactionSpan "hydrate-diff2" mempty $ - diff1 - & asListOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferences_) - %%~ \refs -> do - typeTags <- Codebase.typeTagsByReferencesOf traversed refs - pure $ zip typeTags (refs <&> V2Reference.toShortHash) + defns2 :: NamespaceDiffs.GNamespaceTreeDiff NameSegment (TermTag, ShortHash) (TypeTag, ShortHash) Name Name Name Name <- + PG.transactionSpan "load type tags" mempty do + defns1 + & asListOf NamespaceDiffs.namespaceTreeDiffReferences_ %%~ \refs -> do + typeTags <- Codebase.typeTagsByReferencesOf traversed refs + pure $ zip typeTags (refs <&> V2Reference.toShortHash) + + -- Resolve the actual term/type definitions. Use the LCA as the "old" (because that's what we're rendering the diff + -- relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we won't have + -- anything classified as an "update" in this case so it doesn't really matter). + + let defns3 = + defns2 + & NamespaceDiffs.namespaceTreeDiffTermDiffs_ %~ (\name -> (oldTermDefinitionsByName Map.! name, newTermDefinitionsByName Map.! name)) + & NamespaceDiffs.witherNamespaceTreeDiffTermDiffs (Identity . diffTermsPure) + & runIdentity + & unsafePartsOf NamespaceDiffs.namespaceTreeDiffRenderedTerms_ + .~ map (either (oldTermDefinitionsByName Map.!) (newTermDefinitionsByName Map.!)) termNamesToRender + & NamespaceDiffs.witherNamespaceTreeTermDiffKinds (Identity . throwAwayConstructorDiffs) + & runIdentity + & NamespaceDiffs.namespaceTreeDiffTypeDiffs_ %~ (\name -> diffTypesPure (oldTypeDefinitionsByName Map.! name, newTypeDefinitionsByName Map.! name)) + & unsafePartsOf NamespaceDiffs.namespaceTreeDiffRenderedTypes_ + .~ map (either (oldTypeDefinitionsByName Map.!) (newTypeDefinitionsByName Map.!)) typeNamesToRender + -- Resolve libdeps branch hash ids to branch hashes - diff3 <- - PG.transactionSpan "hydrate-diff3" mempty $ + libdeps <- + PG.transactionSpan "load libdeps branch hashes" mempty do HashQ.expectNamespaceHashesByNamespaceHashIdsOf - (NamespaceDiffs.namespaceAndLibdepsDiffLibdeps_ . traversed . DiffOp.traverse) - diff2 - -- Resolve the actual term/type definitions. Use the LCA as the "old" (because that's what we're rendering the - -- diff relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we - -- won't have anything classified as an "update" in this case so it doesn't really matter). - diff4 <- - PG.transactionSpan "hydrate-diff4" mempty $ - diff3 - & NamespaceDiffs.namespaceAndLibdepsDiffDefns_ - %%~ computeUpdatedDefinitionDiffs - (oldCodebase, oldRuntime, fromMaybe oldPerspective maybeLcaPerspective) - (newCodebase, newRuntime, newPerspective) - pure diff4 - -computeUpdatedDefinitionDiffs :: - forall a b from to. - (Ord a, Ord b) => - (Codebase.CodebaseEnv, Codebase.CodebaseRuntime from IO, NamesPerspective (PG.Transaction NamespaceDiffError)) -> - (Codebase.CodebaseEnv, Codebase.CodebaseRuntime to IO, NamesPerspective (PG.Transaction NamespaceDiffError)) -> - GNamespaceTreeDiff NameSegment a b Name Name Name Name -> - PG.Transaction - NamespaceDiffError - (NamespaceDiffs.NamespaceTreeDiff a b TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff) -computeUpdatedDefinitionDiffs (fromCodebase, fromRuntime, fromPerspective) (toCodebase, toRuntime, toPerspective) diff0 = PG.transactionSpan "computeUpdatedDefinitionDiffs" mempty $ do - diff1 <- PG.transactionSpan "termDiffs" mempty $ do - diff0 - & NamespaceDiffs.namespaceTreeDiffTermDiffs_ %~ (\name -> (name, name)) - & expectTermDefinitionsOf fromCodebase fromRuntime fromPerspective (NamespaceDiffs.namespaceTreeDiffTermDiffs_ . _1) - >>= expectTermDefinitionsOf toCodebase toRuntime toPerspective (NamespaceDiffs.namespaceTreeDiffTermDiffs_ . _2) - >>= NamespaceDiffs.witherNamespaceTreeDiffTermDiffs (pure . diffTermsPure) - - diff2 <- PG.transactionSpan "termDiffKinds" mempty $ do - diff1 - & NamespaceDiffs.namespaceTreeTermDiffKinds_ %~ partitionDiffKind - & expectTermDefinitionsOf fromCodebase fromRuntime fromPerspective (NamespaceDiffs.namespaceTreeDiffRenderedTerms_ . _Left) - >>= expectTermDefinitionsOf toCodebase toRuntime toPerspective (NamespaceDiffs.namespaceTreeDiffRenderedTerms_ . _Right) - <&> NamespaceDiffs.namespaceTreeDiffRenderedTerms_ %~ either id id - >>= NamespaceDiffs.witherNamespaceTreeTermDiffKinds (pure . throwAwayConstructorDiffs) - - diff3 <- PG.transactionSpan "typeDiffs" mempty $ do - diff2 - & NamespaceDiffs.namespaceTreeDiffTypeDiffs_ %~ (\name -> (name, name)) - & expectTypeDefinitionsOf fromCodebase fromRuntime fromPerspective (NamespaceDiffs.namespaceTreeDiffTypeDiffs_ . _1) - >>= expectTypeDefinitionsOf toCodebase toRuntime toPerspective (NamespaceDiffs.namespaceTreeDiffTypeDiffs_ . _2) - <&> NamespaceDiffs.namespaceTreeDiffTypeDiffs_ %~ diffTypesPure - diff4 <- PG.transactionSpan "typeDiffKinds" mempty $ do - diff3 - & NamespaceDiffs.namespaceTreeTypeDiffKinds_ %~ partitionDiffKind - & expectTypeDefinitionsOf fromCodebase fromRuntime fromPerspective (NamespaceDiffs.namespaceTreeDiffRenderedTypes_ . _Left) - >>= expectTypeDefinitionsOf toCodebase fromRuntime toPerspective (NamespaceDiffs.namespaceTreeDiffRenderedTypes_ . _Right) - <&> NamespaceDiffs.namespaceTreeDiffRenderedTypes_ %~ either id id - pure (NamespaceDiffs.compressNameTree diff4) + (traversed . DiffOp.traverse) + diffblob.libdepsDiffs.bob + + pure + NamespaceDiffs.NamespaceAndLibdepsDiff + { defns = NamespaceDiffs.compressNameTree defns3, + libdeps + } where -- Splits the diff kind into the parts from the 'from' and 'to' sections of a diff. -- @@ -311,3 +353,15 @@ expectTypeDefinitionsOf codebase rt np trav s = for (zip names results) \case (name, Nothing) -> throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("Type not found: " <> Name.toText name <> ", in names perspective: " <> tShow np)) (_, Just typeDef) -> pure typeDef + +-- Quick helper that makes a `Map k v` from an input list of `k` and a monadic `v`-fetching function +-- +-- A simpler version of this might elide the traversal and instead just be: +-- +-- deriveMapOf :: (Ord k, Functor m) => ([k] -> m [v]) -> [k] -> m (Map k v) +-- +-- However, that'd require the caller to provide a `v`-fetching function that returns the same number of `v` as there +-- were `k` input. That's not hard to do, the traversal just does that for us (assuming it's law-abiding). +deriveMapOf :: (Ord k, Functor m) => (forall s t. Traversal s t k v -> s -> m t) -> [k] -> m (Map k v) +deriveMapOf f ks = do + Map.fromList . zip ks <$> f traverse ks From 46d2f86820885d57f28b9be8963fb8d8fb530325 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 11:00:32 -0400 Subject: [PATCH 03/14] cache hydrated terms and types --- src/Share/Codebase/CodeCache.hs | 19 +++++++------- src/Share/Codebase/Types.hs | 5 ++-- src/Share/NamespaceDiffs.hs | 31 ++++++++++++++++++----- src/Share/Postgres/Definitions/Queries.hs | 20 +++++++-------- src/Share/Web/Share/Diffs/Impl.hs | 4 ++- src/Unison/Server/Share/Definitions.hs | 2 +- 6 files changed, 50 insertions(+), 31 deletions(-) diff --git a/src/Share/Codebase/CodeCache.hs b/src/Share/Codebase/CodeCache.hs index 0d9a9b2e..85988d9b 100644 --- a/src/Share/Codebase/CodeCache.hs +++ b/src/Share/Codebase/CodeCache.hs @@ -34,6 +34,7 @@ import Unison.DataDeclaration qualified as V1 import Unison.DataDeclaration.ConstructorId qualified as V1Decl import Unison.Hash (Hash) import Unison.Parser.Ann +import Unison.Reference (TermReferenceId, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as V1Referent import Unison.Runtime.IOSource qualified as IOSource @@ -55,27 +56,25 @@ readCodeCache CodeCache {codeCacheVar} = PG.transactionUnsafeIO (readTVarIO code cacheTermAndTypes :: (QueryM m) => CodeCache s -> - [(Reference.Id, (V1.Term Symbol Ann, V1.Type Symbol Ann))] -> + Map TermReferenceId (V1.Term Symbol Ann, V1.Type Symbol Ann) -> m () cacheTermAndTypes CodeCache {codeCacheVar} termAndTypes = do PG.transactionUnsafeIO do atomically do modifyTVar' codeCacheVar \CodeCacheData {termCache, ..} -> - let newTermMap = Map.fromList termAndTypes - termCache' = Map.union termCache newTermMap + let !termCache' = Map.union termCache termAndTypes in CodeCacheData {termCache = termCache', ..} cacheDecls :: (QueryM m) => CodeCache s -> - [(Reference.Id, V1.Decl Symbol Ann)] -> + Map TypeReferenceId (V1.Decl Symbol Ann) -> m () cacheDecls CodeCache {codeCacheVar} decls = do PG.transactionUnsafeIO do atomically do modifyTVar' codeCacheVar \CodeCacheData {typeCache, ..} -> - let newDeclsMap = Map.fromList decls - typeCache' = Map.union typeCache newDeclsMap + let !typeCache' = Map.union typeCache decls in CodeCacheData {typeCache = typeCache', ..} builtinsCodeLookup :: (Monad m) => CL.CodeLookup Symbol m Ann @@ -123,8 +122,8 @@ getTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = Nothing -> (mempty, Nothing) Right tt -> (mempty, Just tt) - cacheTermAndTypes codeCache cacheable - pure $ hydrated' + cacheTermAndTypes codeCache (Map.fromList cacheable) + pure hydrated' where findBuiltinTT :: Reference.Id -> Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann) findBuiltinTT refId = do @@ -161,8 +160,8 @@ getTypeDeclsByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do Nothing -> (mempty, Nothing) Right decl -> (mempty, Just decl) - cacheDecls codeCache cacheable - pure $ hydrated' + cacheDecls codeCache (Map.fromList cacheable) + pure hydrated' where findBuiltinDecl :: Reference.Id -> Maybe (V1.Decl Symbol Ann) findBuiltinDecl refId = do diff --git a/src/Share/Codebase/Types.hs b/src/Share/Codebase/Types.hs index 39dde1ed..ab51a63d 100644 --- a/src/Share/Codebase/Types.hs +++ b/src/Share/Codebase/Types.hs @@ -21,6 +21,7 @@ import Unison.Codebase.Runtime qualified as Rt import Unison.DataDeclaration qualified as V1 import Unison.NameSegment.Internal (NameSegment (..)) import Unison.Parser.Ann (Ann) +import Unison.Reference (TermReferenceId, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Symbol (Symbol) import Unison.Term qualified as V1 @@ -44,8 +45,8 @@ data CodeCache scope = CodeCache } data CodeCacheData = CodeCacheData - { termCache :: Map Reference.Id (V1.Term Symbol Ann, V1.Type Symbol Ann), - typeCache :: Map Reference.Id (V1.Decl Symbol Ann) + { termCache :: Map TermReferenceId (V1.Term Symbol Ann, V1.Type Symbol Ann), + typeCache :: Map TypeReferenceId (V1.Decl Symbol Ann) } -- | The runtime environment for a codebase transaction. diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 08eaa3ba..cf42d63a 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -42,6 +42,8 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.NonEmpty qualified as NESet import Share.Codebase qualified as Codebase +import Share.Codebase.CodeCache qualified as CodeCache +import Share.Codebase.Types (CodeCache) import Share.Names.Postgres qualified as PGNames import Share.NamespaceDiffs.Types import Share.Postgres qualified as PG @@ -214,10 +216,12 @@ compressNameTree (diffs Cofree.:< children) = computeThreeWayNamespaceDiff :: Merge.TwoWay Codebase.CodebaseEnv -> + CodeCache alice -> + CodeCache bob -> Merge.TwoOrThreeWay BranchHashId -> Merge.TwoOrThreeWay NameLookupReceipt -> PG.Transaction NamespaceDiffError (Merge.Diffblob BranchHashId) -computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG.transactionSpan "computeThreeWayNamespaceDiff" mempty $ do +computeThreeWayNamespaceDiff codebaseEnvs2 aliceCodeCache bobCodeCache branchHashIds nameLookupReceipts = PG.transactionSpan "computeThreeWayNamespaceDiff" mempty do -- Load the shallow libdeps for Alice/Bob/LCA. This can fail with "lib at unexpected path" libdeps :: Merge.ThreeWay (Map NameSegment BranchHashId) <- do PG.transactionSpan "load libdeps" mempty do @@ -278,11 +282,11 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG hydrate Merge.ThreeWay {lca = lcaDefns, alice = aliceDefns, bob = bobDefns} = do -- We assume LCA and Alice come from the same codebase, so hydrate them together. let lcaAndAliceDefns = lcaDefns <> aliceDefns - lcaAndAliceHydratedDefns <- hydrateDefns "hydrate alice & lca definitions" codebaseEnvs2.alice lcaAndAliceDefns + lcaAndAliceHydratedDefns <- hydrateDefns "hydrate alice & lca definitions" codebaseEnvs2.alice aliceCodeCache lcaAndAliceDefns -- Only bother hydrating Bob defns that we haven't already found in Alice's codebase. let bobDefnsNotInAlice = Defns.zipDefnsWith Set.difference Set.difference bobDefns lcaAndAliceDefns - bobHydratedDefns <- hydrateDefns "hydrate bob definitions" codebaseEnvs2.bob bobDefnsNotInAlice + bobHydratedDefns <- hydrateDefns "hydrate bob definitions" codebaseEnvs2.bob bobCodeCache bobDefnsNotInAlice pure (lcaAndAliceHydratedDefns <> bobHydratedDefns) @@ -313,6 +317,7 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds nameLookupReceipts = PG hydrateDefns :: Text -> Codebase.CodebaseEnv -> + CodeCache scope -> DefnsF Set TermReferenceId TypeReferenceId -> PG.Transaction e @@ -320,13 +325,25 @@ hydrateDefns :: (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann)) (Map TypeReferenceId (Decl Symbol Ann)) ) -hydrateDefns description codebase Defns {terms, types} +hydrateDefns description codebase codeCache Defns {terms, types} | Set.null terms && Set.null types = pure (Defns Map.empty Map.empty) | otherwise = PG.transactionSpan description mempty do - Defns - <$> (if Set.null terms then pure Map.empty else Map.fromList <$> hydrateTermsOf codebase traversed (Set.toList terms)) - <*> (if Set.null types then pure Map.empty else Map.fromList <$> hydrateTypesOf codebase traversed (Set.toList types)) + hydratedTerms <- + if Set.null terms + then pure Map.empty + else do + hydratedTerms <- Map.fromList <$> hydrateTermsOf codebase traversed (Set.toList terms) + CodeCache.cacheTermAndTypes codeCache hydratedTerms + pure hydratedTerms + hydratedTypes <- + if Set.null types + then pure Map.empty + else do + hydratedTypes <- Map.fromList <$> hydrateTypesOf codebase traversed (Set.toList types) + CodeCache.cacheDecls codeCache hydratedTypes + pure hydratedTypes + pure Defns {terms = hydratedTerms, types = hydratedTypes} hydrateTermsOf :: Codebase.CodebaseEnv -> diff --git a/src/Share/Postgres/Definitions/Queries.hs b/src/Share/Postgres/Definitions/Queries.hs index b1f40b10..7fe53019 100644 --- a/src/Share/Postgres/Definitions/Queries.hs +++ b/src/Share/Postgres/Definitions/Queries.hs @@ -466,22 +466,22 @@ loadTypeComponentElementsAndTypeIdsOf (CodebaseEnv codebaseUser) trav s = do <&> \(ord, Reference.Id compHash compIndex) -> (ord, compHash, (pgComponentIndex compIndex)) queryListRows @(Maybe TypeComponentElement, Maybe TypeId) [sql| - WITH ref_ids(ord, comp_hash, comp_index) AS ( - SELECT t.ord, t.comp_hash, t.comp_index FROM ^{toTable refsTable} AS t(ord, comp_hash, comp_index) - ) SELECT bytes.bytes, typ.id - FROM ref_ids - LEFT JOIN component_hashes ch ON ref_ids.comp_hash = ch.base32 - LEFT JOIN types typ ON (typ.component_index = ref_ids.comp_index AND typ.component_hash_id = ch.id) - LEFT JOIN sandboxed_types sandboxed ON (typ.id = sandboxed.type_id AND sandboxed.user_id = #{codebaseUser}) - LEFT JOIN bytes ON sandboxed.bytes_id = bytes.id - ORDER BY ref_ids.ord ASC + WITH ref_ids(ord, comp_hash, comp_index) AS ( + SELECT t.ord, t.comp_hash, t.comp_index FROM ^{toTable refsTable} AS t(ord, comp_hash, comp_index) + ) SELECT bytes.bytes, typ.id + FROM ref_ids + LEFT JOIN component_hashes ch ON ref_ids.comp_hash = ch.base32 + LEFT JOIN types typ ON (typ.component_index = ref_ids.comp_index AND typ.component_hash_id = ch.id) + LEFT JOIN sandboxed_types sandboxed ON (typ.id = sandboxed.type_id AND sandboxed.user_id = #{codebaseUser}) + LEFT JOIN bytes ON sandboxed.bytes_id = bytes.id + ORDER BY ref_ids.ord ASC |] <&> fmap \(element, typeId) -> liftA2 (,) element typeId expectTypeComponentElementsAndTypeIdsOf :: (QueryA m) => CodebaseEnv -> Traversal s t TypeReferenceId (TypeComponentElement, TypeId) -> s -> m t expectTypeComponentElementsAndTypeIdsOf codebase trav s = s - & asListOfDeduped trav %%~ \refs -> do + & asListOf trav %%~ \refs -> do unrecoverableEitherMap ( \elems -> for (zip refs elems) \case (refId, Nothing) -> Left (expectedTypeError $ Right refId) diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index eea765e9..fa3e48b9 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -106,6 +106,8 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC diffblob <- NamespaceDiffs.computeThreeWayNamespaceDiff TwoWay {alice = oldCodebase, bob = newCodebase} + oldRuntime.codeCache + newRuntime.codeCache TwoOrThreeWay {alice = oldBranchHashId, bob = newBranchHashId, lca = maybeLcaBranchHashId} TwoOrThreeWay {alice = oldBranchNLReceipt, bob = newBranchNLReceipt, lca = maybeLcaBranchNLReceipt} @@ -331,7 +333,7 @@ getTypeDefinitionsOf :: m t getTypeDefinitionsOf codebase rt namesPerspective trav s = do s - & asListOfDeduped trav %%~ \names -> do + & asListOf trav %%~ \names -> do Definitions.typeDefinitionsByNamesOf codebase ppedBuilder namesPerspective renderWidth rt includeDocs traversed names where includeDocs = False diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index c386b181..d09f3b20 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -294,7 +294,7 @@ typeDefinitionsByNamesOf :: m t typeDefinitionsByNamesOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do s - & asListOfDeduped trav %%~ \allNames -> do + & asListOf trav %%~ \allNames -> do typeDisplayObjs <- typeDisplayObjectsByNamesOf codebase namesPerspective traversed allNames let addName name = \case Just (ref, displayObject) -> Just (name, ref, displayObject) From 46500b84f41a90fe030a4c3ed50c6198dca65172 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 12:23:47 -0400 Subject: [PATCH 04/14] use code caches when fetching terms and types after diff --- src/Share/Backend.hs | 21 ++-- .../BackgroundJobs/Search/DefinitionSync.hs | 18 +-- src/Share/Codebase/CodeCache.hs | 115 +++++++++++++++--- src/Share/NamespaceDiffs.hs | 20 +-- src/Share/NamespaceDiffs/Types.hs | 11 ++ src/Share/Web/Share/Branches/Impl.hs | 8 +- src/Share/Web/Share/Impl.hs | 8 +- src/Share/Web/Share/Releases/Impl.hs | 8 +- src/Unison/Server/Share/DefinitionSummary.hs | 13 +- src/Unison/Server/Share/Definitions.hs | 30 ++--- 10 files changed, 178 insertions(+), 74 deletions(-) diff --git a/src/Share/Backend.hs b/src/Share/Backend.hs index 9a85a80a..61616932 100644 --- a/src/Share/Backend.hs +++ b/src/Share/Backend.hs @@ -41,7 +41,7 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Share.Codebase qualified as Codebase import Share.Codebase.CodeCache qualified as CC -import Share.Codebase.Types (CodebaseRuntime (CodebaseRuntime, cachedEvalResult)) +import Share.Codebase.Types (CodeCache, CodebaseRuntime (CodebaseRuntime, cachedEvalResult)) import Share.Postgres (QueryM) import Share.Postgres qualified as PG import Share.Postgres.Causal.Conversions (namespaceStatsPgToV2) @@ -69,7 +69,7 @@ import Unison.NameSegment.Internal (NameSegment (..)) import Unison.Parser.Ann (Ann) import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED -import Unison.Reference (Reference) +import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as DD @@ -248,8 +248,13 @@ getTypeTagsOf trav s = do Just CT.Data -> Data Just CT.Effect -> Ability -displayTermsOf :: (QueryM m) => Codebase.CodebaseEnv -> Traversal s t Reference (DisplayObject (Type Symbol Ann) (V1.Term Symbol Ann)) -> s -> m t -displayTermsOf codebase trav s = +displayTermsOf :: + (QueryM m) => + CodeCache scope -> + Traversal s t TermReference (DisplayObject (Type Symbol Ann) (V1.Term Symbol Ann)) -> + s -> + m t +displayTermsOf codeCache trav s = s & asListOfDeduped trav %%~ \refs -> do let partitionedRefs = @@ -261,7 +266,7 @@ displayTermsOf codebase trav s = Nothing -> Left $ MissingObject $ Reference.toShortHash ref Just typ -> Left $ BuiltinObject (mempty <$ typ) Reference.DerivedId rid -> Right rid - r <- Codebase.expectTermsByRefIdsOf codebase (traversed . _Right) partitionedRefs + r <- CC.expectTermsAndTypesByRefIdsOf codeCache (traversed . _Right) partitionedRefs r & traversed %~ \case @@ -272,15 +277,15 @@ displayTermsOf codebase trav s = Left obj -> obj & pure -displayTypesOf :: (QueryM m) => Codebase.CodebaseEnv -> Traversal s t Reference (DisplayObject () (DD.Decl Symbol Ann)) -> s -> m t -displayTypesOf codebase trav s = +displayTypesOf :: (QueryM m) => CodeCache scope -> Traversal s t TypeReference (DisplayObject () (DD.Decl Symbol Ann)) -> s -> m t +displayTypesOf codeCache trav s = s & asListOf trav %%~ \refs -> do let partitionedRefs = refs <&> \case Reference.Builtin _ -> Left (BuiltinObject ()) Reference.DerivedId rid -> Right rid - Codebase.expectTypeDeclarationsByRefIdsOf codebase (traversed . _Right) partitionedRefs + CC.expectTypeDeclsByRefIdsOf codeCache (traversed . _Right) partitionedRefs <&> fmap \case Left obj -> obj Right decl -> (UserObject decl) diff --git a/src/Share/BackgroundJobs/Search/DefinitionSync.hs b/src/Share/BackgroundJobs/Search/DefinitionSync.hs index b9d9d7c5..03d69602 100644 --- a/src/Share/BackgroundJobs/Search/DefinitionSync.hs +++ b/src/Share/BackgroundJobs/Search/DefinitionSync.hs @@ -23,6 +23,7 @@ import Share.BackgroundJobs.Monad (Background) import Share.BackgroundJobs.Search.DefinitionSync.Types (Arity (..), DefinitionDocument (..), DefnSearchToken (..), Occurrence, OccurrenceKind (..), TermOrTypeSummary (..), TermOrTypeTag (..), VarId (..)) import Share.BackgroundJobs.Workers (newWorker) import Share.Codebase qualified as Codebase +import Share.Codebase.Types (CodeCache) import Share.IDs (ReleaseId, UserId) import Share.Metrics qualified as Metrics import Share.Postgres qualified as PG @@ -65,6 +66,7 @@ import Unison.Util.Monoid qualified as Monoid import Unison.Util.Recursion qualified as Rec import Unison.Util.Set qualified as Set import Unison.Var qualified as Var +import qualified Share.Codebase.CodeCache as CodeCache data DefnIndexingFailure = NoTypeSigForTerm Name Referent @@ -165,12 +167,13 @@ syncRoot authZReceipt (mayReleaseId, rootBranchHashId, codebaseOwner) = do let nlReceipt = nameLookupReceipt namesPerspective let codebaseLoc = Codebase.codebaseLocationForProjectRelease codebaseOwner let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc - termsCursor <- NLOps.projectTermsWithinRoot nlReceipt rootBranchHashId + CodeCache.withCodeCache codebase \codeCache -> do + termsCursor <- NLOps.projectTermsWithinRoot nlReceipt rootBranchHashId - termErrs <- syncTerms codebase namesPerspective rootBranchHashId termsCursor - typesCursor <- NLOps.projectTypesWithinRoot nlReceipt rootBranchHashId - typeErrs <- syncTypes codebase namesPerspective rootBranchHashId typesCursor - pure (termErrs <> typeErrs) + termErrs <- syncTerms codebase namesPerspective rootBranchHashId termsCursor + typesCursor <- NLOps.projectTypesWithinRoot nlReceipt rootBranchHashId + typeErrs <- syncTypes codebase codeCache namesPerspective rootBranchHashId typesCursor + pure (termErrs <> typeErrs) True -> pure mempty -- Copy relevant index rows into the global search index as well for mayReleaseId (syncRelease rootBranchHashId) @@ -370,11 +373,12 @@ typeSigTokens typ = syncTypes :: (PG.QueryM m) => Codebase.CodebaseEnv -> + CodeCache scope -> NamesPerspective m -> BranchHashId -> Cursors.PGCursor (Name, TypeReference) -> m ([DefnIndexingFailure], [Text]) -syncTypes codebase namesPerspective rootBranchHashId typesCursor = do +syncTypes codebase codeCache namesPerspective rootBranchHashId typesCursor = do Cursors.foldBatched typesCursor defnBatchSize \types -> do (errs, refDocs) <- types @@ -391,7 +395,7 @@ syncTypes codebase namesPerspective rootBranchHashId typesCursor = do decl <- lift (Codebase.loadV1TypeDeclarationsByRefIdsOf codebase id refId) `whenNothingM` throwError (NoDeclForType fqn ref) pure $ (tokensForDecl refId decl, Arity . fromIntegral . length . DD.bound $ DD.asDataDecl decl) let basicTokens = Set.fromList [NameToken fqn, HashToken $ Reference.toShortHash ref] - typeSummary <- lift $ Summary.typeSummaryForReference codebase ref (Just fqn) Nothing + typeSummary <- lift $ Summary.typeSummaryForReference codeCache ref (Just fqn) Nothing let sh = Reference.toShortHash ref let dd = DefinitionDocument diff --git a/src/Share/Codebase/CodeCache.hs b/src/Share/Codebase/CodeCache.hs index 85988d9b..86a68443 100644 --- a/src/Share/Codebase/CodeCache.hs +++ b/src/Share/Codebase/CodeCache.hs @@ -6,7 +6,9 @@ module Share.Codebase.CodeCache termsForRefsOf, typesOfReferentsOf, getTermsAndTypesByRefIdsOf, + expectTermsAndTypesByRefIdsOf, getTypeDeclsByRefIdsOf, + expectTypeDeclsByRefIdsOf, getTypeDeclsByRefsOf, cacheTermAndTypes, cacheDecls, @@ -15,6 +17,7 @@ where import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) import Control.Lens +import Control.Monad.State.Strict qualified as State import Data.Map qualified as Map import Data.Text qualified as Text import Share.Codebase qualified as Codebase @@ -44,6 +47,9 @@ import Unison.Term qualified as V1 import Unison.Type qualified as Type import Unison.Type qualified as V1 +type TermAndType = + (V1.Term Symbol Ann, V1.Type Symbol Ann) + withCodeCache :: (QueryM m) => CodebaseEnv -> (forall s. CodeCache s -> m r) -> m r withCodeCache codeCacheCodebaseEnv action = do codeCacheVar <- PG.transactionUnsafeIO (newTVarIO (CodeCacheData Map.empty Map.empty)) @@ -53,11 +59,7 @@ withCodeCache codeCacheCodebaseEnv action = do readCodeCache :: (QueryM m) => CodeCache s -> m CodeCacheData readCodeCache CodeCache {codeCacheVar} = PG.transactionUnsafeIO (readTVarIO codeCacheVar) -cacheTermAndTypes :: - (QueryM m) => - CodeCache s -> - Map TermReferenceId (V1.Term Symbol Ann, V1.Type Symbol Ann) -> - m () +cacheTermAndTypes :: (QueryM m) => CodeCache s -> Map TermReferenceId TermAndType -> m () cacheTermAndTypes CodeCache {codeCacheVar} termAndTypes = do PG.transactionUnsafeIO do atomically do @@ -96,7 +98,7 @@ toCodeLookup codeCache = do getTermsAndTypesByRefIdsOf :: (QueryM m) => CodeCache scope -> - Traversal s t Reference.Id (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) -> + Traversal s t TermReferenceId (Maybe TermAndType) -> s -> m t getTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do @@ -124,17 +126,49 @@ getTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = cacheTermAndTypes codeCache (Map.fromList cacheable) pure hydrated' - where - findBuiltinTT :: Reference.Id -> Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann) - findBuiltinTT refId = do - tm <- runIdentity $ CL.getTerm builtinsCodeLookup refId - typ <- runIdentity $ CL.getTypeOfTerm builtinsCodeLookup refId - pure (tm, typ) + +-- | Like 'getTermsAndTypesByRefIdsOf', but throws an unrecoverable error when the term isn't in the database. +expectTermsAndTypesByRefIdsOf :: + (QueryM m) => + CodeCache scope -> + Traversal s t TermReferenceId TermAndType -> + s -> + m t +expectTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do + CodeCacheData {termCache} <- readCodeCache codeCache + s + & asListOf trav %%~ \refs -> do + -- Partition by cache misses + let terms0 :: [Either (TermReferenceId, TermReferenceId) TermAndType] + terms0 = + refs + <&> \ref -> + case findBuiltinTT ref <|> Map.lookup ref termCache of + Just termAndType -> Right termAndType + Nothing -> Left (ref, ref) + + -- Fetch all cache misses from database + terms1 :: [Either (TermReferenceId, TermAndType) TermAndType] <- + Codebase.expectTermsByRefIdsOf codeCacheCodebaseEnv (traversed . _Left . _2) terms0 + + -- Tease out the just-fetched things to add to the cache + let terms2 :: [TermAndType] + justFetched :: Map TermReferenceId TermAndType + (terms2, justFetched) = teaseOutJustFetched terms1 + + cacheTermAndTypes codeCache justFetched + pure terms2 + +findBuiltinTT :: TermReferenceId -> Maybe TermAndType +findBuiltinTT refId = do + tm <- runIdentity $ CL.getTerm builtinsCodeLookup refId + typ <- runIdentity $ CL.getTypeOfTerm builtinsCodeLookup refId + pure (tm, typ) getTypeDeclsByRefIdsOf :: (QueryM m) => CodeCache scope -> - Traversal s t Reference.Id (Maybe (V1.Decl Symbol Ann)) -> + Traversal s t TypeReferenceId (Maybe (V1.Decl Symbol Ann)) -> s -> m t getTypeDeclsByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do @@ -162,10 +196,53 @@ getTypeDeclsByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do cacheDecls codeCache (Map.fromList cacheable) pure hydrated' + +expectTypeDeclsByRefIdsOf :: + (QueryM m) => + CodeCache scope -> + Traversal s t TypeReferenceId (V1.Decl Symbol Ann) -> + s -> + m t +expectTypeDeclsByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do + CodeCacheData {typeCache} <- readCodeCache codeCache + s + & asListOf trav %%~ \refs -> do + -- Partition by cache misses + let types0 :: [Either (TypeReferenceId, TypeReferenceId) (V1.Decl Symbol Ann)] + types0 = + refs + <&> \ref -> + case findBuiltinDecl ref <|> Map.lookup ref typeCache of + Just typ -> Right typ + Nothing -> Left (ref, ref) + + -- Fetch all cache misses from database + types1 :: [Either (TypeReferenceId, V1.Decl Symbol Ann) (V1.Decl Symbol Ann)] <- + Codebase.expectTypeDeclarationsByRefIdsOf codeCacheCodebaseEnv (traversed . _Left . _2) types0 + + -- Tease out the just-fetched things to add to the cache + let types2 :: [V1.Decl Symbol Ann] + justFetched :: Map TypeReferenceId (V1.Decl Symbol Ann) + (types2, justFetched) = teaseOutJustFetched types1 + + cacheDecls codeCache justFetched + pure types2 + +findBuiltinDecl :: Reference.Id -> Maybe (V1.Decl Symbol Ann) +findBuiltinDecl refId = do + runIdentity $ CL.getTypeDeclaration builtinsCodeLookup refId + +-- Tease out the just-fetched things to add to the cache +teaseOutJustFetched :: forall a ref. (Ord ref) => [Either (ref, a) a] -> ([a], Map ref a) +teaseOutJustFetched terms1 = + runState (traverse recordJustFetched terms1) Map.empty where - findBuiltinDecl :: Reference.Id -> Maybe (V1.Decl Symbol Ann) - findBuiltinDecl refId = do - runIdentity $ CL.getTypeDeclaration builtinsCodeLookup refId + recordJustFetched :: Either (ref, a) a -> State (Map ref a) a + recordJustFetched = \case + Left (ref, term) -> do + State.modify' (Map.insert ref term) + pure term + Right term -> pure term getTypeDeclsByRefsOf :: (QueryM m) => @@ -195,7 +272,7 @@ termsForRefsOf codeCache trav s = do s & asListOf trav %%~ \refs -> do - let trav :: Traversal Reference (Maybe (V1.Term Symbol ())) Reference.Id (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) + let trav :: Traversal Reference (Maybe (V1.Term Symbol ())) Reference.Id (Maybe TermAndType) trav f = \case -- Builtins are their own terms ref@(Reference.Builtin _) -> pure (Just (Term.ref () ref)) @@ -240,7 +317,7 @@ typesOfReferentsOf codeCache trav s = do [ Either (V1.Type Symbol ()) ( Either - (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) + (Maybe TermAndType) (Reference.Id' Hash, V1Decl.ConstructorId) ) ] <- @@ -249,7 +326,7 @@ typesOfReferentsOf codeCache trav s = do [ Either (V1.Type Symbol ()) ( Either - (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) + (Maybe TermAndType) (Maybe (V1.Decl Symbol Ann), V1Decl.ConstructorId) ) ] <- diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index cf42d63a..50189e43 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -28,6 +28,7 @@ module Share.NamespaceDiffs namespaceAndLibdepsDiffDefns_, namespaceAndLibdepsDiffLibdeps_, definitionDiffKindRendered_, + definitionDiffKindRefsAndRendered_, ) where @@ -93,11 +94,10 @@ definitionDiffsToTree :: (Ord ref) => DefinitionDiffs Name ref -> GNamespaceTreeOf NameSegment (Set (DefinitionDiff ref Name Name)) -definitionDiffsToTree dd = - let DefinitionDiffs {added, removed, updated, propagated, renamed, newAliases} = dd - expandedAliases :: Map Name (Set (DefinitionDiffKind ref Name Name)) +definitionDiffsToTree diff = + let expandedAliases :: Map Name (Set (DefinitionDiffKind ref Name Name)) expandedAliases = - newAliases + diff.newAliases & Map.toList & foldMap ( \(r, (existingNames, newNames)) -> @@ -108,7 +108,7 @@ definitionDiffsToTree dd = & Map.unionsWith (<>) expandedRenames :: Map Name (Set (DefinitionDiffKind ref Name Name)) expandedRenames = - renamed + diff.renamed & Map.toList & foldMap \(r, (oldNames, newNames)) -> ( -- We don't currently want to track the old names in a rename, and including them messes up @@ -125,12 +125,12 @@ definitionDiffsToTree dd = diffTree :: Map Name (Set (DefinitionDiffKind ref Name Name)) diffTree = Map.unionsWith - (<>) - [ (added & Map.mapWithKey \n r -> Set.singleton $ Added r n), + Set.union + [ (diff.added & Map.mapWithKey \n r -> Set.singleton $ Added r n), expandedAliases, - (removed & Map.mapWithKey \n r -> Set.singleton $ Removed r n), - (updated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Updated oldR newR name), - (propagated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Propagated oldR newR name), + (diff.removed & Map.mapWithKey \n r -> Set.singleton $ Removed r n), + (diff.updated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Updated oldR newR name), + (diff.propagated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Propagated oldR newR name), expandedRenames ] includeFQNs :: Map Name (Set (DefinitionDiffKind ref Name Name)) -> Map Name (Set (DefinitionDiff ref Name Name)) diff --git a/src/Share/NamespaceDiffs/Types.hs b/src/Share/NamespaceDiffs/Types.hs index d99154ae..a09fd251 100644 --- a/src/Share/NamespaceDiffs/Types.hs +++ b/src/Share/NamespaceDiffs/Types.hs @@ -25,6 +25,7 @@ module Share.NamespaceDiffs.Types namespaceTreeDiffRenderedTerms_, namespaceTreeDiffRenderedTypes_, definitionDiffKindRendered_, + definitionDiffKindRefsAndRendered_, ) where @@ -187,6 +188,16 @@ definitionDiffKindRendered_ f = \case RenamedTo r old rendered -> RenamedTo r old <$> f rendered RenamedFrom r old rendered -> RenamedFrom r old <$> f rendered +definitionDiffKindRefsAndRendered_ :: Traversal (DefinitionDiffKind r rendered diff) (DefinitionDiffKind r rendered' diff) (r, rendered) (r, rendered') +definitionDiffKindRefsAndRendered_ f = \case + Added r rendered -> (\(r', rendered') -> Added r' rendered') <$> f (r, rendered) + NewAlias r ns rendered -> (\(r', rendered') -> NewAlias r' ns rendered') <$> f (r, rendered) + Removed r rendered -> (\(r', rendered') -> Removed r' rendered') <$> f (r, rendered) + Propagated old new diff -> Propagated old new <$> pure diff + Updated old new diff -> Updated old new <$> pure diff + RenamedTo r old rendered -> (\(r', rendered') -> RenamedTo r' old rendered') <$> f (r, rendered) + RenamedFrom r old rendered -> (\(r', rendered') -> RenamedFrom r' old rendered') <$> f (r, rendered) + data NamespaceDiffResult = NamespaceDiffResult'Ok ( NamespaceAndLibdepsDiff diff --git a/src/Share/Web/Share/Branches/Impl.hs b/src/Share/Web/Share/Branches/Impl.hs index eff47494..5523d921 100644 --- a/src/Share/Web/Share/Branches/Impl.hs +++ b/src/Share/Web/Share/Branches/Impl.hs @@ -13,6 +13,7 @@ import Data.Time (UTCTime) import Servant import Share.Branch (Branch (..), branchCausals_) import Share.Codebase qualified as Codebase +import Share.Codebase.CodeCache qualified as CodeCache import Share.Codebase.CodebaseRuntime qualified as CR import Share.Env qualified as Env import Share.IDs (BranchId, BranchShortHand (..), ProjectBranchShortHand (..), ProjectShortHand (..), ProjectSlug (..), UserHandle, UserId) @@ -227,9 +228,10 @@ projectBranchTypeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHand let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc causalId <- resolveRootHash codebase branchHead rootHash - Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-branch-type-summary" cacheParams causalId $ do - PG.runTransactionMode PG.ReadCommitted PG.ReadWrite $ do - serveTypeSummary codebase ref mayName renderWidth + Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-branch-type-summary" cacheParams causalId do + PG.runTransactionMode PG.ReadCommitted PG.ReadWrite do + CodeCache.withCodeCache codebase \codeCache -> do + serveTypeSummary codeCache ref mayName renderWidth where projectBranchShortHand = ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName} cacheParams = [IDs.toText projectBranchShortHand, toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe mempty relativeTo, foldMap toUrlPiece renderWidth] diff --git a/src/Share/Web/Share/Impl.hs b/src/Share/Web/Share/Impl.hs index 3f15e487..3f4257d2 100644 --- a/src/Share/Web/Share/Impl.hs +++ b/src/Share/Web/Share/Impl.hs @@ -12,6 +12,7 @@ import Data.Text qualified as Text import Servant import Share.Branch qualified as Branch import Share.Codebase qualified as Codebase +import Share.Codebase.CodeCache qualified as CodeCache import Share.Codebase.CodebaseRuntime qualified as CR import Share.Codebase.Types qualified as Codebase import Share.Env qualified as Env @@ -238,9 +239,10 @@ typeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle ref mayNam authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkReadUserCodebase callerUserId codebaseOwner authPath let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc (rootCausalId, _rootCausalHash) <- PG.runTransactionMode PG.ReadCommitted PG.Read $ Codebase.expectLooseCodeRoot codebase - Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "type-summary" cacheParams rootCausalId $ do - PG.runTransactionMode PG.ReadCommitted PG.ReadWrite $ do - serveTypeSummary codebase ref mayName renderWidth + Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "type-summary" cacheParams rootCausalId do + PG.runTransactionMode PG.ReadCommitted PG.ReadWrite do + CodeCache.withCodeCache codebase \codeCache -> do + serveTypeSummary codeCache ref mayName renderWidth where cacheParams = [toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe mempty relativeTo, foldMap toUrlPiece renderWidth] authPath :: Path.Path diff --git a/src/Share/Web/Share/Releases/Impl.hs b/src/Share/Web/Share/Releases/Impl.hs index 901b1b81..ccb37fdb 100644 --- a/src/Share/Web/Share/Releases/Impl.hs +++ b/src/Share/Web/Share/Releases/Impl.hs @@ -68,6 +68,7 @@ import Unison.Server.Share.RenderDoc (findAndRenderDoc) import Unison.Server.Types (DefinitionDisplayResults, NamespaceDetails (..), Suffixify (..)) import Unison.Syntax.Name qualified as Name import Unison.Util.Pretty qualified as Pretty +import qualified Share.Codebase.CodeCache as CodeCache releasesServer :: Maybe Session -> UserHandle -> ProjectSlug -> ServerT API.ProjectReleasesAPI WebApp releasesServer session handle projectSlug = @@ -227,9 +228,10 @@ projectReleaseTypeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHan authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkProjectReleaseRead callerUserId projectId let codebaseLoc = Codebase.codebaseLocationForProjectRelease projectOwnerUserId let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc - Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-release-type-summary" cacheParams releaseHead $ do - PG.runTransactionMode PG.ReadCommitted PG.ReadWrite $ do - serveTypeSummary codebase ref mayName renderWidth + Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-release-type-summary" cacheParams releaseHead do + PG.runTransactionMode PG.ReadCommitted PG.ReadWrite do + CodeCache.withCodeCache codebase \codeCache -> do + serveTypeSummary codeCache ref mayName renderWidth where projectReleaseShortHand = ProjectReleaseShortHand {userHandle, projectSlug, releaseVersion} cacheParams = [IDs.toText projectReleaseShortHand, toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe mempty relativeTo, foldMap toUrlPiece renderWidth] diff --git a/src/Unison/Server/Share/DefinitionSummary.hs b/src/Unison/Server/Share/DefinitionSummary.hs index 0b74e83d..c52def64 100644 --- a/src/Unison/Server/Share/DefinitionSummary.hs +++ b/src/Unison/Server/Share/DefinitionSummary.hs @@ -18,6 +18,7 @@ where import Share.Backend qualified as Backend import Share.Codebase qualified as Codebase +import Share.Codebase.Types (CodeCache) import Share.Postgres (QueryM, unrecoverableError) import Share.Postgres.Hashes.Queries qualified as HashQ import Share.Postgres.IDs (BranchHashId, CausalId) @@ -91,26 +92,26 @@ termSummaryForReferent referent typeSig mayName rootBranchHashId relativeTo mayW serveTypeSummary :: (QueryM m) => - Codebase.CodebaseEnv -> + CodeCache scope -> Reference -> Maybe Name -> Maybe Width -> m TypeSummary -serveTypeSummary codebase reference mayName mayWidth = do - typeSummaryForReference codebase reference mayName mayWidth +serveTypeSummary codeCache reference mayName mayWidth = do + typeSummaryForReference codeCache reference mayName mayWidth typeSummaryForReference :: (QueryM m) => - Codebase.CodebaseEnv -> + CodeCache scope -> Reference -> Maybe Name -> Maybe Width -> m TypeSummary -typeSummaryForReference codebase reference mayName mayWidth = do +typeSummaryForReference codeCache reference mayName mayWidth = do let shortHash = Reference.toShortHash reference let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName tag <- Backend.getTypeTagsOf id reference - displayDecl <- Backend.displayTypesOf codebase id reference + displayDecl <- Backend.displayTypesOf codeCache id reference let syntaxHeader = Backend.typeToSyntaxHeader width displayName displayDecl pure $ TypeSummary diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index d09f3b20..980228e1 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -16,7 +16,7 @@ import Data.Set.NonEmpty qualified as NESet import Share.Backend qualified as Backend import Share.Codebase (CodebaseEnv, CodebaseRuntime) import Share.Codebase qualified as Codebase -import Share.Codebase.Types (CodebaseEnv (..)) +import Share.Codebase.Types (CodeCache, CodebaseEnv (..)) import Share.Postgres (QueryM, transactionSpan) import Share.Postgres.Causal.Queries qualified as CausalQ import Share.Postgres.IDs (CausalId) @@ -115,7 +115,7 @@ definitionForHQName codebase@(CodebaseEnv {codebaseOwner}) perspective rootCausa let biases = maybeToList $ HQ.toName query let ppedBuilder deps = (PPED.biasTo biases) <$> (PPEPostgres.ppedForReferences perspectiveNP deps) let nameSearch = PGNameSearch.nameSearchForPerspective perspectiveNP - dr@(Backend.DefinitionResults terms types misses) <- mkDefinitionsForQuery codebase nameSearch [query] + dr@(Backend.DefinitionResults terms types misses) <- mkDefinitionsForQuery rt.codeCache nameSearch [query] let width = mayDefaultWidth renderWidth let docResultsOf :: forall s t. Traversal s t Name [(HashQualifiedName, UnisonHash, Doc.Doc)] -> s -> m t docResultsOf trav s = do @@ -177,19 +177,19 @@ type PPEDBuilder m = Set LD.LabeledDependency -> m PPED.PrettyPrintEnvDecl -- | Mirrors Backend.definitionsBySuffixes but without doing a suffix search. mkDefinitionsForQuery :: (QueryM m) => - CodebaseEnv -> + CodeCache scope -> NameSearch m -> [HQ.HashQualified Name] -> m Backend.DefinitionResults -mkDefinitionsForQuery codebase nameSearch query = do +mkDefinitionsForQuery codeCache nameSearch query = do QueryResult misses results <- hqNameQuery nameSearch query let termRefs = Set.toList $ searchResultsToTermRefs results -- todo: remember to replace this with getting components directly, -- and maybe even remove getComponentLength from Codebase interface altogether - displayedTerms <- Backend.displayTermsOf codebase traversed termRefs + displayedTerms <- Backend.displayTermsOf codeCache traversed termRefs let termsMap = Map.fromList (zip termRefs displayedTerms) let typeRefsMap = Data.mapFromSelf . Set.toList $ searchResultsToTypeRefs results - typesMap <- Backend.displayTypesOf codebase traversed typeRefsMap + typesMap <- Backend.displayTypesOf codeCache traversed typeRefsMap pure (Backend.DefinitionResults termsMap typesMap misses) where searchResultsToTermRefs :: [SR.SearchResult] -> Set V1.Reference @@ -210,12 +210,12 @@ mkDefinitionsForQuery codebase nameSearch query = do -- Just Right means term termDisplayObjectsByNamesOf :: (QueryM m) => - Codebase.CodebaseEnv -> + CodeCache scope -> NamesPerspective m -> Traversal s t Name (Maybe (Either ConstructorReference (TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann)))) -> s -> m t -termDisplayObjectsByNamesOf codebase namesPerspective trav s = do +termDisplayObjectsByNamesOf codeCache namesPerspective trav s = do s & asListOfDeduped trav %%~ \names -> do allRefs <- PGNameSearch.termRefsByHQNamesOf namesPerspective traversed (HQ'.NameOnly <$> names) @@ -227,7 +227,7 @@ termDisplayObjectsByNamesOf codebase namesPerspective trav s = do <&> \case (Referent.Ref r) -> Right $ (r, r) (Referent.Con r _) -> (Left r) - Backend.displayTermsOf codebase (traversed . _Just . _Right . _2) partitionedRefs + Backend.displayTermsOf codeCache (traversed . _Just . _Right . _2) partitionedRefs termDefinitionByNamesOf :: (QueryM m) => @@ -243,7 +243,7 @@ termDefinitionByNamesOf :: termDefinitionByNamesOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do s & asListOf trav %%~ \allNames -> do - constructorsAndRendered <- termDisplayObjectsByNamesOf codebase namesPerspective traversed allNames + constructorsAndRendered <- termDisplayObjectsByNamesOf rt.codeCache namesPerspective traversed allNames let addName name = \case Just (Right (termRef, displayObject)) -> Just (Right (name, termRef, displayObject)) Just (Left constructorRef) -> Just (Left constructorRef) @@ -265,19 +265,19 @@ termDefinitionByNamesOf codebase ppedBuilder namesPerspective width rt includeDo let syntaxDOs = snd <$> Backend.termsToSyntaxOf (Suffixify False) width pped traversed (zip refs dos) Backend.mkTermDefinitionsOf codebase pped width traversed (zip4 (Just <$> names) refs allRenderedDocs syntaxDOs) -termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> (Set LD.LabeledDependency) +termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> Set LD.LabeledDependency termDisplayObjectLabeledDependencies termRef displayObject = do displayObject & bifoldMap (Type.labeledDependencies) (Term.labeledDependencies) & Set.insert (LD.TermReference termRef) -typeDisplayObjectsByNamesOf :: (QueryM m) => Codebase.CodebaseEnv -> NamesPerspective m -> Traversal s t Name (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann))) -> s -> m t -typeDisplayObjectsByNamesOf codebase namesPerspective trav s = do +typeDisplayObjectsByNamesOf :: (QueryM m) => CodeCache scope -> NamesPerspective m -> Traversal s t Name (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann))) -> s -> m t +typeDisplayObjectsByNamesOf codeCache namesPerspective trav s = do s & asListOf trav %%~ \names -> do foundRefs <- PGNameSearch.typeRefsByHQNamesOf namesPerspective traversed (HQ'.NameOnly <$> names) let refs = fmap (\ref -> (ref, ref)) . Set.lookupMin <$> foundRefs - Backend.displayTypesOf codebase (traversed . _Just . _2) refs + Backend.displayTypesOf codeCache (traversed . _Just . _2) refs -- | NOTE: If you're displaying many definitions you should probably generate a single PPED to -- share among all of them, it would be more efficient than generating a PPED per definition. @@ -295,7 +295,7 @@ typeDefinitionsByNamesOf :: typeDefinitionsByNamesOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do s & asListOf trav %%~ \allNames -> do - typeDisplayObjs <- typeDisplayObjectsByNamesOf codebase namesPerspective traversed allNames + typeDisplayObjs <- typeDisplayObjectsByNamesOf rt.codeCache namesPerspective traversed allNames let addName name = \case Just (ref, displayObject) -> Just (name, ref, displayObject) Nothing -> Nothing From 4c79d57e625b30d84bf560168d1a89ef70f59e32 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 13:40:23 -0400 Subject: [PATCH 05/14] don't include propagated changes in the diff blob at all --- src/Share/NamespaceDiffs.hs | 1 - src/Share/Web/Share/Diffs/Impl.hs | 12 +++++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 50189e43..6472d495 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -130,7 +130,6 @@ definitionDiffsToTree diff = expandedAliases, (diff.removed & Map.mapWithKey \n r -> Set.singleton $ Removed r n), (diff.updated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Updated oldR newR name), - (diff.propagated & Map.mapWithKey \name (oldR, newR) -> Set.singleton $ Propagated oldR newR name), expandedRenames ] includeFQNs :: Map Name (Set (DefinitionDiffKind ref Name Name)) -> Map Name (Set (DefinitionDiff ref Name Name)) diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index fa3e48b9..f57dfaa6 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -64,10 +64,11 @@ computeAndStoreCausalDiff authZReceipt old@(oldCodebase, _, oldCausalId) new@(ne Right diff -> NamespaceDiffs.NamespaceDiffResult'Ok diff Left err -> NamespaceDiffs.NamespaceDiffResult'Err err let encoded = Aeson.encode result - ContributionQ.savePrecomputedNamespaceDiff - (oldCodebase, oldCausalId) - (newCodebase, newCausalId) - (TL.toStrict $ TL.decodeUtf8 encoded) + PG.transactionSpan "savePrecomputedNamespaceDiff" mempty do + ContributionQ.savePrecomputedNamespaceDiff + (oldCodebase, oldCausalId) + (newCodebase, newCausalId) + (TL.toStrict $ TL.decodeUtf8 encoded) pure (PreEncoded encoded) tryComputeCausalDiff :: @@ -188,7 +189,8 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC -- relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we won't have -- anything classified as an "update" in this case so it doesn't really matter). - let defns3 = + let defns3 :: GNamespaceTreeDiff NameSegment (TermTag, ShortHash) (TypeTag, ShortHash) TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff + defns3 = defns2 & NamespaceDiffs.namespaceTreeDiffTermDiffs_ %~ (\name -> (oldTermDefinitionsByName Map.! name, newTermDefinitionsByName Map.! name)) & NamespaceDiffs.witherNamespaceTreeDiffTermDiffs (Identity . diffTermsPure) From fcbcd61b86ce4144d0531437cd816b225fec41b6 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 17:27:04 -0400 Subject: [PATCH 06/14] re-run transcripts --- .../codebase-namespace-by-name-root.json | 2 +- .../contribution-diffs/contribution-diff.json | 416 +----------------- .../contribution-diffs/namespace-diff.json | 416 +----------------- .../sync-apis/pull-without-history.output.md | 2 + transcripts/sync-apis/sync.output.md | 4 +- 5 files changed, 10 insertions(+), 830 deletions(-) diff --git a/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json b/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json index dea96bf8..ccdb7eed 100644 --- a/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json +++ b/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json @@ -1,7 +1,7 @@ { "body": { "fqn": "", - "hash": "#atdvemjjjgksnq8t3cv420dlusb37r21349m7nglli3r8n1d5q063s8cn0aravas8dt1ofuu9t0ge5civ11begb43meo339t498aj7g", + "hash": "#hjj7spb37rsmv6eojjite9l0eomq9m85gnrnt8oiuvta41rr28sj239tib8b7qhk87hnm560fikbtb1heou3epvrq5118ej5thk3hs0", "readme": null }, "status": [ diff --git a/transcripts/share-apis/contribution-diffs/contribution-diff.json b/transcripts/share-apis/contribution-diffs/contribution-diff.json index 172ac1b2..faa1d4f4 100644 --- a/transcripts/share-apis/contribution-diffs/contribution-diff.json +++ b/transcripts/share-apis/contribution-diffs/contribution-diff.json @@ -1737,418 +1737,6 @@ }, "tag": "Plain" }, - { - "contents": { - "contents": { - "diff": { - "diff": { - "diff": { - "contents": [ - { - "diffTag": "both", - "elements": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "diffTag": "annotationChange", - "fromAnnotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe", - "toAnnotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - } - }, - { - "diffTag": "both", - "elements": [ - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "diffTag": "annotationChange", - "fromAnnotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe", - "toAnnotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - } - } - ], - "tag": "UserObject" - }, - "diffKind": "diff" - }, - "left": { - "bestTermName": "termDependsOnUpdateMe", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "termDependsOnUpdateMe" - ] - }, - "right": { - "bestTermName": "termDependsOnUpdateMe", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "termDependsOnUpdateMe" - ] - } - }, - "fullName": "termDependsOnUpdateMe", - "newHash": "#t3u2jnk3eej5hrcrfr80vqiaj7n26grg15n4eb67bd1601jb65ikhbfdk18eeirovmaithk3ipukum6qnhttld43ovitj01kdkd4jrg", - "newTag": "Plain", - "oldHash": "#8imj19nvqqdtl1jd9ns5fksnuh4slku9hoi3sl7dh353k7o209eek4aievkp1sbqq5lqpgqouvf00k5b6t1fkv8omnpsnvmpu0a5lr8", - "oldTag": "Plain", - "shortName": "termDependsOnUpdateMe" - }, - "tag": "Propagated" - }, - "tag": "Plain" - }, { "contents": { "contents": { @@ -2675,9 +2263,9 @@ "tag": "ok" }, "newRef": "diff-end", - "newRefHash": "#j34aadhp37a5fhfbph4hc7i0pp7nlr48otdbapdue4kgmtt3e63evn2p46um4il8q45ltqu4msms93a34ptkhpjlctto2il89sd47u8", + "newRefHash": "#lau4pa7q7ul1ub9m0f13kg3soqjmdsu173n9j36a7u0t6hp81kmfqgfv3pm0tp6i0kjb80ae1bb4a2eo3aa6c7jscqgin3rati2t0t0", "oldRef": "diff-start", - "oldRefHash": "#slt6ihj3f9r5eavshflld6q5gkjq2fc42f5vpco02u2mp7els39k0ai630eqncbpihosroutg8km6cf4t922h445vki1ofe4hsl24ig", + "oldRefHash": "#vu2ddn75mpvl8jv01c4tnmvddm8e2q1e2nb9qj2c6qb0j3dl6har1v07l3vmm18ap1p0qos9pgo82f19enaboighed7bnal6t7jcumo", "project": "@transcripts/contribution-diff", "tag": "done" }, diff --git a/transcripts/share-apis/contribution-diffs/namespace-diff.json b/transcripts/share-apis/contribution-diffs/namespace-diff.json index 172ac1b2..faa1d4f4 100644 --- a/transcripts/share-apis/contribution-diffs/namespace-diff.json +++ b/transcripts/share-apis/contribution-diffs/namespace-diff.json @@ -1737,418 +1737,6 @@ }, "tag": "Plain" }, - { - "contents": { - "contents": { - "diff": { - "diff": { - "diff": { - "contents": [ - { - "diffTag": "both", - "elements": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "diffTag": "annotationChange", - "fromAnnotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe", - "toAnnotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - } - }, - { - "diffTag": "both", - "elements": [ - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - } - ] - }, - { - "diffTag": "annotationChange", - "fromAnnotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe", - "toAnnotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - } - } - ], - "tag": "UserObject" - }, - "diffKind": "diff" - }, - "left": { - "bestTermName": "termDependsOnUpdateMe", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#ofktbubbloi1omgpr09e0t90pg0cnf0lsuuopqese9biqvpdafsuhq0b4dfasbk6g3hp5r7crp4t486fc8bava7q7rrreg9j2volam8", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "termDependsOnUpdateMe" - ] - }, - "right": { - "bestTermName": "termDependsOnUpdateMe", - "defnTermTag": "Plain", - "signature": [ - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text", - "tag": "TypeReference" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "termDependsOnUpdateMe", - "tag": "HashQualifier" - }, - "segment": "termDependsOnUpdateMe" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseKeyword" - }, - "segment": "use " - }, - { - "annotation": { - "tag": "UsePrefix" - }, - "segment": "Text" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "UseSuffix" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Text.++", - "tag": "TermReference" - }, - "segment": "++" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "#711u1t9cjso4t3rhlq2rp491n2n5n4t9o7701053kpj5ouu3kfs2e2l63i879pnsb6ob9fp0gpj18u6fpcl1qosd704h4doklfo734g", - "tag": "TermReference" - }, - "segment": "termUpdateMe" - } - ], - "tag": "UserObject" - }, - "termDocs": [], - "termNames": [ - "termDependsOnUpdateMe" - ] - } - }, - "fullName": "termDependsOnUpdateMe", - "newHash": "#t3u2jnk3eej5hrcrfr80vqiaj7n26grg15n4eb67bd1601jb65ikhbfdk18eeirovmaithk3ipukum6qnhttld43ovitj01kdkd4jrg", - "newTag": "Plain", - "oldHash": "#8imj19nvqqdtl1jd9ns5fksnuh4slku9hoi3sl7dh353k7o209eek4aievkp1sbqq5lqpgqouvf00k5b6t1fkv8omnpsnvmpu0a5lr8", - "oldTag": "Plain", - "shortName": "termDependsOnUpdateMe" - }, - "tag": "Propagated" - }, - "tag": "Plain" - }, { "contents": { "contents": { @@ -2675,9 +2263,9 @@ "tag": "ok" }, "newRef": "diff-end", - "newRefHash": "#j34aadhp37a5fhfbph4hc7i0pp7nlr48otdbapdue4kgmtt3e63evn2p46um4il8q45ltqu4msms93a34ptkhpjlctto2il89sd47u8", + "newRefHash": "#lau4pa7q7ul1ub9m0f13kg3soqjmdsu173n9j36a7u0t6hp81kmfqgfv3pm0tp6i0kjb80ae1bb4a2eo3aa6c7jscqgin3rati2t0t0", "oldRef": "diff-start", - "oldRefHash": "#slt6ihj3f9r5eavshflld6q5gkjq2fc42f5vpco02u2mp7els39k0ai630eqncbpihosroutg8km6cf4t922h445vki1ofe4hsl24ig", + "oldRefHash": "#vu2ddn75mpvl8jv01c4tnmvddm8e2q1e2nb9qj2c6qb0j3dl6har1v07l3vmm18ap1p0qos9pgo82f19enaboighed7bnal6t7jcumo", "project": "@transcripts/contribution-diff", "tag": "done" }, diff --git a/transcripts/sync-apis/pull-without-history.output.md b/transcripts/sync-apis/pull-without-history.output.md index f67d5381..0389ac2b 100644 --- a/transcripts/sync-apis/pull-without-history.output.md +++ b/transcripts/sync-apis/pull-without-history.output.md @@ -7,6 +7,8 @@ x = 1 + x : ##Nat + + (added), ~ (modified), - (deleted) + Run `update` to apply these changes to your codebase. ``` diff --git a/transcripts/sync-apis/sync.output.md b/transcripts/sync-apis/sync.output.md index 9d892abc..c7ff3620 100644 --- a/transcripts/sync-apis/sync.output.md +++ b/transcripts/sync-apis/sync.output.md @@ -33,6 +33,8 @@ ys = [!a, !b] :+ 3 + xs : ['{g} Nat] + ys : [Nat] + + (added), ~ (modified), - (deleted) + Run `update` to apply these changes to your codebase. ``` @@ -71,7 +73,7 @@ proj/pulled> ls . 4. B/ (2 terms) 5. a ('Nat) 6. b ('Nat) - 7. builtin/ (582 terms, 100 types) + 7. builtin/ (580 terms, 100 types) 8. xs (['{g} Nat]) 9. ys ([Nat]) ``` From 2a911f632bac2fd3a469da735f47f1cfde8366a4 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 17:37:32 -0400 Subject: [PATCH 07/14] bump unison to 0.5.45 in CI --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index eb157ff6..5dc98321 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -236,7 +236,7 @@ jobs: # Install ucm mkdir ucm - curl -L https://github.com/unisonweb/unison/releases/download/release%2F0.5.44/ucm-linux-x64.tar.gz | tar -xz -C ucm + curl -L https://github.com/unisonweb/unison/releases/download/release%2F0.5.45/ucm-linux-x64.tar.gz | tar -xz -C ucm export PATH=$PWD/ucm:$PATH # Clean up old postgres data if it exists. From 393dccd76a67a7f251ba86c64ceb2bde165d17ac Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 22 Aug 2025 18:15:48 -0400 Subject: [PATCH 08/14] re-run transcripts with ucm-0.5.45 --- .../code-browse/codebase-namespace-by-name-root.json | 2 +- .../share-apis/contribution-diffs/contribution-diff.json | 4 ++-- transcripts/share-apis/contribution-diffs/namespace-diff.json | 4 ++-- transcripts/sync-apis/pull-without-history.output.md | 2 -- transcripts/sync-apis/sync.output.md | 4 +--- 5 files changed, 6 insertions(+), 10 deletions(-) diff --git a/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json b/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json index ccdb7eed..dea96bf8 100644 --- a/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json +++ b/transcripts/share-apis/code-browse/codebase-namespace-by-name-root.json @@ -1,7 +1,7 @@ { "body": { "fqn": "", - "hash": "#hjj7spb37rsmv6eojjite9l0eomq9m85gnrnt8oiuvta41rr28sj239tib8b7qhk87hnm560fikbtb1heou3epvrq5118ej5thk3hs0", + "hash": "#atdvemjjjgksnq8t3cv420dlusb37r21349m7nglli3r8n1d5q063s8cn0aravas8dt1ofuu9t0ge5civ11begb43meo339t498aj7g", "readme": null }, "status": [ diff --git a/transcripts/share-apis/contribution-diffs/contribution-diff.json b/transcripts/share-apis/contribution-diffs/contribution-diff.json index faa1d4f4..84e70b48 100644 --- a/transcripts/share-apis/contribution-diffs/contribution-diff.json +++ b/transcripts/share-apis/contribution-diffs/contribution-diff.json @@ -2263,9 +2263,9 @@ "tag": "ok" }, "newRef": "diff-end", - "newRefHash": "#lau4pa7q7ul1ub9m0f13kg3soqjmdsu173n9j36a7u0t6hp81kmfqgfv3pm0tp6i0kjb80ae1bb4a2eo3aa6c7jscqgin3rati2t0t0", + "newRefHash": "#j34aadhp37a5fhfbph4hc7i0pp7nlr48otdbapdue4kgmtt3e63evn2p46um4il8q45ltqu4msms93a34ptkhpjlctto2il89sd47u8", "oldRef": "diff-start", - "oldRefHash": "#vu2ddn75mpvl8jv01c4tnmvddm8e2q1e2nb9qj2c6qb0j3dl6har1v07l3vmm18ap1p0qos9pgo82f19enaboighed7bnal6t7jcumo", + "oldRefHash": "#slt6ihj3f9r5eavshflld6q5gkjq2fc42f5vpco02u2mp7els39k0ai630eqncbpihosroutg8km6cf4t922h445vki1ofe4hsl24ig", "project": "@transcripts/contribution-diff", "tag": "done" }, diff --git a/transcripts/share-apis/contribution-diffs/namespace-diff.json b/transcripts/share-apis/contribution-diffs/namespace-diff.json index faa1d4f4..84e70b48 100644 --- a/transcripts/share-apis/contribution-diffs/namespace-diff.json +++ b/transcripts/share-apis/contribution-diffs/namespace-diff.json @@ -2263,9 +2263,9 @@ "tag": "ok" }, "newRef": "diff-end", - "newRefHash": "#lau4pa7q7ul1ub9m0f13kg3soqjmdsu173n9j36a7u0t6hp81kmfqgfv3pm0tp6i0kjb80ae1bb4a2eo3aa6c7jscqgin3rati2t0t0", + "newRefHash": "#j34aadhp37a5fhfbph4hc7i0pp7nlr48otdbapdue4kgmtt3e63evn2p46um4il8q45ltqu4msms93a34ptkhpjlctto2il89sd47u8", "oldRef": "diff-start", - "oldRefHash": "#vu2ddn75mpvl8jv01c4tnmvddm8e2q1e2nb9qj2c6qb0j3dl6har1v07l3vmm18ap1p0qos9pgo82f19enaboighed7bnal6t7jcumo", + "oldRefHash": "#slt6ihj3f9r5eavshflld6q5gkjq2fc42f5vpco02u2mp7els39k0ai630eqncbpihosroutg8km6cf4t922h445vki1ofe4hsl24ig", "project": "@transcripts/contribution-diff", "tag": "done" }, diff --git a/transcripts/sync-apis/pull-without-history.output.md b/transcripts/sync-apis/pull-without-history.output.md index 0389ac2b..f67d5381 100644 --- a/transcripts/sync-apis/pull-without-history.output.md +++ b/transcripts/sync-apis/pull-without-history.output.md @@ -7,8 +7,6 @@ x = 1 + x : ##Nat - + (added), ~ (modified), - (deleted) - Run `update` to apply these changes to your codebase. ``` diff --git a/transcripts/sync-apis/sync.output.md b/transcripts/sync-apis/sync.output.md index c7ff3620..9d892abc 100644 --- a/transcripts/sync-apis/sync.output.md +++ b/transcripts/sync-apis/sync.output.md @@ -33,8 +33,6 @@ ys = [!a, !b] :+ 3 + xs : ['{g} Nat] + ys : [Nat] - + (added), ~ (modified), - (deleted) - Run `update` to apply these changes to your codebase. ``` @@ -73,7 +71,7 @@ proj/pulled> ls . 4. B/ (2 terms) 5. a ('Nat) 6. b ('Nat) - 7. builtin/ (580 terms, 100 types) + 7. builtin/ (582 terms, 100 types) 8. xs (['{g} Nat]) 9. ys ([Nat]) ``` From b08c3f0e24fb476d754040657f272407ff08d7c6 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 25 Aug 2025 12:02:35 -0400 Subject: [PATCH 09/14] simplify definion diffs traversals --- src/Share/NamespaceDiffs.hs | 3 + src/Share/NamespaceDiffs/Types.hs | 31 ++++++++ src/Share/Web/Share/Diffs/Impl.hs | 117 ++++++++++++++---------------- 3 files changed, 87 insertions(+), 64 deletions(-) diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 6472d495..76291dcf 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -18,16 +18,19 @@ module Share.NamespaceDiffs namespaceTreeDiffReferences_, namespaceTreeDiffReferents_, namespaceTreeDiffTermDiffs_, + mapMaybeNamespaceTreeDiffTermDiffs, witherNamespaceTreeDiffTermDiffs, namespaceTreeDiffTypeDiffs_, namespaceTreeDiffRenderedTerms_, namespaceTreeDiffRenderedTypes_, namespaceTreeTermDiffKinds_, + mapMaybeNamespaceTreeTermDiffKinds, witherNamespaceTreeTermDiffKinds, namespaceTreeTypeDiffKinds_, namespaceAndLibdepsDiffDefns_, namespaceAndLibdepsDiffLibdeps_, definitionDiffKindRendered_, + definitionDiffKindRenderedOldNew_, definitionDiffKindRefsAndRendered_, ) where diff --git a/src/Share/NamespaceDiffs/Types.hs b/src/Share/NamespaceDiffs/Types.hs index a09fd251..0c37c4fe 100644 --- a/src/Share/NamespaceDiffs/Types.hs +++ b/src/Share/NamespaceDiffs/Types.hs @@ -17,14 +17,17 @@ module Share.NamespaceDiffs.Types namespaceTreeDiffReferents_, namespaceTreeDiffReferences_, namespaceTreeDiffTermDiffs_, + mapMaybeNamespaceTreeDiffTermDiffs, witherNamespaceTreeDiffTermDiffs, namespaceTreeDiffTypeDiffs_, namespaceTreeTermDiffKinds_, + mapMaybeNamespaceTreeTermDiffKinds, witherNamespaceTreeTermDiffKinds, namespaceTreeTypeDiffKinds_, namespaceTreeDiffRenderedTerms_, namespaceTreeDiffRenderedTypes_, definitionDiffKindRendered_, + definitionDiffKindRenderedOldNew_, definitionDiffKindRefsAndRendered_, ) where @@ -188,6 +191,16 @@ definitionDiffKindRendered_ f = \case RenamedTo r old rendered -> RenamedTo r old <$> f rendered RenamedFrom r old rendered -> RenamedFrom r old <$> f rendered +definitionDiffKindRenderedOldNew_ :: Traversal (DefinitionDiffKind r rendered diff) (DefinitionDiffKind r rendered' diff) (Either rendered rendered) rendered' +definitionDiffKindRenderedOldNew_ f = \case + Added r rendered -> Added r <$> f (Right rendered) + NewAlias r ns rendered -> NewAlias r ns <$> f (Right rendered) + Removed r rendered -> Removed r <$> f (Left rendered) + Propagated old new diff -> Propagated old new <$> pure diff + Updated old new diff -> Updated old new <$> pure diff + RenamedTo r old rendered -> RenamedTo r old <$> f (Left rendered) + RenamedFrom r old rendered -> RenamedFrom r old <$> f (Right rendered) + definitionDiffKindRefsAndRendered_ :: Traversal (DefinitionDiffKind r rendered diff) (DefinitionDiffKind r rendered' diff) (r, rendered) (r, rendered') definitionDiffKindRefsAndRendered_ f = \case Added r rendered -> (\(r', rendered') -> Added r' rendered') <$> f (r, rendered) @@ -539,6 +552,15 @@ namespaceTreeDiffReferences_ = traversed . traversed . diffAtPathReferences_ namespaceTreeDiffTermDiffs_ :: (Ord termDiff', Ord referent, Ord renderedTerm) => Traversal (GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff typeDiff) (GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff' typeDiff) termDiff termDiff' namespaceTreeDiffTermDiffs_ = traversed . traversed . diffAtPathTermDiffs_ +mapMaybeNamespaceTreeDiffTermDiffs :: + forall k reference referent renderedTerm renderedType termDiff termDiff' typeDiff. + (Ord termDiff', Ord referent, Ord renderedTerm) => + (termDiff -> Maybe termDiff') -> + GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff typeDiff -> + GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff' typeDiff +mapMaybeNamespaceTreeDiffTermDiffs f = + runIdentity . witherNamespaceTreeDiffTermDiffs (Identity . f) + witherNamespaceTreeDiffTermDiffs :: forall f k reference referent renderedTerm renderedType termDiff termDiff' typeDiff. (Monad f, Ord termDiff', Ord referent, Ord renderedTerm) => @@ -568,6 +590,15 @@ namespaceTreeDiffTypeDiffs_ = traversed . traversed . diffAtPathTypeDiffs_ namespaceTreeTermDiffKinds_ :: (Ord renderedTerm', Ord termDiff', Ord referent') => Traversal (GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff typeDiff) (GNamespaceTreeDiff k referent' reference renderedTerm' renderedType termDiff' typeDiff) (DefinitionDiffKind referent renderedTerm termDiff) (DefinitionDiffKind referent' renderedTerm' termDiff') namespaceTreeTermDiffKinds_ = traversed . traversed . diffAtPathTermDiffKinds_ +mapMaybeNamespaceTreeTermDiffKinds :: + forall k reference referent referent' renderedTerm renderedTerm' renderedType termDiff termDiff' typeDiff. + (Ord renderedTerm', Ord termDiff', Ord referent') => + (DefinitionDiffKind referent renderedTerm termDiff -> Maybe (DefinitionDiffKind referent' renderedTerm' termDiff')) -> + GNamespaceTreeDiff k referent reference renderedTerm renderedType termDiff typeDiff -> + GNamespaceTreeDiff k referent' reference renderedTerm' renderedType termDiff' typeDiff +mapMaybeNamespaceTreeTermDiffKinds f = + runIdentity . witherNamespaceTreeTermDiffKinds (Identity . f) + witherNamespaceTreeTermDiffKinds :: forall f k reference referent referent' renderedTerm renderedTerm' renderedType termDiff termDiff' typeDiff. (Monad f, Ord renderedTerm', Ord termDiff', Ord referent') => diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index f57dfaa6..d8f66ac4 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -145,29 +145,37 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC let typeNamesToDiff = setOf NamespaceDiffs.namespaceTreeDiffTypeDiffs_ defns0 - oldTermDefinitionsByName <- do - PG.transactionSpan "load old terms" mempty do - deriveMapOf - (expectTermDefinitionsOf oldCodebase oldRuntime oldPerspective1) - (Set.toList (Set.union oldTermNamesToRender termNamesToDiff)) - - newTermDefinitionsByName <- do - PG.transactionSpan "load new terms" mempty do - deriveMapOf - (expectTermDefinitionsOf newCodebase newRuntime newPerspective) - (Set.toList (Set.union newTermNamesToRender termNamesToDiff)) - - oldTypeDefinitionsByName <- do - PG.transactionSpan "load old types" mempty do - deriveMapOf - (expectTypeDefinitionsOf oldCodebase oldRuntime oldPerspective1) - (Set.toList (Set.union oldTypeNamesToRender typeNamesToDiff)) - - newTypeDefinitionsByName <- do - PG.transactionSpan "load new types" mempty do - deriveMapOf - (expectTypeDefinitionsOf newCodebase newRuntime newPerspective) - (Set.toList (Set.union newTypeNamesToRender typeNamesToDiff)) + getOldTermDefinitionByName <- do + oldTermDefinitionsByName <- + PG.transactionSpan "load old terms" mempty do + deriveMapOf + (expectTermDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (Set.toList (Set.union oldTermNamesToRender termNamesToDiff)) + pure (oldTermDefinitionsByName Map.!) + + getNewTermDefinitionByName <- do + newTermDefinitionsByName <- do + PG.transactionSpan "load new terms" mempty do + deriveMapOf + (expectTermDefinitionsOf newCodebase newRuntime newPerspective) + (Set.toList (Set.union newTermNamesToRender termNamesToDiff)) + pure (newTermDefinitionsByName Map.!) + + getOldTypeDefinitionByName <- do + oldTypeDefinitionsByName <- do + PG.transactionSpan "load old types" mempty do + deriveMapOf + (expectTypeDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (Set.toList (Set.union oldTypeNamesToRender typeNamesToDiff)) + pure (oldTypeDefinitionsByName Map.!) + + getNewTypeDefinitionByName <- do + newTypeDefinitionsByName <- do + PG.transactionSpan "load new types" mempty do + deriveMapOf + (expectTypeDefinitionsOf newCodebase newRuntime newPerspective) + (Set.toList (Set.union newTypeNamesToRender typeNamesToDiff)) + pure (newTypeDefinitionsByName Map.!) -- Resolve the term referents to tag + hash defns1 :: NamespaceDiffs.GNamespaceTreeDiff NameSegment (TermTag, ShortHash) TypeReference Name Name Name Name <- @@ -192,16 +200,17 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC let defns3 :: GNamespaceTreeDiff NameSegment (TermTag, ShortHash) (TypeTag, ShortHash) TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff defns3 = defns2 - & NamespaceDiffs.namespaceTreeDiffTermDiffs_ %~ (\name -> (oldTermDefinitionsByName Map.! name, newTermDefinitionsByName Map.! name)) - & NamespaceDiffs.witherNamespaceTreeDiffTermDiffs (Identity . diffTermsPure) - & runIdentity - & unsafePartsOf NamespaceDiffs.namespaceTreeDiffRenderedTerms_ - .~ map (either (oldTermDefinitionsByName Map.!) (newTermDefinitionsByName Map.!)) termNamesToRender - & NamespaceDiffs.witherNamespaceTreeTermDiffKinds (Identity . throwAwayConstructorDiffs) - & runIdentity - & NamespaceDiffs.namespaceTreeDiffTypeDiffs_ %~ (\name -> diffTypesPure (oldTypeDefinitionsByName Map.! name, newTypeDefinitionsByName Map.! name)) - & unsafePartsOf NamespaceDiffs.namespaceTreeDiffRenderedTypes_ - .~ map (either (oldTypeDefinitionsByName Map.!) (newTypeDefinitionsByName Map.!)) typeNamesToRender + & NamespaceDiffs.mapMaybeNamespaceTreeDiffTermDiffs (\name -> diffTermsPure (getOldTermDefinitionByName name) (getNewTermDefinitionByName name)) + & NamespaceDiffs.mapMaybeNamespaceTreeTermDiffKinds + ( NamespaceDiffs.definitionDiffKindRenderedOldNew_ + ( either + (eitherToMaybe . getOldTermDefinitionByName) + (eitherToMaybe . getNewTermDefinitionByName) + ) + ) + & NamespaceDiffs.namespaceTreeDiffTypeDiffs_ %~ (\name -> diffTypesPure (getOldTypeDefinitionByName name) (getNewTypeDefinitionByName name)) + & NamespaceDiffs.namespaceTreeTypeDiffKinds_ . NamespaceDiffs.definitionDiffKindRenderedOldNew_ + %~ either getOldTypeDefinitionByName getNewTypeDefinitionByName -- Resolve libdeps branch hash ids to branch hashes libdeps <- @@ -229,23 +238,6 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC RenamedTo r names name -> RenamedTo r names (Left name) RenamedFrom r names name -> RenamedFrom r names (Right name) - throwAwayConstructorDiffs :: - DefinitionDiffKind a (Either ConstructorReference TermDefinition) diff -> Maybe (DefinitionDiffKind a TermDefinition diff) - throwAwayConstructorDiffs = \case - Added ref (Right term) -> Just (Added ref term) - NewAlias ref names (Right term) -> Just (NewAlias ref names term) - Removed ref (Right term) -> Just (Removed ref term) - Updated old new diff -> Just (Updated old new diff) - Propagated old new diff -> Just (Propagated old new diff) - RenamedTo ref names (Right term) -> Just (RenamedTo ref names term) - RenamedFrom ref names (Right term) -> Just (RenamedFrom ref names term) - -- - Added _ (Left _) -> Nothing - NewAlias _ _ (Left _) -> Nothing - Removed _ (Left _) -> Nothing - RenamedFrom _ _ (Left _) -> Nothing - RenamedTo _ _ (Left _) -> Nothing - -- | Note: Only use this if you're diffing a single definition, otherwise batch operations are -- more efficient. diffTerms :: @@ -256,17 +248,15 @@ diffTerms :: diffTerms !_authZReceipt (oldCodebase, oldRt, oldNp, oldName) (newCodebase, newRt, newNp, newName) = do oldTerm <- getTermDefinitionsOf oldCodebase oldRt oldNp id oldName `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) newTerm <- getTermDefinitionsOf newCodebase newRt newNp id newName `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) - pure $ diffTermsPure (oldTerm, newTerm) + pure $ diffTermsPure oldTerm newTerm -diffTermsPure :: - (Either a2 TermDefinition, Either a3 TermDefinition) -> (Maybe TermDefinitionDiff) -diffTermsPure = \case - (Right oldTerm, Right newTerm) -> - let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects (termDefinition oldTerm) (termDefinition newTerm) - in (Just TermDefinitionDiff {left = oldTerm, right = newTerm, diff = termDiffDisplayObject}) - -- For later: decide how to render a constructor-to-term or constructor-to-constructor diff - -- Just dropping them from the diff for now - _ -> Nothing +diffTermsPure :: Either ConstructorReference TermDefinition -> Either ConstructorReference TermDefinition -> Maybe TermDefinitionDiff +diffTermsPure (Right oldTerm) (Right newTerm) = + let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects (termDefinition oldTerm) (termDefinition newTerm) + in (Just TermDefinitionDiff {left = oldTerm, right = newTerm, diff = termDiffDisplayObject}) +-- For later: decide how to render a constructor-to-term or constructor-to-constructor diff +-- Just dropping them from the diff for now +diffTermsPure _ _ = Nothing -- | Get definitions for a batch of terms within a codebase and perspective. -- NOTE: The names should already be properly scoped to the names perspective. @@ -315,11 +305,10 @@ diffTypes !_authZReceipt (oldCodebase, oldRt, oldNp, oldTypeName) (newCodebase, newType <- getTypeDefinitionsOf newCodebase newRt newNp id newTypeName `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) - pure $ diffTypesPure (oldType, newType) + pure $ diffTypesPure oldType newType -diffTypesPure :: - (TypeDefinition, TypeDefinition) -> TypeDefinitionDiff -diffTypesPure (oldType, newType) = do +diffTypesPure :: TypeDefinition -> TypeDefinition -> TypeDefinitionDiff +diffTypesPure oldType newType = let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects (typeDefinition oldType) (typeDefinition newType) in TypeDefinitionDiff {left = oldType, right = newType, diff = typeDiffDisplayObject} From acd539b27b275a4ab71d464e6bde8fc62da4cff2 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 25 Aug 2025 13:15:47 -0400 Subject: [PATCH 10/14] skip resolving term names to referents since we already have that info --- src/Share/NamespaceDiffs.hs | 1 - src/Share/NamespaceDiffs/Types.hs | 11 ----- src/Share/Web/Share/Diffs/Impl.hs | 50 +++++++++++++++++--- src/Unison/Server/Share/Definitions.hs | 63 ++++++++++++++++++++------ 4 files changed, 94 insertions(+), 31 deletions(-) diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 76291dcf..d5e4dc17 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -31,7 +31,6 @@ module Share.NamespaceDiffs namespaceAndLibdepsDiffLibdeps_, definitionDiffKindRendered_, definitionDiffKindRenderedOldNew_, - definitionDiffKindRefsAndRendered_, ) where diff --git a/src/Share/NamespaceDiffs/Types.hs b/src/Share/NamespaceDiffs/Types.hs index 0c37c4fe..203f9ea8 100644 --- a/src/Share/NamespaceDiffs/Types.hs +++ b/src/Share/NamespaceDiffs/Types.hs @@ -28,7 +28,6 @@ module Share.NamespaceDiffs.Types namespaceTreeDiffRenderedTypes_, definitionDiffKindRendered_, definitionDiffKindRenderedOldNew_, - definitionDiffKindRefsAndRendered_, ) where @@ -201,16 +200,6 @@ definitionDiffKindRenderedOldNew_ f = \case RenamedTo r old rendered -> RenamedTo r old <$> f (Left rendered) RenamedFrom r old rendered -> RenamedFrom r old <$> f (Right rendered) -definitionDiffKindRefsAndRendered_ :: Traversal (DefinitionDiffKind r rendered diff) (DefinitionDiffKind r rendered' diff) (r, rendered) (r, rendered') -definitionDiffKindRefsAndRendered_ f = \case - Added r rendered -> (\(r', rendered') -> Added r' rendered') <$> f (r, rendered) - NewAlias r ns rendered -> (\(r', rendered') -> NewAlias r' ns rendered') <$> f (r, rendered) - Removed r rendered -> (\(r', rendered') -> Removed r' rendered') <$> f (r, rendered) - Propagated old new diff -> Propagated old new <$> pure diff - Updated old new diff -> Updated old new <$> pure diff - RenamedTo r old rendered -> (\(r', rendered') -> RenamedTo r' old rendered') <$> f (r, rendered) - RenamedFrom r old rendered -> (\(r', rendered') -> RenamedFrom r' old rendered') <$> f (r, rendered) - data NamespaceDiffResult = NamespaceDiffResult'Ok ( NamespaceAndLibdepsDiff diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index d8f66ac4..affe7f9b 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -29,7 +29,6 @@ import Share.Postgres.NamesPerspective.Types (NamesPerspective (..)) import Share.Prelude import Share.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres import Share.Utils.Aeson (PreEncoded (PreEncoded)) -import Share.Utils.Lens (asListOfDeduped) import Share.Web.Authorization (AuthZReceipt) import Share.Web.Errors import U.Codebase.Reference qualified as V2Reference @@ -49,6 +48,8 @@ import Unison.Server.Types import Unison.ShortHash (ShortHash) import Unison.Syntax.Name qualified as Name import Unison.UnconflictedLocalDefnsView qualified +import Unison.Util.BiMultimap qualified as BiMultimap +import Unison.Util.Defns qualified import Unison.Util.Pretty (Width) -- | Diff two causals and store the diff in the database. @@ -145,11 +146,21 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC let typeNamesToDiff = setOf NamespaceDiffs.namespaceTreeDiffTypeDiffs_ defns0 + let newNameToReferent :: Name -> Referent + newNameToReferent = + (BiMultimap.range diffblob.defns.bob.defns.terms Map.!) + + let oldNameToReferent :: Name -> Referent + oldNameToReferent = + case maybeLcaPerspective of + Just _ -> (BiMultimap.range diffblob.defns.lca.defns.terms Map.!) + Nothing -> newNameToReferent + getOldTermDefinitionByName <- do oldTermDefinitionsByName <- PG.transactionSpan "load old terms" mempty do deriveMapOf - (expectTermDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (expectTermDefinitionsByNamedRefsOf oldCodebase oldRuntime oldPerspective1 oldNameToReferent) (Set.toList (Set.union oldTermNamesToRender termNamesToDiff)) pure (oldTermDefinitionsByName Map.!) @@ -157,7 +168,7 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC newTermDefinitionsByName <- do PG.transactionSpan "load new terms" mempty do deriveMapOf - (expectTermDefinitionsOf newCodebase newRuntime newPerspective) + (expectTermDefinitionsByNamedRefsOf newCodebase newRuntime newPerspective newNameToReferent) (Set.toList (Set.union newTermNamesToRender termNamesToDiff)) pure (newTermDefinitionsByName Map.!) @@ -246,8 +257,8 @@ diffTerms :: (Codebase.CodebaseEnv, Codebase.CodebaseRuntime new IO, NamesPerspective (PG.Transaction NamespaceDiffError), Name) -> PG.Transaction NamespaceDiffError (Maybe TermDefinitionDiff) diffTerms !_authZReceipt (oldCodebase, oldRt, oldNp, oldName) (newCodebase, newRt, newNp, newName) = do - oldTerm <- getTermDefinitionsOf oldCodebase oldRt oldNp id oldName `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) - newTerm <- getTermDefinitionsOf newCodebase newRt newNp id newName `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) + oldTerm <- expectTermDefinitionsOf oldCodebase oldRt oldNp id oldName + newTerm <- expectTermDefinitionsOf newCodebase newRt newNp id newName pure $ diffTermsPure oldTerm newTerm diffTermsPure :: Either ConstructorReference TermDefinition -> Either ConstructorReference TermDefinition -> Maybe TermDefinitionDiff @@ -270,7 +281,7 @@ getTermDefinitionsOf :: m t getTermDefinitionsOf codebase rt namesPerspective trav s = do s - & asListOfDeduped trav %%~ \names -> do + & asListOf trav %%~ \names -> do Definitions.termDefinitionByNamesOf codebase ppedBuilder namesPerspective renderWidth rt includeDocs traversed names where includeDocs = False @@ -293,6 +304,33 @@ expectTermDefinitionsOf codebase rt np trav s = (name, Nothing) -> throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("Term not found: " <> Name.toText name <> ", in names perspective: " <> tShow np)) (_, Just termDef) -> pure termDef +expectTermDefinitionsByNamedRefsOf :: + (PG.QueryM m) => + Codebase.CodebaseEnv -> + Codebase.CodebaseRuntime sym IO -> + NamesPerspective m -> + (Name -> Referent) -> + Traversal s t Name (Either ConstructorReference TermDefinition) -> + s -> + m t +expectTermDefinitionsByNamedRefsOf codebase rt namesPerspective toReferent trav s = do + s + & asListOf trav %%~ \names -> + Definitions.termDefinitionByNamedRefsOf + codebase + ppedBuilder + namesPerspective + renderWidth + rt + includeDocs + traverse + (map (\name -> (name, toReferent name)) names) + where + includeDocs = False + ppedBuilder deps = PPEPostgres.ppedForReferences namesPerspective deps + renderWidth :: Width + renderWidth = 80 + diffTypes :: AuthZReceipt -> (Codebase.CodebaseEnv, Codebase.CodebaseRuntime old IO, NamesPerspective (PG.Transaction NamespaceDiffError), Name) -> diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index 2bf0b260..fe897f94 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -3,6 +3,7 @@ module Unison.Server.Share.Definitions resolveHQName, definitionDependencies, termDefinitionByNamesOf, + termDefinitionByNamedRefsOf, typeDefinitionsByNamesOf, definitionDependencyResults, definitionDependentResults, @@ -55,6 +56,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Reference qualified as V1 +import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Server.Doc qualified as Doc import Unison.Server.NameSearch (NameSearch (..)) @@ -431,19 +433,54 @@ termDefinitionByNamesOf codebase ppedBuilder namesPerspective width rt includeDo let withNames = zipWith addName allNames constructorsAndRendered -- Only the Right values are terms which we're concerned with, the Left values are constructors withNames - & asListOf (traversed . _Just . _Right) %%~ \(refsDO :: [(Name, TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann))]) -> do - let allDeps = refsDO & foldMap \(_name, ref, displayObject) -> termDisplayObjectLabeledDependencies ref displayObject - pped <- ppedBuilder allDeps - let (names, refs, dos) = unzip3 refsDO - allRenderedDocs <- - if includeDocs - then do - allDocRefs <- Docs.docsForDefinitionNamesOf codebase namesPerspective traversed names - -- TODO: properly batchify this - for allDocRefs $ renderDocRefs codebase ppedBuilder width rt - else pure (names $> []) - let syntaxDOs = snd <$> Backend.termsToSyntaxOf (Suffixify False) width pped traversed (zip refs dos) - Backend.mkTermDefinitionsOf codebase pped width traversed (zip4 (Just <$> names) refs allRenderedDocs syntaxDOs) + & asListOf (traversed . _Just . _Right) %%~ mkTermDefinitions codebase ppedBuilder namesPerspective width rt includeDocs + +termDefinitionByNamedRefsOf :: + (QueryM m) => + CodebaseEnv -> + PPEDBuilder m -> + NamesPerspective m -> + Width -> + CodebaseRuntime sym IO -> + Bool -> + Traversal s t (Name, Referent) (Either ConstructorReference TermDefinition) -> + s -> + m t +termDefinitionByNamedRefsOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do + s + & asListOf trav %%~ \refs0 -> do + terms <- + refs0 + & map \case + (_, Referent.Con ref _) -> Left ref + (name, Referent.Ref ref) -> Right (name, ref, ref) + & Backend.displayTermsOf rt.codeCache (traversed . _Right . _3) + terms + & asListOf (traversed . _Right) %%~ mkTermDefinitions codebase ppedBuilder namesPerspective width rt includeDocs + +mkTermDefinitions :: + (QueryM m) => + CodebaseEnv -> + PPEDBuilder m -> + NamesPerspective m -> + Width -> + CodebaseRuntime sym IO -> + Bool -> + [(Name, TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann))] -> + m [TermDefinition] +mkTermDefinitions codebase ppedBuilder namesPerspective width rt includeDocs refsDO = do + let allDeps = refsDO & foldMap \(_name, ref, displayObject) -> termDisplayObjectLabeledDependencies ref displayObject + pped <- ppedBuilder allDeps + let (names, refs, dos) = unzip3 refsDO + allRenderedDocs <- + if includeDocs + then do + allDocRefs <- Docs.docsForDefinitionNamesOf codebase namesPerspective traversed names + -- TODO: properly batchify this + for allDocRefs $ renderDocRefs codebase ppedBuilder width rt + else pure (names $> []) + let syntaxDOs = snd <$> Backend.termsToSyntaxOf (Suffixify False) width pped traversed (zip refs dos) + Backend.mkTermDefinitionsOf codebase pped width traversed (zip4 (Just <$> names) refs allRenderedDocs syntaxDOs) termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> Set LD.LabeledDependency termDisplayObjectLabeledDependencies termRef displayObject = do From b3aff416dd19275461f07f8c5d9e35cd66145f51 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Mon, 25 Aug 2025 14:16:49 -0400 Subject: [PATCH 11/14] skip resolving type names to references since we already have that info --- src/Share/Web/Share/Diffs/Impl.hs | 118 ++++++++++++++++--------- src/Unison/Server/Share/Definitions.hs | 62 ++++++++++--- 2 files changed, 124 insertions(+), 56 deletions(-) diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index affe7f9b..02fba7db 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -128,65 +128,74 @@ tryComputeCausalDiff !_authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newC let oldPerspective1 = fromMaybe oldPerspective maybeLcaPerspective - let termNamesToRender = - defns0 ^.. NamespaceDiffs.namespaceTreeTermDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_ + (getOldTermDefinitionByName, getNewTermDefinitionByName) <- do + let newNameToReferent :: Name -> Referent + newNameToReferent = + (BiMultimap.range diffblob.defns.bob.defns.terms Map.!) + + let oldNameToReferent :: Name -> Referent + oldNameToReferent = + case maybeLcaPerspective of + Just _ -> (BiMultimap.range diffblob.defns.lca.defns.terms Map.!) + Nothing -> newNameToReferent + + let (oldTermNamesToRender, newTermNamesToRender) = + defns0 + & toListOf (NamespaceDiffs.namespaceTreeTermDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_) + & partitionEithers + & bimap Set.fromList Set.fromList + + let termNamesToDiff = + setOf NamespaceDiffs.namespaceTreeDiffTermDiffs_ defns0 - let (oldTermNamesToRender, newTermNamesToRender) = - bimap Set.fromList Set.fromList (partitionEithers termNamesToRender) - - let termNamesToDiff = - setOf NamespaceDiffs.namespaceTreeDiffTermDiffs_ defns0 - - let typeNamesToRender = - defns0 ^.. NamespaceDiffs.namespaceTreeTypeDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_ - - let (oldTypeNamesToRender, newTypeNamesToRender) = - bimap Set.fromList Set.fromList (partitionEithers typeNamesToRender) - - let typeNamesToDiff = - setOf NamespaceDiffs.namespaceTreeDiffTypeDiffs_ defns0 - - let newNameToReferent :: Name -> Referent - newNameToReferent = - (BiMultimap.range diffblob.defns.bob.defns.terms Map.!) - - let oldNameToReferent :: Name -> Referent - oldNameToReferent = - case maybeLcaPerspective of - Just _ -> (BiMultimap.range diffblob.defns.lca.defns.terms Map.!) - Nothing -> newNameToReferent - - getOldTermDefinitionByName <- do oldTermDefinitionsByName <- PG.transactionSpan "load old terms" mempty do deriveMapOf (expectTermDefinitionsByNamedRefsOf oldCodebase oldRuntime oldPerspective1 oldNameToReferent) (Set.toList (Set.union oldTermNamesToRender termNamesToDiff)) - pure (oldTermDefinitionsByName Map.!) - getNewTermDefinitionByName <- do newTermDefinitionsByName <- do PG.transactionSpan "load new terms" mempty do deriveMapOf (expectTermDefinitionsByNamedRefsOf newCodebase newRuntime newPerspective newNameToReferent) (Set.toList (Set.union newTermNamesToRender termNamesToDiff)) - pure (newTermDefinitionsByName Map.!) - getOldTypeDefinitionByName <- do + pure ((oldTermDefinitionsByName Map.!), (newTermDefinitionsByName Map.!)) + + (getOldTypeDefinitionByName, getNewTypeDefinitionByName) <- do + let newNameToReference :: Name -> TypeReference + newNameToReference = + (BiMultimap.range diffblob.defns.bob.defns.types Map.!) + + let oldNameToReference :: Name -> TypeReference + oldNameToReference = + case maybeLcaPerspective of + Just _ -> (BiMultimap.range diffblob.defns.lca.defns.types Map.!) + Nothing -> newNameToReference + + let (oldTypeNamesToRender, newTypeNamesToRender) = + defns0 + & toListOf (NamespaceDiffs.namespaceTreeTypeDiffKinds_ . to partitionDiffKind . NamespaceDiffs.definitionDiffKindRendered_) + & partitionEithers + & bimap Set.fromList Set.fromList + + let typeNamesToDiff = + setOf NamespaceDiffs.namespaceTreeDiffTypeDiffs_ defns0 + oldTypeDefinitionsByName <- do PG.transactionSpan "load old types" mempty do deriveMapOf - (expectTypeDefinitionsOf oldCodebase oldRuntime oldPerspective1) + (expectTypeDefinitionsByNamedRefsOf oldCodebase oldRuntime oldPerspective1 oldNameToReference) (Set.toList (Set.union oldTypeNamesToRender typeNamesToDiff)) pure (oldTypeDefinitionsByName Map.!) - getNewTypeDefinitionByName <- do newTypeDefinitionsByName <- do PG.transactionSpan "load new types" mempty do deriveMapOf - (expectTypeDefinitionsOf newCodebase newRuntime newPerspective) + (expectTypeDefinitionsByNamedRefsOf newCodebase newRuntime newPerspective newNameToReference) (Set.toList (Set.union newTypeNamesToRender typeNamesToDiff)) - pure (newTypeDefinitionsByName Map.!) + + pure ((oldTypeDefinitionsByName Map.!), (newTypeDefinitionsByName Map.!)) -- Resolve the term referents to tag + hash defns1 :: NamespaceDiffs.GNamespaceTreeDiff NameSegment (TermTag, ShortHash) TypeReference Name Name Name Name <- @@ -337,12 +346,8 @@ diffTypes :: (Codebase.CodebaseEnv, Codebase.CodebaseRuntime new IO, NamesPerspective (PG.Transaction NamespaceDiffError), Name) -> PG.Transaction NamespaceDiffError TypeDefinitionDiff diffTypes !_authZReceipt (oldCodebase, oldRt, oldNp, oldTypeName) (newCodebase, newRt, newNp, newTypeName) = do - oldType <- - getTypeDefinitionsOf oldCodebase oldRt oldNp id oldTypeName - `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName)) - newType <- - getTypeDefinitionsOf newCodebase newRt newNp id newTypeName - `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) + oldType <- expectTypeDefinitionsOf oldCodebase oldRt oldNp id oldTypeName + newType <- expectTypeDefinitionsOf newCodebase newRt newNp id newTypeName pure $ diffTypesPure oldType newType diffTypesPure :: TypeDefinition -> TypeDefinition -> TypeDefinitionDiff @@ -366,7 +371,34 @@ getTypeDefinitionsOf codebase rt namesPerspective trav s = do Definitions.typeDefinitionsByNamesOf codebase ppedBuilder namesPerspective renderWidth rt includeDocs traversed names where includeDocs = False - ppedBuilder deps = PPEPostgres.ppedForReferences namesPerspective deps + ppedBuilder = PPEPostgres.ppedForReferences namesPerspective + renderWidth :: Width + renderWidth = 80 + +expectTypeDefinitionsByNamedRefsOf :: + (PG.QueryM m) => + Codebase.CodebaseEnv -> + Codebase.CodebaseRuntime sym IO -> + NamesPerspective m -> + (Name -> TypeReference) -> + Traversal s t Name TypeDefinition -> + s -> + m t +expectTypeDefinitionsByNamedRefsOf codebase rt namesPerspective toReference trav s = do + s + & asListOf trav %%~ \names -> + Definitions.typeDefinitionsByNamedRefsOf + codebase + ppedBuilder + namesPerspective + renderWidth + rt + includeDocs + traverse + (map (\name -> (name, toReference name)) names) + where + includeDocs = False + ppedBuilder = PPEPostgres.ppedForReferences namesPerspective renderWidth :: Width renderWidth = 80 diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index fe897f94..08c7a042 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -5,6 +5,7 @@ module Unison.Server.Share.Definitions termDefinitionByNamesOf, termDefinitionByNamedRefsOf, typeDefinitionsByNamesOf, + typeDefinitionsByNamedRefsOf, definitionDependencyResults, definitionDependentResults, ) @@ -518,19 +519,54 @@ typeDefinitionsByNamesOf codebase ppedBuilder namesPerspective width rt includeD Nothing -> Nothing let withNames = zipWith addName allNames typeDisplayObjs withNames - & asListOf (traversed . _Just) %%~ \displayInfos -> do - let (names, refs, displayObjects) = unzip3 displayInfos - let allDeps = displayInfos & foldMap \(_name, ref, dispObj) -> typeDisplayObjectLabeledDependencies ref dispObj - pped <- ppedBuilder allDeps - allRenderedDocs <- - if includeDocs - then do - allDocRefs <- Docs.docsForDefinitionNamesOf codebase namesPerspective traversed names - -- TODO: properly batchify this - for allDocRefs $ renderDocRefs codebase ppedBuilder width rt - else pure (names $> []) - let syntaxDOs = snd <$> Backend.typesToSyntaxOf (Suffixify False) width pped traversed (zip refs displayObjects) - Backend.mkTypeDefinitionsOf pped width traversed (zip4 (Just <$> names) refs allRenderedDocs syntaxDOs) + & asListOf (traversed . _Just) + %%~ mkTypeDefinitions codebase ppedBuilder namesPerspective width rt includeDocs + +-- | NOTE: If you're displaying many definitions you should probably generate a single PPED to +-- share among all of them, it would be more efficient than generating a PPED per definition. +typeDefinitionsByNamedRefsOf :: + (QueryM m) => + CodebaseEnv -> + PPEDBuilder m -> + NamesPerspective m -> + Width -> + CodebaseRuntime sym IO -> + Bool -> + Traversal s t (Name, TypeReference) TypeDefinition -> + s -> + m t +typeDefinitionsByNamedRefsOf codebase ppedBuilder namesPerspective width rt includeDocs trav s = do + s + & asListOf trav %%~ \refs0 -> do + types <- + refs0 + & map (\(name, ref) -> (name, ref, ref)) + & Backend.displayTypesOf rt.codeCache (traversed . _3) + mkTypeDefinitions codebase ppedBuilder namesPerspective width rt includeDocs types + +mkTypeDefinitions :: + (QueryM m) => + CodebaseEnv -> + PPEDBuilder m -> + NamesPerspective m -> + Width -> + CodebaseRuntime sym IO -> + Bool -> + [(Name, TypeReference, DisplayObject () (DD.Decl Symbol Ann))] -> + m [TypeDefinition] +mkTypeDefinitions codebase ppedBuilder namesPerspective width rt includeDocs displayInfos = do + let (names, refs, displayObjects) = unzip3 displayInfos + let allDeps = displayInfos & foldMap \(_name, ref, dispObj) -> typeDisplayObjectLabeledDependencies ref dispObj + pped <- ppedBuilder allDeps + allRenderedDocs <- + if includeDocs + then do + allDocRefs <- Docs.docsForDefinitionNamesOf codebase namesPerspective traversed names + -- TODO: properly batchify this + for allDocRefs $ renderDocRefs codebase ppedBuilder width rt + else pure (names $> []) + let syntaxDOs = snd <$> Backend.typesToSyntaxOf (Suffixify False) width pped traversed (zip refs displayObjects) + Backend.mkTypeDefinitionsOf pped width traversed (zip4 (Just <$> names) refs allRenderedDocs syntaxDOs) typeDisplayObjectLabeledDependencies :: TypeReference -> DisplayObject () (DD.Decl Symbol Ann) -> Set LD.LabeledDependency typeDisplayObjectLabeledDependencies typeRef displayObject = do From 01ba33f1dfbb393ee2ec239a832278ec9cdfa324 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Tue, 26 Aug 2025 09:54:34 -0400 Subject: [PATCH 12/14] bump unison --- unison | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison b/unison index 0138a901..9fc16411 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 0138a901c30c815045c954466ab8db0dac7a416c +Subproject commit 9fc1641194d1e433520bf9c0370be66990877961 From a6ae8512d5700627cdd4ff6890a523493f329059 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Thu, 28 Aug 2025 10:47:51 -0400 Subject: [PATCH 13/14] reduce duplication in code cache queries --- src/Share/Codebase.hs | 1 + src/Share/Codebase/CodeCache.hs | 74 ++++++--------------------------- 2 files changed, 14 insertions(+), 61 deletions(-) diff --git a/src/Share/Codebase.hs b/src/Share/Codebase.hs index e4d4b6a1..070fb071 100644 --- a/src/Share/Codebase.hs +++ b/src/Share/Codebase.hs @@ -7,6 +7,7 @@ module Share.Codebase ( shorthashLength, CodebaseEnv, codebaseOwner, + CodebaseError (..), CodebaseRuntime (..), codebaseEnv, codebaseForProjectBranch, diff --git a/src/Share/Codebase/CodeCache.hs b/src/Share/Codebase/CodeCache.hs index 86a68443..68862ecb 100644 --- a/src/Share/Codebase/CodeCache.hs +++ b/src/Share/Codebase/CodeCache.hs @@ -17,7 +17,6 @@ where import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) import Control.Lens -import Control.Monad.State.Strict qualified as State import Data.Map qualified as Map import Data.Text qualified as Text import Share.Codebase qualified as Codebase @@ -129,35 +128,18 @@ getTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = -- | Like 'getTermsAndTypesByRefIdsOf', but throws an unrecoverable error when the term isn't in the database. expectTermsAndTypesByRefIdsOf :: + forall m scope s t. (QueryM m) => CodeCache scope -> Traversal s t TermReferenceId TermAndType -> s -> m t -expectTermsAndTypesByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do - CodeCacheData {termCache} <- readCodeCache codeCache - s - & asListOf trav %%~ \refs -> do - -- Partition by cache misses - let terms0 :: [Either (TermReferenceId, TermReferenceId) TermAndType] - terms0 = - refs - <&> \ref -> - case findBuiltinTT ref <|> Map.lookup ref termCache of - Just termAndType -> Right termAndType - Nothing -> Left (ref, ref) - - -- Fetch all cache misses from database - terms1 :: [Either (TermReferenceId, TermAndType) TermAndType] <- - Codebase.expectTermsByRefIdsOf codeCacheCodebaseEnv (traversed . _Left . _2) terms0 - - -- Tease out the just-fetched things to add to the cache - let terms2 :: [TermAndType] - justFetched :: Map TermReferenceId TermAndType - (terms2, justFetched) = teaseOutJustFetched terms1 - - cacheTermAndTypes codeCache justFetched - pure terms2 +expectTermsAndTypesByRefIdsOf codeCache trav = + asListOf trav %%~ \refs -> do + termsAndTypes <- getTermsAndTypesByRefIdsOf codeCache traverse refs + for (zip refs termsAndTypes) \case + (_, Just tt) -> pure tt + (ref, Nothing) -> PG.unrecoverableError (Codebase.MissingTerm ref) findBuiltinTT :: TermReferenceId -> Maybe TermAndType findBuiltinTT refId = do @@ -203,47 +185,17 @@ expectTypeDeclsByRefIdsOf :: Traversal s t TypeReferenceId (V1.Decl Symbol Ann) -> s -> m t -expectTypeDeclsByRefIdsOf codeCache@(CodeCache {codeCacheCodebaseEnv}) trav s = do - CodeCacheData {typeCache} <- readCodeCache codeCache - s - & asListOf trav %%~ \refs -> do - -- Partition by cache misses - let types0 :: [Either (TypeReferenceId, TypeReferenceId) (V1.Decl Symbol Ann)] - types0 = - refs - <&> \ref -> - case findBuiltinDecl ref <|> Map.lookup ref typeCache of - Just typ -> Right typ - Nothing -> Left (ref, ref) - - -- Fetch all cache misses from database - types1 :: [Either (TypeReferenceId, V1.Decl Symbol Ann) (V1.Decl Symbol Ann)] <- - Codebase.expectTypeDeclarationsByRefIdsOf codeCacheCodebaseEnv (traversed . _Left . _2) types0 - - -- Tease out the just-fetched things to add to the cache - let types2 :: [V1.Decl Symbol Ann] - justFetched :: Map TypeReferenceId (V1.Decl Symbol Ann) - (types2, justFetched) = teaseOutJustFetched types1 - - cacheDecls codeCache justFetched - pure types2 +expectTypeDeclsByRefIdsOf codeCache trav = + asListOf trav %%~ \refs -> do + decls <- getTypeDeclsByRefIdsOf codeCache traverse refs + for (zip refs decls) \case + (_, Just decl) -> pure decl + (ref, Nothing) -> PG.unrecoverableError (Codebase.MissingDecl ref) findBuiltinDecl :: Reference.Id -> Maybe (V1.Decl Symbol Ann) findBuiltinDecl refId = do runIdentity $ CL.getTypeDeclaration builtinsCodeLookup refId --- Tease out the just-fetched things to add to the cache -teaseOutJustFetched :: forall a ref. (Ord ref) => [Either (ref, a) a] -> ([a], Map ref a) -teaseOutJustFetched terms1 = - runState (traverse recordJustFetched terms1) Map.empty - where - recordJustFetched :: Either (ref, a) a -> State (Map ref a) a - recordJustFetched = \case - Left (ref, term) -> do - State.modify' (Map.insert ref term) - pure term - Right term -> pure term - getTypeDeclsByRefsOf :: (QueryM m) => CodeCache scope -> From a949c4b7ea37d49a96cf59f5290bba9e85935703 Mon Sep 17 00:00:00 2001 From: Mitchell Dalvi Rosen Date: Fri, 29 Aug 2025 13:31:37 -0400 Subject: [PATCH 14/14] bump unison --- unison | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison b/unison index 9fc16411..e1b98c86 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 9fc1641194d1e433520bf9c0370be66990877961 +Subproject commit e1b98c8608fcce3c79c8e09f9d3e507175c9ac56