From eb1e3234d5342a086f29d23658d1133154c7dbba Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 12 Dec 2022 14:47:40 -0500 Subject: [PATCH 1/6] 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 From 200c8f1cbd9c055e54fd9da085a26c07d7d04d25 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 13 Dec 2022 14:05:39 -0500 Subject: [PATCH 2/6] make diff.namespace.to-patch command use v2 branch diffs --- .../src/U/Codebase/Branch/Diff.hs | 6 +- unison-cli/src/Unison/Cli/Monad.hs | 6 + unison-cli/src/Unison/Cli/MonadUtils.hs | 54 +++++--- .../src/Unison/Codebase/Editor/HandleInput.hs | 116 ++++++++++-------- 4 files changed, 111 insertions(+), 71 deletions(-) diff --git a/parser-typechecker/src/U/Codebase/Branch/Diff.hs b/parser-typechecker/src/U/Codebase/Branch/Diff.hs index 34403b4a9..842588bae 100644 --- a/parser-typechecker/src/U/Codebase/Branch/Diff.hs +++ b/parser-typechecker/src/U/Codebase/Branch/Diff.hs @@ -97,7 +97,7 @@ instance Monoid NameChanges where -- | 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` +-- 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, @@ -202,8 +202,8 @@ nameBasedDiff (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) = 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) + let termAdds = mapMaybe Referent.toTermReference (Set.toList adds) + termRemovals = mapMaybe Referent.toTermReference (Set.toList removals) in ((,) <$> termRemovals <*> termAdds) & filter (\(r0, r1) -> r0 /= r1) & Relation.fromList diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 638fb6fcf..2d6210e0d 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -38,6 +38,7 @@ module Unison.Cli.Monad -- * Running transactions runTransaction, + runEitherTransaction, -- * Misc types LoadSourceResult (..), @@ -381,3 +382,8 @@ runTransaction :: Sqlite.Transaction a -> Cli a runTransaction action = do Env {codebase} <- ask liftIO (Codebase.runTransaction codebase action) + +-- | Return early if a transaction returns Left. +runEitherTransaction :: Sqlite.Transaction (Either Output a) -> Cli a +runEitherTransaction action = + runTransaction action & onLeftM returnEarly diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index e487f2713..5299543a4 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -13,7 +13,9 @@ module Unison.Cli.MonadUtils -- ** Resolving branch identifiers resolveAbsBranchId, + resolveAbsBranchIdV2, resolveBranchId, + resolveBranchIdToAbsBranchId, resolveShortCausalHash, -- ** Getting/setting branches @@ -78,6 +80,7 @@ import Control.Monad.State import qualified Data.Configurator as Configurator import qualified Data.Configurator.Types as Configurator import qualified Data.Set as Set +import qualified U.Codebase.Branch as V2 (Branch) import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal import U.Codebase.HashTags (CausalHash (..)) @@ -101,6 +104,7 @@ import Unison.Parser.Ann (Ann (..)) import Unison.Prelude import Unison.Reference (TypeReference) import Unison.Referent (Referent) +import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import Unison.UnisonFile (TypecheckedUnisonFile) import qualified Unison.Util.Set as Set @@ -144,32 +148,54 @@ resolveAbsBranchId = \case Left hash -> resolveShortCausalHash hash Right path -> getBranchAt path +-- | V2 version of 'resolveAbsBranchId2'. +resolveAbsBranchIdV2 :: Input.AbsBranchId -> Sqlite.Transaction (Either Output.Output (V2.Branch Sqlite.Transaction)) +resolveAbsBranchIdV2 = \case + Left shortHash -> do + resolveShortCausalHashToCausalHash shortHash >>= \case + Left output -> pure (Left output) + Right hash -> succeed (Codebase.expectCausalBranchByCausalHash hash) + Right path -> succeed (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)) + where + succeed getCausal = do + causal <- getCausal + branch <- V2Causal.value causal + pure (Right branch) + -- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent -- branches by path are OK - the empty branch will be returned). resolveBranchId :: Input.BranchId -> Cli (Branch IO) resolveBranchId branchId = do - absBranchId <- traverseOf _Right resolvePath' branchId + absBranchId <- resolveBranchIdToAbsBranchId branchId resolveAbsBranchId absBranchId +-- | Resolve a @BranchId@ to an @AbsBranchId@. +resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId +resolveBranchIdToAbsBranchId = + traverseOf _Right resolvePath' + -- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found. resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) -resolveShortCausalHash hash = do +resolveShortCausalHash shortHash = do Cli.time "resolveShortCausalHash" do Cli.Env {codebase} <- ask - (hashSet, len) <- - Cli.runTransaction do - hashSet <- Codebase.causalHashesByPrefix hash - len <- Codebase.branchHashLength - pure (hashSet, len) - h <- - Set.asSingleton hashSet & onNothing do - Cli.returnEarly - if Set.null hashSet - then Output.NoBranchWithHash hash - else Output.BranchHashAmbiguous hash (Set.map (SCH.fromHash len) hashSet) - branch <- liftIO (Codebase.getBranchForHash codebase h) + hash <- Cli.runTransaction (resolveShortCausalHashToCausalHash shortHash) & onLeftM Cli.returnEarly + branch <- liftIO (Codebase.getBranchForHash codebase hash) pure (fromMaybe Branch.empty branch) +resolveShortCausalHashToCausalHash :: ShortCausalHash -> Sqlite.Transaction (Either Output.Output CausalHash) +resolveShortCausalHashToCausalHash shortHash = do + hashes <- Codebase.causalHashesByPrefix shortHash + case Set.asSingleton hashes of + Nothing -> + fmap Left do + if Set.null hashes + then pure (Output.NoBranchWithHash shortHash) + else do + len <- Codebase.branchHashLength + pure (Output.BranchHashAmbiguous shortHash (Set.map (SCH.fromHash len) hashes)) + Just hash -> pure (Right hash) + ------------------------------------------------------------------------------------------------------------------------ -- Getting/Setting branches diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 953c27f43..b050869e4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -12,6 +12,7 @@ import Control.Lens import Control.Monad.Reader (ask) import Control.Monad.State (StateT) import qualified Control.Monad.State as State +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Control.Monad.Writer (WriterT (..)) import Data.Bifunctor (first, second) import qualified Data.Foldable as Foldable @@ -41,6 +42,7 @@ import qualified Text.Megaparsec as P import qualified U.Codebase.Branch.Diff as V2Branch import qualified U.Codebase.Causal as V2Causal import U.Codebase.HashTags (CausalHash (..)) +import qualified U.Codebase.Reference as V2 (Reference) import qualified U.Codebase.Reflog as Reflog import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Queries @@ -64,7 +66,6 @@ import Unison.Codebase.Branch (Branch (..), Branch0 (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Branch.Names as Branch -import qualified Unison.Codebase.BranchDiff as BranchDiff (diff0) import qualified Unison.Codebase.BranchUtil as BranchUtil import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..)) @@ -118,6 +119,7 @@ import Unison.Codebase.PushBehavior (PushBehavior) import qualified Unison.Codebase.PushBehavior as PushBehavior import qualified Unison.Codebase.Runtime as Runtime import qualified Unison.Codebase.ShortCausalHash as SCH +import qualified Unison.Codebase.SqliteCodebase.Conversions as Conversions import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit @@ -1407,8 +1409,8 @@ loop e = do ([fromCH], [toCH]) -> pure (fromCH, toCH) output <- Cli.runTransaction do - fromBranch <- (Codebase.expectCausalBranchByCausalHash fromCH) >>= V2Causal.value - toBranch <- (Codebase.expectCausalBranchByCausalHash toCH) >>= V2Causal.value + fromBranch <- Codebase.expectCausalBranchByCausalHash fromCH >>= V2Causal.value + toBranch <- Codebase.expectCausalBranchByCausalHash toCH >>= V2Causal.value treeDiff <- V2Branch.diffBranches fromBranch toBranch let nameChanges = V2Branch.nameChanges Nothing treeDiff pure (DisplayDebugNameDiff nameChanges) @@ -1801,58 +1803,34 @@ handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli () handleDiffNamespaceToPatch description input = do Cli.Env {codebase} <- ask - branch1 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId1) - branch2 <- Branch.head <$> Cli.resolveBranchId (input ^. #branchId2) - branchDiff <- liftIO (BranchDiff.diff0 branch1 branch2) + absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1) + absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2) - -- Given {old referents} and {new referents}, create term edit patch entries as follows: - -- - -- * If the {new referents} is a singleton set {new referent}, proceed. (Otherwise, the patch we might create would - -- not be a function, which is a bogus/conflicted patch). - -- * If the new referent is a term reference, not a data constructor, proceed. (Patches currently can't track - -- updates to data constructors). - -- * For each old term reference (again, throwing constructors away) in {old referents}, create a patch entry that - -- maps the old reference to the new. The patch entry includes the typing relationship between the terms, so we - -- look the references' types up in the codebase, too. - let termNamespaceUpdateToTermEdits :: (Set Referent, Set Referent) -> Sqlite.Transaction (Set (Reference, TermEdit)) - termNamespaceUpdateToTermEdits (refs0, refs1) = - case Set.asSingleton refs1 of - Just (Referent.Ref ref1) -> - Codebase.getTypeOfTerm codebase ref1 >>= \case - Nothing -> pure Set.empty - Just ty1 -> - Monoid.foldMapM - ( \ref0 -> - Codebase.getTypeOfTerm codebase ref0 <&> \case - Nothing -> Set.empty - Just ty0 -> Set.singleton (ref0, TermEdit.Replace ref1 (TermEdit.typing ty0 ty1)) - ) - (mapMaybe Referent.toTermReference (Set.toList refs0)) - _ -> pure Set.empty - - -- The same idea as above, but for types: if there's one new reference in {new references}, then map each of the old - -- references to it. - let typeNamespaceUpdateToTypeEdits :: (Set Reference, Set Reference) -> Set (Reference, TypeEdit) - typeNamespaceUpdateToTypeEdits (refs0, refs1) = - case Set.asSingleton refs1 of - Just ref1 -> Set.map (\ref0 -> (ref0, TypeEdit.Replace ref1)) refs0 - _ -> Set.empty - - termUpdates <- - Cli.runTransaction do - (branchDiff ^. #termsDiff . #tallnamespaceUpdates) - & Map.elems - & Monoid.foldMapM termNamespaceUpdateToTermEdits - let typeUpdates = - (branchDiff ^. #typesDiff . #tallnamespaceUpdates) - & Map.elems - & foldMap typeNamespaceUpdateToTypeEdits - - let patch = - Patch - { _termEdits = Relation.fromSet termUpdates, - _typeEdits = Relation.fromSet typeUpdates - } + patch <- do + Cli.runEitherTransaction do + runExceptT do + branch1 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId1) + branch2 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId2) + lift do + branchDiff <- V2Branch.nameBasedDiff <$> V2Branch.diffBranches branch1 branch2 + termEdits <- + (branchDiff ^. #terms) + & Relation.domain + & Map.toList + & traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs + pure + Patch + { _termEdits = + termEdits + & catMaybes + & Relation.fromList, + _typeEdits = + (branchDiff ^. #types) + & Relation.domain + & Map.toList + & mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs) + & Relation.fromList + } -- Display the patch that we are about to create. ppe <- suffixifiedPPE =<< makePrintNamesFromLabeled' (Patch.labeledDependencies patch) @@ -1865,6 +1843,36 @@ handleDiffNamespaceToPatch description input = do Cli.stepAtM description (Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch)) + where + -- Given {old reference} and {new references}, create term edit patch entries as follows: + -- + -- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create + -- would not be a function, which is a bogus/conflicted patch). + -- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to + -- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a + -- patch entry that maps {old reference} to {new reference} with the typing relationship. + makeTermEdit :: + Codebase m Symbol Ann -> + V2.Reference -> + Set V2.Reference -> + Sqlite.Transaction (Maybe (Reference, TermEdit)) + makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs = + runMaybeT do + newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs)) + oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef) + newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef) + pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType)) + + -- Given {old reference} and {new references}, create term edit patch entries as follows: + -- + -- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create + -- would not be a function, which is a bogus/conflicted patch). + -- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to + -- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a + -- patch entry that maps {old reference} to {new reference} with the typing relationship. + makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit) + makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs = + Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef)) -- | Handle a @push@ command. handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () From 5115a7441255931c23c6e045824c74131fed7f82 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 13 Dec 2022 14:06:56 -0500 Subject: [PATCH 3/6] fix comment --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b050869e4..a42ca9de0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1863,13 +1863,7 @@ handleDiffNamespaceToPatch description input = do newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef) pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType)) - -- Given {old reference} and {new references}, create term edit patch entries as follows: - -- - -- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create - -- would not be a function, which is a bogus/conflicted patch). - -- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to - -- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a - -- patch entry that maps {old reference} to {new reference} with the typing relationship. + -- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database. makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit) makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs = Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef)) From 4cd748c337028fd8e3f1d51a703eaa5fee5573b5 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 15 Dec 2022 11:47:25 -0500 Subject: [PATCH 4/6] update transcript --- unison-src/transcripts/diff-namespace-to-patch.md | 3 +-- .../transcripts/diff-namespace-to-patch.output.md | 11 ++++------- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/unison-src/transcripts/diff-namespace-to-patch.md b/unison-src/transcripts/diff-namespace-to-patch.md index 436a50033..67ee00b9e 100644 --- a/unison-src/transcripts/diff-namespace-to-patch.md +++ b/unison-src/transcripts/diff-namespace-to-patch.md @@ -39,6 +39,5 @@ A summary of the diff: * `one.a` -> `two.a` is a normal update. * Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. * Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and - `one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug. +* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. * Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces. diff --git a/unison-src/transcripts/diff-namespace-to-patch.output.md b/unison-src/transcripts/diff-namespace-to-patch.output.md index 9be43a9a2..09798f8ae 100644 --- a/unison-src/transcripts/diff-namespace-to-patch.output.md +++ b/unison-src/transcripts/diff-namespace-to-patch.output.md @@ -39,11 +39,9 @@ two.e = 6 .> diff.namespace.to-patch one two thepatch Edited Terms: - 1. one.b#cp6ri8mtg0 -> 6. two.b - 2. one.b#dcgdua2lj6 -> 7. two.b - 3. one.a -> 8. two.a - 4. one.d -> 9. two.d - 5. one.d -> 10. two.e + 1. one.b#cp6ri8mtg0 -> 4. two.b + 2. one.b#dcgdua2lj6 -> 5. two.b + 3. one.a -> 6. two.a Tip: To remove entries from a patch, use delete.term-replacement or delete.type-replacement, as @@ -55,6 +53,5 @@ A summary of the diff: * `one.a` -> `two.a` is a normal update. * Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. * Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and - `one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug. +* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. * Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces. From f21e6483e76909cc6b10c34b5c27773db70ad493 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 15 Dec 2022 13:32:43 -0500 Subject: [PATCH 5/6] code review --- parser-typechecker/src/U/Codebase/Branch/Diff.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/U/Codebase/Branch/Diff.hs b/parser-typechecker/src/U/Codebase/Branch/Diff.hs index 842588bae..614942e08 100644 --- a/parser-typechecker/src/U/Codebase/Branch/Diff.hs +++ b/parser-typechecker/src/U/Codebase/Branch/Diff.hs @@ -107,7 +107,6 @@ data NameBasedDiff = NameBasedDiff instance Monoid NameBasedDiff where mempty = NameBasedDiff mempty mempty - mappend = (<>) instance Semigroup NameBasedDiff where NameBasedDiff terms0 types0 <> NameBasedDiff terms1 types1 = @@ -192,13 +191,12 @@ nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< chil -- | 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 - } +nameBasedDiff (TreeDiff defnDiffs) = + defnDiffs & foldMap \DefinitionDiffs {termDiffs, typeDiffs} -> + NameBasedDiff + { terms = foldMap nameBasedTermDiff termDiffs, + types = foldMap nameBasedTypeDiff typeDiffs + } where nameBasedTermDiff :: Diff Referent -> Relation Reference Reference nameBasedTermDiff Diff {adds, removals} = From 6e4bce6ae1f44491dbcd148fbe3531fde2ad18b1 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 16 Dec 2022 12:42:11 -0500 Subject: [PATCH 6/6] one more code review suggestion --- unison-cli/src/Unison/Cli/MonadUtils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 5299543a4..41985cc88 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -179,7 +179,7 @@ resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) resolveShortCausalHash shortHash = do Cli.time "resolveShortCausalHash" do Cli.Env {codebase} <- ask - hash <- Cli.runTransaction (resolveShortCausalHashToCausalHash shortHash) & onLeftM Cli.returnEarly + hash <- Cli.runEitherTransaction (resolveShortCausalHashToCausalHash shortHash) branch <- liftIO (Codebase.getBranchForHash codebase hash) pure (fromMaybe Branch.empty branch)