From eb1e3234d5342a086f29d23658d1133154c7dbba Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 12 Dec 2022 14:47:40 -0500 Subject: [PATCH] add NameBasedDiff, nameBasedDiff --- codebase2/codebase/U/Codebase/Referent.hs | 5 + .../src/U/Codebase/Branch/Diff.hs | 137 ++++++++++++------ 2 files changed, 94 insertions(+), 48 deletions(-) diff --git a/codebase2/codebase/U/Codebase/Referent.hs b/codebase2/codebase/U/Codebase/Referent.hs index 5e087240d..52b3e0f71 100644 --- a/codebase2/codebase/U/Codebase/Referent.hs +++ b/codebase2/codebase/U/Codebase/Referent.hs @@ -54,6 +54,11 @@ toReference = \case Ref termRef -> termRef Con typeRef _ -> typeRef +toTermReference :: Referent' termRef typeRef -> Maybe termRef +toTermReference = \case + Ref termRef -> Just termRef + Con _ _ -> Nothing + type Id = Id' Hash Hash data Id' hTm hTp diff --git a/parser-typechecker/src/U/Codebase/Branch/Diff.hs b/parser-typechecker/src/U/Codebase/Branch/Diff.hs index eb636a97e..34403b4a9 100644 --- a/parser-typechecker/src/U/Codebase/Branch/Diff.hs +++ b/parser-typechecker/src/U/Codebase/Branch/Diff.hs @@ -3,8 +3,10 @@ module U.Codebase.Branch.Diff NameChanges (..), DefinitionDiffs (..), Diff (..), + NameBasedDiff (..), diffBranches, nameChanges, + nameBasedDiff, ) where @@ -20,10 +22,13 @@ import qualified U.Codebase.Branch.Type as Branch import qualified U.Codebase.Causal as Causal import U.Codebase.Reference (Reference) import U.Codebase.Referent (Referent) +import qualified U.Codebase.Referent as Referent import Unison.Name (Name) import qualified Unison.Name as Name import Unison.NameSegment (NameSegment) import Unison.Prelude +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as Relation data Diff a = Diff { adds :: Set a, @@ -83,56 +88,71 @@ data NameChanges = NameChanges } instance Semigroup NameChanges where - (NameChanges a b c d) <> (NameChanges a2 b2 c2 d2) = + NameChanges a b c d <> NameChanges a2 b2 c2 d2 = NameChanges (a <> a2) (b <> b2) (c <> c2) (d <> d2) instance Monoid NameChanges where mempty = NameChanges mempty mempty mempty mempty +-- | A name-based diff for namespaces `N1` and `N2` is (for both terms and types) a relation between references, where +-- `a R b` if: +-- +-- 1. `a` has name `n` in `N1` and `b` has the same name `n` in `N2` +-- 2. `a` != `b` +data NameBasedDiff = NameBasedDiff + { terms :: Relation Reference Reference, + types :: Relation Reference Reference + } + deriving stock (Generic, Show) + +instance Monoid NameBasedDiff where + mempty = NameBasedDiff mempty mempty + mappend = (<>) + +instance Semigroup NameBasedDiff where + NameBasedDiff terms0 types0 <> NameBasedDiff terms1 types1 = + NameBasedDiff (terms0 <> terms1) (types0 <> types1) + -- | Diff two Branches, returning a tree containing all of the changes diffBranches :: forall m. Monad m => Branch m -> Branch m -> m TreeDiff diffBranches from to = do - let termDiffs = diffMap (terms from) (terms to) - let typeDiffs = diffMap (types from) (types to) + let termDiffs = diffMap (Branch.terms from) (Branch.terms to) + let typeDiffs = diffMap (Branch.types from) (Branch.types to) let defDiff = DefinitionDiffs {termDiffs, typeDiffs} childDiff <- do Align.align (children from) (children to) - & wither - ( \case - This ca -> do - -- TODO: For the names index we really don't need to know which exact - -- names were removed, we just need to delete from the index using a - -- prefix query, this would be faster than crawling to get all the deletes. - removedChildBranch <- Causal.value ca - Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty - That ca -> do - newChildBranch <- Causal.value ca - Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch - These fromC toC - | Causal.valueHash fromC == Causal.valueHash toC -> do - -- This child didn't change. - pure Nothing - | otherwise -> do - fromChildBranch <- Causal.value fromC - toChildBranch <- Causal.value toC - diffBranches fromChildBranch toChildBranch >>= \case - Lens.Empty -> pure Nothing - TreeDiff cfr -> pure . Just $ cfr - ) + & wither \case + This ca -> do + -- TODO: For the names index we really don't need to know which exact + -- names were removed, we just need to delete from the index using a + -- prefix query, this would be faster than crawling to get all the deletes. + removedChildBranch <- Causal.value ca + Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty + That ca -> do + newChildBranch <- Causal.value ca + Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch + These fromC toC + | Causal.valueHash fromC == Causal.valueHash toC -> do + -- This child didn't change. + pure Nothing + | otherwise -> do + fromChildBranch <- Causal.value fromC + toChildBranch <- Causal.value toC + diffBranches fromChildBranch toChildBranch >>= \case + Lens.Empty -> pure Nothing + TreeDiff cfr -> pure . Just $ cfr pure $ TreeDiff (defDiff :< childDiff) where diffMap :: forall ref. Ord ref => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref) diffMap l r = Align.align l r - & fmap - ( \case - (This refs) -> (Diff {removals = Map.keysSet refs, adds = mempty}) - (That refs) -> (Diff {removals = mempty, adds = Map.keysSet refs}) - (These l' r') -> - let lRefs = Map.keysSet l' - rRefs = Map.keysSet r' - in (Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs}) - ) + & fmap \case + This refs -> Diff {removals = Map.keysSet refs, adds = mempty} + That refs -> Diff {removals = mempty, adds = Map.keysSet refs} + These l' r' -> + let lRefs = Map.keysSet l' + rRefs = Map.keysSet r' + in Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs} -- | Get a summary of all of the name adds and removals from a tree diff. -- @@ -144,22 +164,19 @@ nameChanges :: NameChanges nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) = let (termNameAdds, termNameRemovals) = - ( termDiffs - & ifoldMap \ns diff -> - let name = appendName ns - in (listifyNames name $ adds diff, listifyNames name $ removals diff) - ) + termDiffs + & ifoldMap \ns diff -> + let name = appendName ns + in (listifyNames name $ adds diff, listifyNames name $ removals diff) (typeNameAdds, typeNameRemovals) = - ( typeDiffs - & ifoldMap \ns diff -> - let name = appendName ns - in (listifyNames name $ adds diff, listifyNames name $ removals diff) - ) + typeDiffs + & ifoldMap \ns diff -> + let name = appendName ns + in (listifyNames name $ adds diff, listifyNames name $ removals diff) childNameChanges = - ( children - & ifoldMap \ns childTree -> - nameChanges (Just $ appendName ns) (TreeDiff childTree) - ) + children + & ifoldMap \ns childTree -> + nameChanges (Just $ appendName ns) (TreeDiff childTree) in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges where appendName :: NameSegment -> Name @@ -172,3 +189,27 @@ nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< chil xs & Set.toList & fmap (name,) + +-- | Get a 'NameBasedDiff' from a 'TreeDiff'. +nameBasedDiff :: TreeDiff -> NameBasedDiff +nameBasedDiff (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) = + let NameBasedDiff childrenTerms childrenTypes = + foldMap (nameBasedDiff . TreeDiff) children + in NameBasedDiff + { terms = foldMap nameBasedTermDiff termDiffs <> childrenTerms, + types = foldMap nameBasedTypeDiff typeDiffs <> childrenTypes + } + where + nameBasedTermDiff :: Diff Referent -> Relation Reference Reference + nameBasedTermDiff Diff {adds, removals} = + let termAdds = mapMaybe Referent.toTermReference (Set.toList removals) + termRemovals = mapMaybe Referent.toTermReference (Set.toList adds) + in ((,) <$> termRemovals <*> termAdds) + & filter (\(r0, r1) -> r0 /= r1) + & Relation.fromList + + nameBasedTypeDiff :: Diff Reference -> Relation Reference Reference + nameBasedTypeDiff Diff {adds, removals} = + ((,) <$> Set.toList removals <*> Set.toList adds) + & filter (\(r0, r1) -> r0 /= r1) + & Relation.fromList