mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
split apart combine and partition diffs steps
This commit is contained in:
Mitchell Rosen
parent
6a847aedae
commit
4e42d38385
@ -74,7 +74,7 @@ unfoldNametree f x =
|
||||
-- > }
|
||||
-- > }
|
||||
--
|
||||
-- into an equivalent-but-flatter association between names and definitions, like
|
||||
-- into an equivalent-but-flat association between names and definitions, like
|
||||
--
|
||||
-- > {
|
||||
-- > "foo" = #bar,
|
||||
|
||||
@ -14,6 +14,7 @@ import Data.List qualified as List
|
||||
import Data.List.NonEmpty (pattern (:|))
|
||||
import Data.Map.Merge.Strict qualified as Map
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Semialign (unzip)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as Text
|
||||
@ -52,13 +53,14 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.Merge.CombineDiffs (combineDiffs)
|
||||
import Unison.Merge.CombineDiffs (CombinedDiffOp, combineDiffs)
|
||||
import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1)
|
||||
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency)
|
||||
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames)
|
||||
import Unison.Merge.Diff qualified as Merge
|
||||
import Unison.Merge.DiffOp (DiffOp (..))
|
||||
import Unison.Merge.Libdeps qualified as Merge
|
||||
import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
|
||||
import Unison.Merge.PreconditionViolation qualified as Merge
|
||||
import Unison.Merge.Synhashed (Synhashed (..))
|
||||
import Unison.Merge.Synhashed qualified as Synhashed
|
||||
@ -92,7 +94,7 @@ import Unison.UnisonFile (UnisonFile')
|
||||
import Unison.UnisonFile qualified as UnisonFile
|
||||
import Unison.Util.BiMultimap (BiMultimap)
|
||||
import Unison.Util.BiMultimap qualified as BiMultimap
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, zipDefnsWith)
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith)
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree)
|
||||
import Unison.Util.Pretty (ColorText, Pretty)
|
||||
@ -117,20 +119,20 @@ handleMerge bobBranchName = do
|
||||
-- Create a bunch of cached database lookup functions
|
||||
db <- makeMergeDatabase codebase
|
||||
|
||||
-- Load the current project branch ("alice"), and the branch from the same project to merge in ("bob")
|
||||
mergeInfo <- loadMergeInfo bobBranchName
|
||||
-- Load the current project branch ("Alice"), and the branch from the same project to merge in ("Bob")
|
||||
info <- loadMergeInfo bobBranchName
|
||||
|
||||
-- Load alice, bob, and LCA branches
|
||||
-- Load Alice/Bob/LCA branches
|
||||
branches <-
|
||||
Cli.runTransactionWithRollback \abort -> do
|
||||
loadV2Branches =<< loadV2Causals abort db mergeInfo
|
||||
loadV2Branches =<< loadV2Causals abort db info
|
||||
|
||||
-- Load alice, bob, and LCA definitions + decl names
|
||||
(declNameLookups, defns) <-
|
||||
-- Load Alice/Bob/LCA definitions and decl name lookups
|
||||
(defns, declNameLookups) <-
|
||||
Cli.runTransactionWithRollback \abort -> do
|
||||
loadDefns abort db mergeInfo branches
|
||||
loadDefns abort db info.projectBranches branches
|
||||
|
||||
liftIO (debugFunctions.debugDefns declNameLookups defns)
|
||||
liftIO (debugFunctions.debugDefns defns declNameLookups)
|
||||
|
||||
-- Diff LCA->Alice and LCA->Bob
|
||||
diffs <-
|
||||
@ -140,15 +142,20 @@ handleMerge bobBranchName = do
|
||||
liftIO (debugFunctions.debugDiffs diffs)
|
||||
|
||||
-- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias
|
||||
whenJust (findOneConflictedAlias mergeInfo.projectBranches defns.lca diffs) \violation ->
|
||||
whenJust (findOneConflictedAlias info.projectBranches defns.lca diffs) \violation ->
|
||||
Cli.returnEarly (mergePreconditionViolationToOutput violation)
|
||||
|
||||
-- Combine the LCA->Alice and LCA->Bob diffs together into the conflicted things and the unconflicted things
|
||||
-- Combine the LCA->Alice and LCA->Bob diffs together
|
||||
let diff = combineDiffs diffs
|
||||
|
||||
liftIO (debugFunctions.debugCombinedDiffs diff)
|
||||
|
||||
-- Partition the combined diff into the conflicted things and the unconflicted things
|
||||
(conflicts, unconflicts) <-
|
||||
combineDiffs (ThreeWay.forgetLca declNameLookups) (ThreeWay.forgetLca defns) diffs & onLeft \name ->
|
||||
partitionCombinedDiffs (ThreeWay.forgetLca defns) (ThreeWay.forgetLca declNameLookups) diff & onLeft \name ->
|
||||
Cli.returnEarly (mergePreconditionViolationToOutput (Merge.ConflictInvolvingBuiltin name))
|
||||
|
||||
liftIO (debugFunctions.debugCombinedDiffs conflicts unconflicts)
|
||||
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
|
||||
|
||||
-- Identify the dependents we need to pull into the Unison file (either first for typechecking, if there aren't
|
||||
-- conflicts, or else for manual conflict resolution without a typechecking step, if there are)
|
||||
@ -176,12 +183,7 @@ handleMerge bobBranchName = do
|
||||
|
||||
let thisMergeHasConflicts =
|
||||
-- Eh, they'd either both be null, or neither, but just check both maps anyway
|
||||
or
|
||||
[ not (Map.null conflicts.alice.terms),
|
||||
not (Map.null conflicts.alice.types),
|
||||
not (Map.null conflicts.bob.terms),
|
||||
not (Map.null conflicts.bob.types)
|
||||
]
|
||||
not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob)
|
||||
|
||||
-- Create the Unison file, which may have conflicts, in which case we don't bother trying to parse and typecheck it.
|
||||
unisonFile <-
|
||||
@ -218,7 +220,7 @@ handleMerge bobBranchName = do
|
||||
else prettyParseTypecheck unisonFile pped parsingEnv <&> eitherToMaybe
|
||||
|
||||
case maybeTypecheckedUnisonFile of
|
||||
Nothing -> promptUser mergeInfo (Pretty.prettyUnisonFile pped unisonFile) newBranchIO
|
||||
Nothing -> promptUser info (Pretty.prettyUnisonFile pped unisonFile) newBranchIO
|
||||
Just tuf -> do
|
||||
mergedBranchPlusTuf <-
|
||||
Cli.runTransactionWithRollback \abort -> do
|
||||
@ -226,11 +228,11 @@ handleMerge bobBranchName = do
|
||||
updates <- typecheckedUnisonFileToBranchUpdates abort undefined tuf
|
||||
pure (Branch.batchUpdates updates newBranchIO)
|
||||
Cli.stepAt
|
||||
(textualDescriptionOfMerge mergeInfo)
|
||||
( Path.unabsolute mergeInfo.paths.alice,
|
||||
(textualDescriptionOfMerge info)
|
||||
( Path.unabsolute info.paths.alice,
|
||||
const mergedBranchPlusTuf
|
||||
)
|
||||
Cli.respond (Output.MergeSuccess (aliceProjectAndBranchName mergeInfo) (bobProjectAndBranchName mergeInfo))
|
||||
Cli.respond (Output.MergeSuccess (aliceProjectAndBranchName info) (bobProjectAndBranchName info))
|
||||
|
||||
aliceProjectAndBranchName :: MergeInfo -> ProjectAndBranch ProjectName ProjectBranchName
|
||||
aliceProjectAndBranchName mergeInfo =
|
||||
@ -293,29 +295,25 @@ loadV2Branches causals = do
|
||||
loadDefns ::
|
||||
(forall a. Output -> Transaction a) ->
|
||||
MergeDatabase ->
|
||||
MergeInfo ->
|
||||
TwoWay ProjectBranch ->
|
||||
TwoOrThreeWay (V2.Branch Transaction) ->
|
||||
Transaction
|
||||
( ThreeWay DeclNameLookup,
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
|
||||
( ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)),
|
||||
ThreeWay DeclNameLookup
|
||||
)
|
||||
loadDefns abort0 db info branches = do
|
||||
loadDefns abort0 db projectBranches branches = do
|
||||
lcaDefns0 <-
|
||||
case branches.lca of
|
||||
Nothing -> pure Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
|
||||
Just lcaBranch -> loadNamespaceInfo abort db lcaBranch
|
||||
(lcaDeclNameLookup, lcaDefns1) <-
|
||||
assertNamespaceSatisfiesPreconditions db abort Nothing (fromMaybe V2.Branch.empty branches.lca) lcaDefns0
|
||||
aliceDefns0 <- loadNamespaceInfo abort db branches.alice
|
||||
(aliceDeclNameLookup, aliceDefns1) <-
|
||||
assertNamespaceSatisfiesPreconditions db abort (Just info.projectBranches.alice.name) branches.alice aliceDefns0
|
||||
bobDefns0 <- loadNamespaceInfo abort db branches.bob
|
||||
(bobDeclNameLookup, bobDefns1) <-
|
||||
assertNamespaceSatisfiesPreconditions db abort (Just info.projectBranches.bob.name) branches.bob bobDefns0
|
||||
pure
|
||||
( ThreeWay {lca = lcaDeclNameLookup, alice = aliceDeclNameLookup, bob = bobDeclNameLookup},
|
||||
ThreeWay {lca = lcaDefns1, alice = aliceDefns1, bob = bobDefns1}
|
||||
)
|
||||
|
||||
lca <- assertNamespaceSatisfiesPreconditions db abort Nothing (fromMaybe V2.Branch.empty branches.lca) lcaDefns0
|
||||
alice <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.alice.name) branches.alice aliceDefns0
|
||||
bob <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.bob.name) branches.bob bobDefns0
|
||||
|
||||
pure (unzip ThreeWay {lca, alice, bob})
|
||||
where
|
||||
abort :: Merge.PreconditionViolation -> Transaction void
|
||||
abort =
|
||||
@ -784,7 +782,7 @@ defnsRangeToNames Defns {terms, types} =
|
||||
types = Relation.fromMap types
|
||||
}
|
||||
|
||||
palonka :: DefnsF (Map Name) Referent TypeReference -> Either () DeclNameLookup
|
||||
palonka :: HasCallStack => DefnsF (Map Name) Referent TypeReference -> Either () DeclNameLookup
|
||||
palonka defns = do
|
||||
conToName <- bazinga defns.terms
|
||||
|
||||
@ -962,21 +960,23 @@ assertNamespaceSatisfiesPreconditions ::
|
||||
Maybe ProjectBranchName ->
|
||||
V2.Branch Transaction ->
|
||||
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
|
||||
Transaction (DeclNameLookup, Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
|
||||
Transaction (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name), DeclNameLookup)
|
||||
assertNamespaceSatisfiesPreconditions db abort maybeBranchName branch defns = do
|
||||
Map.lookup NameSegment.libSegment branch.children `whenJust` \libdepsCausal -> do
|
||||
whenJust (Map.lookup NameSegment.libSegment branch.children) \libdepsCausal -> do
|
||||
libdepsBranch <- libdepsCausal.value
|
||||
when (not (Map.null libdepsBranch.terms) || not (Map.null libdepsBranch.types)) do
|
||||
abort Merge.DefnsInLib
|
||||
|
||||
declNameLookup <-
|
||||
checkDeclCoherency db.loadDeclNumConstructors defns
|
||||
& onLeftM (abort . incoherentDeclReasonToMergePreconditionViolation)
|
||||
|
||||
pure
|
||||
( declNameLookup,
|
||||
Defns
|
||||
( Defns
|
||||
{ terms = flattenNametree (view #terms) defns,
|
||||
types = flattenNametree (view #types) defns
|
||||
}
|
||||
},
|
||||
declNameLookup
|
||||
)
|
||||
where
|
||||
incoherentDeclReasonToMergePreconditionViolation :: IncoherentDeclReason -> Merge.PreconditionViolation
|
||||
@ -1105,11 +1105,12 @@ libdepsToBranch0 db libdeps = do
|
||||
|
||||
data DebugFunctions = DebugFunctions
|
||||
{ debugDefns ::
|
||||
ThreeWay DeclNameLookup ->
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
ThreeWay DeclNameLookup ->
|
||||
IO (),
|
||||
debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (),
|
||||
debugCombinedDiffs ::
|
||||
debugCombinedDiffs :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (),
|
||||
debugPartitionedDiff ::
|
||||
TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) ->
|
||||
DefnsF Unconflicts Referent TypeReference ->
|
||||
IO (),
|
||||
@ -1127,6 +1128,7 @@ realDebugFunctions =
|
||||
{ debugDefns = realDebugDefns,
|
||||
debugDiffs = realDebugDiffs,
|
||||
debugCombinedDiffs = realDebugCombinedDiffs,
|
||||
debugPartitionedDiff = realDebugPartitionedDiff,
|
||||
debugDependents = realDebugDependents,
|
||||
debugMergedDefns = realDebugMergedDefns,
|
||||
debugMergedConstructorNames = realDebugMergedConstructorNames
|
||||
@ -1134,13 +1136,13 @@ realDebugFunctions =
|
||||
|
||||
fakeDebugFunctions :: DebugFunctions
|
||||
fakeDebugFunctions =
|
||||
DebugFunctions mempty mempty mempty mempty mempty mempty
|
||||
DebugFunctions mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
realDebugDefns ::
|
||||
ThreeWay DeclNameLookup ->
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
ThreeWay DeclNameLookup ->
|
||||
IO ()
|
||||
realDebugDefns declNameLookups defns = do
|
||||
realDebugDefns defns declNameLookups = do
|
||||
Text.putStrLn "\n=== Alice's definitions ==="
|
||||
for_ (Map.toList (BiMultimap.range defns.alice.terms)) \(name, ref) ->
|
||||
Text.putStrLn ("term " <> Name.toText name <> " => " <> tShow ref)
|
||||
@ -1176,11 +1178,18 @@ realDebugDiffs diffs = do
|
||||
for_ (Map.toList diffs.bob.types) \(name, op) ->
|
||||
Text.putStrLn ("type " <> Name.toText name <> " => " <> tShow (Synhashed.hash <$> op))
|
||||
|
||||
realDebugCombinedDiffs ::
|
||||
realDebugCombinedDiffs :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO ()
|
||||
realDebugCombinedDiffs diff = do
|
||||
for_ (Map.toList diff.terms) \(name, op) ->
|
||||
Text.putStrLn ("term " <> Name.toText name <> " => " <> tShow op)
|
||||
for_ (Map.toList diff.types) \(name, op) ->
|
||||
Text.putStrLn ("type " <> Name.toText name <> " => " <> tShow op)
|
||||
|
||||
realDebugPartitionedDiff ::
|
||||
TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) ->
|
||||
DefnsF Unconflicts Referent TypeReference ->
|
||||
IO ()
|
||||
realDebugCombinedDiffs conflicts unconflicts = do
|
||||
realDebugPartitionedDiff conflicts unconflicts = do
|
||||
when (not (Map.null conflicts.alice.terms) || not (Map.null conflicts.alice.types)) do
|
||||
Text.putStrLn "\n=== Alice's conflicts === "
|
||||
for_ (Map.toList conflicts.alice.terms) \(name, ref) ->
|
||||
|
||||
@ -8,3 +8,4 @@ data AliceIorBob
|
||||
= OnlyAlice
|
||||
| OnlyBob
|
||||
| AliceAndBob
|
||||
deriving stock (Show)
|
||||
|
||||
@ -2,306 +2,63 @@
|
||||
|
||||
-- | Combine two diffs together.
|
||||
module Unison.Merge.CombineDiffs
|
||||
( combineDiffs,
|
||||
( CombinedDiffOp (..),
|
||||
combineDiffs,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Lens', over, view, (%~), (.~))
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Semialign (alignWith)
|
||||
import Data.These (These (..))
|
||||
import Unison.Merge.AliceIorBob (AliceIorBob (..))
|
||||
import Unison.Merge.AliceXorBob (AliceXorBob (..))
|
||||
import Unison.Merge.AliceXorBob qualified as AliceXorBob
|
||||
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames, expectDeclName)
|
||||
import Unison.Merge.DiffOp (DiffOp (..))
|
||||
import Unison.Merge.Synhashed (Synhashed (..))
|
||||
import Unison.Merge.TwoDiffOps (TwoDiffOps (..), combineTwoDiffOps)
|
||||
import Unison.Merge.TwoWay (TwoWay (..), twoWay)
|
||||
import Unison.Merge.TwoWay qualified as TwoWay
|
||||
import Unison.Merge.TwoWayI (TwoWayI (..))
|
||||
import Unison.Merge.TwoWayI qualified as TwoWayI
|
||||
import Unison.Merge.Unconflicts (Unconflicts (..))
|
||||
import Unison.Merge.Unconflicts qualified as Unconflicts
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude hiding (catMaybes)
|
||||
import Unison.Reference (Reference' (..), TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.BiMultimap (BiMultimap)
|
||||
import Unison.Util.BiMultimap qualified as BiMultimap
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, DefnsF4, defnsAreEmpty)
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Defns (DefnsF2, DefnsF3)
|
||||
|
||||
-- | The combined result of two diffs on the same thing.
|
||||
data CombinedDiffOps ref
|
||||
= CombinedDiffOps'Add !AliceIorBob !ref
|
||||
| CombinedDiffOps'Delete !AliceIorBob !ref -- old value
|
||||
| CombinedDiffOps'Update !AliceIorBob !ref !ref -- old value, new value
|
||||
data CombinedDiffOp a
|
||||
= CombinedDiffOp'Add !AliceIorBob !a
|
||||
| CombinedDiffOp'Delete !AliceIorBob !a -- old value
|
||||
| CombinedDiffOp'Update !AliceIorBob !a !a -- old value, new value
|
||||
| -- An add-add or an update-update conflict. We don't consider update-delete a conflict; the delete gets ignored.
|
||||
CombinedDiffOps'Conflict !(TwoWay ref)
|
||||
CombinedDiffOp'Conflict !(TwoWay a)
|
||||
deriving stock (Show)
|
||||
|
||||
-- | Combine LCA->Alice diff and LCA->Bob diff, then partition into conflicted and unconflicted things.
|
||||
-- | Combine LCA->Alice diff and LCA->Bob diff.
|
||||
combineDiffs ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) ->
|
||||
Either
|
||||
Name
|
||||
( TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId),
|
||||
DefnsF Unconflicts Referent TypeReference
|
||||
)
|
||||
combineDiffs declNameLookups defns diffs = do
|
||||
let diffs1 :: DefnsF4 TwoWay (Map Name) DiffOp Synhashed Referent TypeReference
|
||||
diffs1 =
|
||||
TwoWay.sequenceDefns diffs
|
||||
|
||||
let diffs2 :: DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference
|
||||
diffs2 =
|
||||
let f = twoWay (alignWith combine)
|
||||
in bimap f f diffs1
|
||||
|
||||
let conflicts0 = identifyConflicts declNameLookups defns diffs2
|
||||
|
||||
let unconflicts = identifyUnconflicts declNameLookups conflicts0 diffs2
|
||||
|
||||
conflicts <- assertThereAreNoBuiltins conflicts0
|
||||
|
||||
Right (conflicts, unconflicts)
|
||||
|
||||
identifyConflicts ::
|
||||
HasCallStack =>
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
identifyConflicts declNameLookups defns =
|
||||
loop . makeInitialIdentifyConflictsState
|
||||
DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
|
||||
combineDiffs =
|
||||
bimap f f . TwoWay.sequenceDefns
|
||||
where
|
||||
loop :: S -> TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
loop s =
|
||||
case (view myTermStack_ s, view myTypeStack_ s, defnsAreEmpty (view theirStacks_ s)) of
|
||||
(name : names, _, _) -> loop (poppedTerm name (s & myTermStack_ .~ names))
|
||||
([], name : names, _) -> loop (poppedType name (s & myTypeStack_ .~ names))
|
||||
([], [], False) -> loop (s & #me %~ AliceXorBob.swap)
|
||||
([], [], True) -> s.conflicts
|
||||
where
|
||||
poppedTerm :: Name -> S -> S
|
||||
poppedTerm name =
|
||||
case BiMultimap.lookupRan name (view (me_ . #terms) defns) of
|
||||
Nothing -> id
|
||||
Just (Referent.Ref ref) -> over myTermConflicts_ (Map.insert name ref)
|
||||
Just (Referent.Con _ _) -> over myTypeStack_ (expectDeclName myDeclNameLookup name :)
|
||||
f = twoWay (alignWith combine)
|
||||
|
||||
poppedType :: Name -> S -> S
|
||||
poppedType name s =
|
||||
fromMaybe s do
|
||||
ref <- BiMultimap.lookupRan name (view (me_ . #types) defns)
|
||||
conflicts <- Map.upsertF (maybe (Just ref) (const Nothing)) name (view myTypeConflicts_ s)
|
||||
Just $
|
||||
s
|
||||
& myTypeConflicts_ .~ conflicts
|
||||
& case ref of
|
||||
ReferenceBuiltin _ -> id -- builtin types don't have constructors
|
||||
ReferenceDerived _ -> theirTermStack_ %~ (expectConstructorNames myDeclNameLookup name ++)
|
||||
|
||||
me_ :: Lens' (TwoWay a) a
|
||||
me_ = TwoWay.who_ s.me
|
||||
|
||||
myConflicts_ :: Lens' S (DefnsF (Map Name) TermReference TypeReference)
|
||||
myConflicts_ = #conflicts . me_
|
||||
|
||||
myTermConflicts_ :: Lens' S (Map Name TermReference)
|
||||
myTermConflicts_ = myConflicts_ . #terms
|
||||
|
||||
myTypeConflicts_ :: Lens' S (Map Name TermReference)
|
||||
myTypeConflicts_ = myConflicts_ . #types
|
||||
|
||||
myStacks_ :: Lens' S (DefnsF [] Name Name)
|
||||
myStacks_ = #stacks . me_
|
||||
|
||||
myTermStack_ :: Lens' S [Name]
|
||||
myTermStack_ = myStacks_ . #terms
|
||||
|
||||
myTypeStack_ :: Lens' S [Name]
|
||||
myTypeStack_ = myStacks_ . #types
|
||||
|
||||
myDeclNameLookup :: DeclNameLookup
|
||||
myDeclNameLookup = view me_ declNameLookups
|
||||
|
||||
them_ :: Lens' (TwoWay a) a
|
||||
them_ = TwoWay.who_ (AliceXorBob.swap s.me)
|
||||
|
||||
theirStacks_ :: Lens' S (DefnsF [] Name Name)
|
||||
theirStacks_ = #stacks . them_
|
||||
|
||||
theirTermStack_ :: Lens' S [Name]
|
||||
theirTermStack_ = theirStacks_ . #terms
|
||||
|
||||
identifyUnconflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference ->
|
||||
DefnsF Unconflicts Referent TypeReference
|
||||
identifyUnconflicts declNameLookups conflicts =
|
||||
bimap (identifyTermUnconflicts declNameLookups conflicts) (identifyTypeUnconflicts (view #types <$> conflicts))
|
||||
|
||||
identifyTermUnconflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Map Name (CombinedDiffOps Referent) ->
|
||||
Unconflicts Referent
|
||||
identifyTermUnconflicts declNameLookups conflicts =
|
||||
Map.foldlWithKey' (\acc name op -> f name op acc) Unconflicts.empty
|
||||
where
|
||||
f :: Name -> CombinedDiffOps Referent -> Unconflicts Referent -> Unconflicts Referent
|
||||
f name = \case
|
||||
CombinedDiffOps'Add who ref ->
|
||||
case ref of
|
||||
Referent.Ref _ -> keepIt1
|
||||
Referent.Con _ _ -> if constructor who then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt #adds who name ref
|
||||
CombinedDiffOps'Update who _old new ->
|
||||
case new of
|
||||
Referent.Ref _ ->
|
||||
case who of
|
||||
OnlyAlice -> if termIsConflicted.alice then ignoreIt else keepIt1
|
||||
OnlyBob -> if termIsConflicted.bob then ignoreIt else keepIt1
|
||||
AliceAndBob -> keepIt1
|
||||
Referent.Con _ _ -> if constructor who then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt #updates who name new
|
||||
CombinedDiffOps'Delete who ref -> keepIt #deletes who name ref
|
||||
CombinedDiffOps'Conflict _ -> ignoreIt
|
||||
where
|
||||
-- Ignore added/updated constructors whose types are conflicted
|
||||
constructor :: AliceIorBob -> Bool
|
||||
constructor = \case
|
||||
OnlyAlice -> constructorHasConflictedType.alice
|
||||
OnlyBob -> constructorHasConflictedType.bob
|
||||
AliceAndBob -> TwoWay.or constructorHasConflictedType
|
||||
|
||||
constructorHasConflictedType :: TwoWay Bool
|
||||
constructorHasConflictedType =
|
||||
(\conflicts1 declNameLookup -> Map.member (expectDeclName declNameLookup name) conflicts1.types)
|
||||
<$> conflicts
|
||||
<*> declNameLookups
|
||||
|
||||
termIsConflicted :: TwoWay Bool
|
||||
termIsConflicted =
|
||||
Map.member name . view #terms <$> conflicts
|
||||
|
||||
identifyTypeUnconflicts ::
|
||||
TwoWay (Map Name TypeReference) ->
|
||||
Map Name (CombinedDiffOps TypeReference) ->
|
||||
Unconflicts TypeReference
|
||||
identifyTypeUnconflicts conflicts =
|
||||
Map.foldlWithKey' (\acc name ref -> f name ref acc) Unconflicts.empty
|
||||
where
|
||||
f :: Name -> CombinedDiffOps TypeReference -> Unconflicts TypeReference -> Unconflicts TypeReference
|
||||
f name = \case
|
||||
CombinedDiffOps'Add who ref -> addOrUpdate #adds who ref
|
||||
CombinedDiffOps'Update who _old new -> addOrUpdate #updates who new
|
||||
CombinedDiffOps'Delete who ref -> keepIt #deletes who name ref
|
||||
CombinedDiffOps'Conflict _ -> ignoreIt
|
||||
where
|
||||
addOrUpdate :: Lens' (Unconflicts v) (TwoWayI (Map Name v)) -> AliceIorBob -> v -> Unconflicts v -> Unconflicts v
|
||||
addOrUpdate l who ref =
|
||||
case who of
|
||||
OnlyAlice -> if typeIsConflicted.alice then ignoreIt else keepIt1
|
||||
OnlyBob -> if typeIsConflicted.bob then ignoreIt else keepIt1
|
||||
AliceAndBob -> if TwoWay.or typeIsConflicted then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt l who name ref
|
||||
|
||||
typeIsConflicted :: TwoWay Bool
|
||||
typeIsConflicted =
|
||||
Map.member name <$> conflicts
|
||||
|
||||
keepIt ::
|
||||
Lens' (Unconflicts v) (TwoWayI (Map Name v)) ->
|
||||
AliceIorBob ->
|
||||
Name ->
|
||||
v ->
|
||||
Unconflicts v ->
|
||||
Unconflicts v
|
||||
keepIt what who name ref =
|
||||
over (what . TwoWayI.who_ who) (Map.insert name ref)
|
||||
|
||||
ignoreIt :: Unconflicts v -> Unconflicts v
|
||||
ignoreIt =
|
||||
id
|
||||
|
||||
makeInitialIdentifyConflictsState :: DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference -> S
|
||||
makeInitialIdentifyConflictsState diff =
|
||||
S
|
||||
{ me = Alice,
|
||||
conflicts = mempty,
|
||||
stacks =
|
||||
let f = TwoWay.bothWays . justTheConflictedNames
|
||||
in bitraverse f f diff
|
||||
}
|
||||
|
||||
-- Given a combined diff, return the names that are conflicted.
|
||||
justTheConflictedNames :: Map Name (CombinedDiffOps a) -> [Name]
|
||||
justTheConflictedNames =
|
||||
Map.foldlWithKey' f []
|
||||
where
|
||||
f :: [Name] -> Name -> CombinedDiffOps term -> [Name]
|
||||
f names name = \case
|
||||
CombinedDiffOps'Conflict _ -> name : names
|
||||
CombinedDiffOps'Add _ _ -> names
|
||||
CombinedDiffOps'Delete _ _ -> names
|
||||
CombinedDiffOps'Update _ _ _ -> names
|
||||
|
||||
data S = S
|
||||
{ me :: !AliceXorBob,
|
||||
conflicts :: !(TwoWay (DefnsF (Map Name) TermReference TypeReference)),
|
||||
stacks :: !(TwoWay (DefnsF [] Name Name))
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
combine :: These (DiffOp (Synhashed ref)) (DiffOp (Synhashed ref)) -> CombinedDiffOps ref
|
||||
combine :: These (DiffOp (Synhashed ref)) (DiffOp (Synhashed ref)) -> CombinedDiffOp ref
|
||||
combine =
|
||||
combineTwoDiffOps >>> \case
|
||||
TwoDiffOps'Add who x -> CombinedDiffOps'Add (xor2ior who) x.value
|
||||
TwoDiffOps'Delete who x -> CombinedDiffOps'Delete (xor2ior who) x.value
|
||||
TwoDiffOps'Update who old new -> CombinedDiffOps'Update (xor2ior who) old.value new.value
|
||||
TwoDiffOps'Add who x -> CombinedDiffOp'Add (xor2ior who) x.value
|
||||
TwoDiffOps'Delete who x -> CombinedDiffOp'Delete (xor2ior who) x.value
|
||||
TwoDiffOps'Update who old new -> CombinedDiffOp'Update (xor2ior who) old.value new.value
|
||||
TwoDiffOps'AddAdd TwoWay {alice, bob}
|
||||
| alice /= bob -> CombinedDiffOps'Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> CombinedDiffOps'Add AliceAndBob alice.value
|
||||
TwoDiffOps'DeleteDelete x -> CombinedDiffOps'Delete AliceAndBob x.value
|
||||
| alice /= bob -> CombinedDiffOp'Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> CombinedDiffOp'Add AliceAndBob alice.value
|
||||
TwoDiffOps'DeleteDelete x -> CombinedDiffOp'Delete AliceAndBob x.value
|
||||
-- These two are not a conflicts, perhaps only temporarily, because it's easier to implement. We just ignore these
|
||||
-- deletes and keep the updates.
|
||||
TwoDiffOps'DeleteUpdate old new -> CombinedDiffOps'Update OnlyBob old.value new.value
|
||||
TwoDiffOps'UpdateDelete old new -> CombinedDiffOps'Update OnlyAlice old.value new.value
|
||||
TwoDiffOps'DeleteUpdate old new -> CombinedDiffOp'Update OnlyBob old.value new.value
|
||||
TwoDiffOps'UpdateDelete old new -> CombinedDiffOp'Update OnlyAlice old.value new.value
|
||||
TwoDiffOps'UpdateUpdate old TwoWay {alice, bob}
|
||||
| alice /= bob -> CombinedDiffOps'Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> CombinedDiffOps'Update AliceAndBob old.value alice.value
|
||||
| alice /= bob -> CombinedDiffOp'Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> CombinedDiffOp'Update AliceAndBob old.value alice.value
|
||||
|
||||
xor2ior :: AliceXorBob -> AliceIorBob
|
||||
xor2ior = \case
|
||||
Alice -> OnlyAlice
|
||||
Bob -> OnlyBob
|
||||
|
||||
assertThereAreNoBuiltins ::
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Either Name (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId))
|
||||
assertThereAreNoBuiltins =
|
||||
traverse (bitraverse (Map.traverseWithKey assertTermIsntBuiltin) (Map.traverseWithKey assertTypeIsntBuiltin))
|
||||
where
|
||||
assertTermIsntBuiltin :: Name -> TermReference -> Either Name TermReferenceId
|
||||
assertTermIsntBuiltin name ref =
|
||||
case Reference.toId ref of
|
||||
Nothing -> Left name
|
||||
Just refId -> Right refId
|
||||
|
||||
-- Same body as above, but could be different some day (e.g. return value tells you what namespace)
|
||||
assertTypeIsntBuiltin :: Name -> TypeReference -> Either Name TypeReferenceId
|
||||
assertTypeIsntBuiltin name ref =
|
||||
case Reference.toId ref of
|
||||
Nothing -> Left name
|
||||
Just refId -> Right refId
|
||||
|
||||
@ -37,16 +37,14 @@ import Unison.Util.BiMultimap qualified as BiMultimap
|
||||
import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith)
|
||||
import Unison.Var (Var)
|
||||
|
||||
-- | @nameBasedNamespaceDiff db defns@ returns Alice's and Bob's name-based namespace diffs, each in the form:
|
||||
-- | @nameBasedNamespaceDiff db declNameLookups defns@ returns Alice's and Bob's name-based namespace diffs, each in the
|
||||
-- form:
|
||||
--
|
||||
-- > decls :: Map Name (DiffOp (Synhashed TypeReference))
|
||||
-- > terms :: Map Name (DiffOp (Synhashed Referent))
|
||||
-- > types :: Map Name (DiffOp (Synhashed TypeReference))
|
||||
--
|
||||
-- where each name is paired with its diff-op (added, deleted, or updated), relative to the LCA between Alice and Bob's
|
||||
-- branches. If the hash of a name did not change, it will not appear in the map.
|
||||
--
|
||||
-- If there is no LCA, this operation is equivalent to a two-way diff, where every name in each of Alice and Bob's
|
||||
-- branches is considered an add.
|
||||
nameBasedNamespaceDiff ::
|
||||
MergeDatabase ->
|
||||
ThreeWay DeclNameLookup ->
|
||||
@ -117,12 +115,10 @@ diffNamespaceDefns =
|
||||
|
||||
deepNamespaceDefinitionsToPpe :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> PrettyPrintEnv
|
||||
deepNamespaceDefinitionsToPpe Defns {terms, types} =
|
||||
PrettyPrintEnv
|
||||
(\ref -> arbitraryName ref terms)
|
||||
(\ref -> arbitraryName ref types)
|
||||
PrettyPrintEnv (arbitraryName terms) (arbitraryName types)
|
||||
where
|
||||
arbitraryName :: Ord ref => ref -> BiMultimap ref Name -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
|
||||
arbitraryName ref names =
|
||||
arbitraryName :: Ord ref => BiMultimap ref Name -> ref -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
|
||||
arbitraryName names ref =
|
||||
BiMultimap.lookupDom ref names
|
||||
& Set.lookupMin
|
||||
& maybe [] \name -> [(HQ'.NameOnly name, HQ'.NameOnly name)]
|
||||
|
||||
268
unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs
Normal file
268
unison-merge/src/Unison/Merge/PartitionCombinedDiffs.hs
Normal file
@ -0,0 +1,268 @@
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
|
||||
module Unison.Merge.PartitionCombinedDiffs
|
||||
( partitionCombinedDiffs,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Lens', over, view, (%~), (.~))
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Unison.Merge.AliceIorBob (AliceIorBob (..))
|
||||
import Unison.Merge.AliceXorBob (AliceXorBob (..))
|
||||
import Unison.Merge.AliceXorBob qualified as AliceXorBob
|
||||
import Unison.Merge.CombineDiffs (CombinedDiffOp (..))
|
||||
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames, expectDeclName)
|
||||
import Unison.Merge.TwoWay (TwoWay (..))
|
||||
import Unison.Merge.TwoWay qualified as TwoWay
|
||||
import Unison.Merge.TwoWayI (TwoWayI (..))
|
||||
import Unison.Merge.TwoWayI qualified as TwoWayI
|
||||
import Unison.Merge.Unconflicts (Unconflicts (..))
|
||||
import Unison.Merge.Unconflicts qualified as Unconflicts
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude hiding (catMaybes)
|
||||
import Unison.Reference (Reference' (..), TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.BiMultimap (BiMultimap)
|
||||
import Unison.Util.BiMultimap qualified as BiMultimap
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, defnsAreEmpty)
|
||||
import Unison.Util.Map qualified as Map
|
||||
|
||||
-- | Combine LCA->Alice diff and LCA->Bob diff, then partition into conflicted and unconflicted things.
|
||||
partitionCombinedDiffs ::
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
TwoWay DeclNameLookup ->
|
||||
DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference ->
|
||||
Either
|
||||
Name
|
||||
( TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId),
|
||||
DefnsF Unconflicts Referent TypeReference
|
||||
)
|
||||
partitionCombinedDiffs defns declNameLookups diffs = do
|
||||
let conflicts0 = identifyConflicts declNameLookups defns diffs
|
||||
let unconflicts = identifyUnconflicts declNameLookups conflicts0 diffs
|
||||
conflicts <- assertThereAreNoBuiltins conflicts0
|
||||
Right (conflicts, unconflicts)
|
||||
|
||||
data S = S
|
||||
{ me :: !AliceXorBob,
|
||||
conflicts :: !(TwoWay (DefnsF (Map Name) TermReference TypeReference)),
|
||||
stacks :: !(TwoWay (DefnsF [] Name Name))
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
makeInitialIdentifyConflictsState :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> S
|
||||
makeInitialIdentifyConflictsState diff =
|
||||
S
|
||||
{ me = Alice, -- arbitrary initial person
|
||||
conflicts = mempty,
|
||||
stacks =
|
||||
let f = TwoWay.bothWays . justTheConflictedNames
|
||||
in bitraverse f f diff
|
||||
}
|
||||
|
||||
identifyConflicts ::
|
||||
HasCallStack =>
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
identifyConflicts declNameLookups defns =
|
||||
loop . makeInitialIdentifyConflictsState
|
||||
where
|
||||
loop :: S -> TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
loop s =
|
||||
case (view myTermStack_ s, view myTypeStack_ s, defnsAreEmpty (view theirStacks_ s)) of
|
||||
(name : names, _, _) -> loop (poppedTerm name (s & myTermStack_ .~ names))
|
||||
([], name : names, _) -> loop (poppedType name (s & myTypeStack_ .~ names))
|
||||
([], [], False) -> loop (s & #me %~ AliceXorBob.swap)
|
||||
([], [], True) -> s.conflicts
|
||||
where
|
||||
poppedTerm :: Name -> S -> S
|
||||
poppedTerm name =
|
||||
case BiMultimap.lookupRan name (view myTerms_ defns) of
|
||||
Nothing -> id
|
||||
Just (Referent.Ref ref) -> over myTermConflicts_ (Map.insert name ref)
|
||||
Just (Referent.Con _ _) -> over myTypeStack_ (expectDeclName myDeclNameLookup name :)
|
||||
|
||||
poppedType :: Name -> S -> S
|
||||
poppedType name s =
|
||||
fromMaybe s do
|
||||
ref <- BiMultimap.lookupRan name (view myTypes_ defns)
|
||||
-- Bail early here (by returning Nothing in the first argument to upsertF) if we've already recorded this
|
||||
-- type as conflicted, because in that case we've already added its constructor names to the other person's
|
||||
-- term stack, and we only want to do that once.
|
||||
typeConflicts <- Map.upsertF (maybe (Just ref) (const Nothing)) name (view myTypeConflicts_ s)
|
||||
Just $
|
||||
s
|
||||
& myTypeConflicts_ .~ typeConflicts
|
||||
& case ref of
|
||||
ReferenceBuiltin _ -> id -- builtin types don't have constructors
|
||||
ReferenceDerived _ -> theirTermStack_ %~ (expectConstructorNames myDeclNameLookup name ++)
|
||||
|
||||
me_ :: Lens' (TwoWay a) a
|
||||
me_ = TwoWay.who_ s.me
|
||||
|
||||
myTerms_ :: Lens' (TwoWay (Defns terms types)) terms
|
||||
myTerms_ = me_ . #terms
|
||||
|
||||
myTypes_ :: Lens' (TwoWay (Defns terms types)) types
|
||||
myTypes_ = me_ . #types
|
||||
|
||||
myConflicts_ :: Lens' S (DefnsF (Map Name) TermReference TypeReference)
|
||||
myConflicts_ = #conflicts . me_
|
||||
|
||||
myTermConflicts_ :: Lens' S (Map Name TermReference)
|
||||
myTermConflicts_ = myConflicts_ . #terms
|
||||
|
||||
myTypeConflicts_ :: Lens' S (Map Name TermReference)
|
||||
myTypeConflicts_ = myConflicts_ . #types
|
||||
|
||||
myStacks_ :: Lens' S (DefnsF [] Name Name)
|
||||
myStacks_ = #stacks . me_
|
||||
|
||||
myTermStack_ :: Lens' S [Name]
|
||||
myTermStack_ = myStacks_ . #terms
|
||||
|
||||
myTypeStack_ :: Lens' S [Name]
|
||||
myTypeStack_ = myStacks_ . #types
|
||||
|
||||
myDeclNameLookup :: DeclNameLookup
|
||||
myDeclNameLookup = view me_ declNameLookups
|
||||
|
||||
them_ :: Lens' (TwoWay a) a
|
||||
them_ = TwoWay.who_ (AliceXorBob.swap s.me)
|
||||
|
||||
theirStacks_ :: Lens' S (DefnsF [] Name Name)
|
||||
theirStacks_ = #stacks . them_
|
||||
|
||||
theirTermStack_ :: Lens' S [Name]
|
||||
theirTermStack_ = theirStacks_ . #terms
|
||||
|
||||
identifyUnconflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference ->
|
||||
DefnsF Unconflicts Referent TypeReference
|
||||
identifyUnconflicts declNameLookups conflicts =
|
||||
bimap (identifyTermUnconflicts declNameLookups conflicts) (identifyTypeUnconflicts (view #types <$> conflicts))
|
||||
|
||||
identifyTermUnconflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Map Name (CombinedDiffOp Referent) ->
|
||||
Unconflicts Referent
|
||||
identifyTermUnconflicts declNameLookups conflicts =
|
||||
Map.foldlWithKey' (\acc name op -> f name op acc) Unconflicts.empty
|
||||
where
|
||||
f :: Name -> CombinedDiffOp Referent -> Unconflicts Referent -> Unconflicts Referent
|
||||
f name = \case
|
||||
CombinedDiffOp'Add who ref ->
|
||||
case ref of
|
||||
Referent.Ref _ -> keepIt1
|
||||
Referent.Con _ _ -> if constructor who then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt #adds who name ref
|
||||
CombinedDiffOp'Update who _old new ->
|
||||
case new of
|
||||
Referent.Ref _ ->
|
||||
case who of
|
||||
OnlyAlice -> if termIsConflicted.alice then ignoreIt else keepIt1
|
||||
OnlyBob -> if termIsConflicted.bob then ignoreIt else keepIt1
|
||||
AliceAndBob -> keepIt1
|
||||
Referent.Con _ _ -> if constructor who then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt #updates who name new
|
||||
CombinedDiffOp'Delete who ref -> keepIt #deletes who name ref
|
||||
CombinedDiffOp'Conflict _ -> ignoreIt
|
||||
where
|
||||
-- Ignore added/updated constructors whose types are conflicted
|
||||
constructor :: AliceIorBob -> Bool
|
||||
constructor = \case
|
||||
OnlyAlice -> constructorHasConflictedType.alice
|
||||
OnlyBob -> constructorHasConflictedType.bob
|
||||
AliceAndBob -> TwoWay.or constructorHasConflictedType
|
||||
|
||||
constructorHasConflictedType :: TwoWay Bool
|
||||
constructorHasConflictedType =
|
||||
(\conflicts1 declNameLookup -> Map.member (expectDeclName declNameLookup name) conflicts1.types)
|
||||
<$> conflicts
|
||||
<*> declNameLookups
|
||||
|
||||
termIsConflicted :: TwoWay Bool
|
||||
termIsConflicted =
|
||||
Map.member name . view #terms <$> conflicts
|
||||
|
||||
identifyTypeUnconflicts ::
|
||||
TwoWay (Map Name TypeReference) ->
|
||||
Map Name (CombinedDiffOp TypeReference) ->
|
||||
Unconflicts TypeReference
|
||||
identifyTypeUnconflicts conflicts =
|
||||
Map.foldlWithKey' (\acc name ref -> f name ref acc) Unconflicts.empty
|
||||
where
|
||||
f :: Name -> CombinedDiffOp TypeReference -> Unconflicts TypeReference -> Unconflicts TypeReference
|
||||
f name = \case
|
||||
CombinedDiffOp'Add who ref -> addOrUpdate #adds who ref
|
||||
CombinedDiffOp'Update who _old new -> addOrUpdate #updates who new
|
||||
CombinedDiffOp'Delete who ref -> keepIt #deletes who name ref
|
||||
CombinedDiffOp'Conflict _ -> ignoreIt
|
||||
where
|
||||
addOrUpdate :: Lens' (Unconflicts v) (TwoWayI (Map Name v)) -> AliceIorBob -> v -> Unconflicts v -> Unconflicts v
|
||||
addOrUpdate l who ref =
|
||||
case who of
|
||||
OnlyAlice -> if typeIsConflicted.alice then ignoreIt else keepIt1
|
||||
OnlyBob -> if typeIsConflicted.bob then ignoreIt else keepIt1
|
||||
AliceAndBob -> if TwoWay.or typeIsConflicted then ignoreIt else keepIt1
|
||||
where
|
||||
keepIt1 = keepIt l who name ref
|
||||
|
||||
typeIsConflicted :: TwoWay Bool
|
||||
typeIsConflicted =
|
||||
Map.member name <$> conflicts
|
||||
|
||||
keepIt ::
|
||||
Lens' (Unconflicts v) (TwoWayI (Map Name v)) ->
|
||||
AliceIorBob ->
|
||||
Name ->
|
||||
v ->
|
||||
Unconflicts v ->
|
||||
Unconflicts v
|
||||
keepIt what who name ref =
|
||||
over (what . TwoWayI.who_ who) (Map.insert name ref)
|
||||
|
||||
ignoreIt :: Unconflicts v -> Unconflicts v
|
||||
ignoreIt =
|
||||
id
|
||||
|
||||
-- Given a combined diff, return the names that are conflicted.
|
||||
justTheConflictedNames :: Map Name (CombinedDiffOp a) -> [Name]
|
||||
justTheConflictedNames =
|
||||
Map.foldlWithKey' f []
|
||||
where
|
||||
f :: [Name] -> Name -> CombinedDiffOp term -> [Name]
|
||||
f names name = \case
|
||||
CombinedDiffOp'Conflict _ -> name : names
|
||||
CombinedDiffOp'Add _ _ -> names
|
||||
CombinedDiffOp'Delete _ _ -> names
|
||||
CombinedDiffOp'Update _ _ _ -> names
|
||||
|
||||
assertThereAreNoBuiltins ::
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Either Name (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId))
|
||||
assertThereAreNoBuiltins =
|
||||
traverse (bitraverse (Map.traverseWithKey assertTermIsntBuiltin) (Map.traverseWithKey assertTypeIsntBuiltin))
|
||||
where
|
||||
assertTermIsntBuiltin :: Name -> TermReference -> Either Name TermReferenceId
|
||||
assertTermIsntBuiltin name ref =
|
||||
case Reference.toId ref of
|
||||
Nothing -> Left name
|
||||
Just refId -> Right refId
|
||||
|
||||
-- Same body as above, but could be different some day (e.g. return value tells you what namespace)
|
||||
assertTypeIsntBuiltin :: Name -> TypeReference -> Either Name TypeReferenceId
|
||||
assertTypeIsntBuiltin name ref =
|
||||
case Reference.toId ref of
|
||||
Nothing -> Left name
|
||||
Just refId -> Right refId
|
||||
@ -4,6 +4,8 @@ module Unison.Merge.ThreeWay
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith))
|
||||
import Data.These (These (..))
|
||||
import Unison.Merge.TwoWay (TwoWay (..))
|
||||
import Unison.Prelude
|
||||
|
||||
@ -15,8 +17,31 @@ data ThreeWay a = ThreeWay
|
||||
deriving stock (Foldable, Functor, Generic, Traversable)
|
||||
|
||||
instance Applicative ThreeWay where
|
||||
pure x = ThreeWay x x x
|
||||
ThreeWay f g h <*> ThreeWay x y z = ThreeWay (f x) (g y) (h z)
|
||||
pure :: a -> ThreeWay a
|
||||
pure x =
|
||||
ThreeWay x x x
|
||||
|
||||
(<*>) :: ThreeWay (a -> b) -> ThreeWay a -> ThreeWay b
|
||||
ThreeWay f g h <*> ThreeWay x y z =
|
||||
ThreeWay (f x) (g y) (h z)
|
||||
|
||||
instance Semialign ThreeWay where
|
||||
alignWith :: (These a b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c
|
||||
alignWith f (ThreeWay a b c) (ThreeWay x y z) =
|
||||
ThreeWay (f (These a x)) (f (These b y)) (f (These c z))
|
||||
|
||||
instance Unzip ThreeWay where
|
||||
unzipWith :: (c -> (a, b)) -> ThreeWay c -> (ThreeWay a, ThreeWay b)
|
||||
unzipWith f (ThreeWay a b c) =
|
||||
let (i, x) = f a
|
||||
(j, y) = f b
|
||||
(k, z) = f c
|
||||
in (ThreeWay i j k, ThreeWay x y z)
|
||||
|
||||
instance Zip ThreeWay where
|
||||
zipWith :: (a -> b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c
|
||||
zipWith f (ThreeWay a b c) (ThreeWay x y z) =
|
||||
ThreeWay (f a x) (f b y) (f c z)
|
||||
|
||||
forgetLca :: ThreeWay a -> TwoWay a
|
||||
forgetLca ThreeWay {alice, bob} =
|
||||
|
||||
@ -26,7 +26,7 @@ data TwoWay a = TwoWay
|
||||
{ alice :: a,
|
||||
bob :: a
|
||||
}
|
||||
deriving stock (Foldable, Functor, Generic, Traversable)
|
||||
deriving stock (Foldable, Functor, Generic, Show, Traversable)
|
||||
deriving (Monoid, Semigroup) via (GenericSemigroupMonoid (TwoWay a))
|
||||
|
||||
instance Applicative TwoWay where
|
||||
|
||||
@ -27,6 +27,7 @@ library
|
||||
Unison.Merge.Diff
|
||||
Unison.Merge.DiffOp
|
||||
Unison.Merge.Libdeps
|
||||
Unison.Merge.PartitionCombinedDiffs
|
||||
Unison.Merge.PreconditionViolation
|
||||
Unison.Merge.Synhash
|
||||
Unison.Merge.Synhashed
|
||||
|
||||
@ -280,11 +280,10 @@ project/alice> merge2 /bob
|
||||
.> project.delete project
|
||||
```
|
||||
|
||||
## Term conflict with a constructor
|
||||
## Type update+rename conflict
|
||||
|
||||
In this example, Alice updates a type, while Bob "updates" one of the constructors (by changing it to a term), and adds
|
||||
back a name for the constructor somewhere else. Bob didn't actually update the type itself, but there is nonetheless
|
||||
a conflict between Alice's type (due to one of its constructors) and Bob's term.
|
||||
Renaming a constructor is modeled as an update, so if Alice updates a type and Bob renames one of its constructors but
|
||||
doesn't change its hash, that's still a conflict.
|
||||
|
||||
```ucm:hide
|
||||
.> project.create-empty project
|
||||
@ -292,9 +291,7 @@ project/main> builtins.mergeio
|
||||
```
|
||||
|
||||
```unison
|
||||
unique type Foo
|
||||
= MkFooOne Nat
|
||||
| MkFooTwo Nat Nat
|
||||
unique type Foo = Baz Nat | Qux Text
|
||||
```
|
||||
|
||||
```ucm
|
||||
@ -303,9 +300,7 @@ project/main> branch alice
|
||||
```
|
||||
|
||||
```unison
|
||||
unique type Foo
|
||||
= MkFooOne Nat Text
|
||||
| MkFooTwo Nat Nat
|
||||
unique type Foo = Baz Nat Nat | Qux Text
|
||||
```
|
||||
|
||||
```ucm
|
||||
@ -314,12 +309,7 @@ project/main> branch bob
|
||||
```
|
||||
|
||||
```unison
|
||||
unique type Foo
|
||||
= MkFooOne Nat
|
||||
| MkFooTwoRenamed Nat Nat
|
||||
|
||||
Foo.MkFooTwo : Text
|
||||
Foo.MkFooTwo = "hello"
|
||||
unique type Foo = Baz Nat | BobQux Text
|
||||
```
|
||||
|
||||
```ucm:error
|
||||
@ -331,7 +321,6 @@ project/alice> merge2 /bob
|
||||
.> project.delete project
|
||||
```
|
||||
|
||||
|
||||
## Precondition violations
|
||||
|
||||
Let's see a number of merge precondition violations. These are conditions under which we can't perform a merge, and the
|
||||
|
||||
@ -701,6 +701,110 @@ type Foo = MkFoo Nat Nat
|
||||
type Foo = MkFoo Nat Text
|
||||
```
|
||||
|
||||
## Type update+rename conflict
|
||||
|
||||
Renaming a constructor is modeled as an update, so if Alice updates a type and Bob renames one of its constructors but
|
||||
doesn't change its hash, that's still a conflict.
|
||||
|
||||
```unison
|
||||
unique type Foo = Baz Nat | Qux Text
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
type Foo
|
||||
|
||||
```
|
||||
```ucm
|
||||
project/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
type Foo
|
||||
|
||||
project/main> branch alice
|
||||
|
||||
Done. I've created the alice branch based off of main.
|
||||
|
||||
Tip: Use `merge /alice /main` to merge your work back into the
|
||||
main branch.
|
||||
|
||||
```
|
||||
```unison
|
||||
unique type Foo = Baz Nat Nat | Qux Text
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These names already exist. You can `update` them to your
|
||||
new definition:
|
||||
|
||||
type Foo
|
||||
|
||||
```
|
||||
```ucm
|
||||
project/alice> update
|
||||
|
||||
Okay, I'm searching the branch for code that needs to be
|
||||
updated...
|
||||
|
||||
Done.
|
||||
|
||||
project/main> branch bob
|
||||
|
||||
Done. I've created the bob branch based off of main.
|
||||
|
||||
Tip: Use `merge /bob /main` to merge your work back into the
|
||||
main branch.
|
||||
|
||||
```
|
||||
```unison
|
||||
unique type Foo = Baz Nat | BobQux Text
|
||||
```
|
||||
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked the definitions in scratch.u. This
|
||||
file has been previously added to the codebase.
|
||||
|
||||
```
|
||||
```ucm
|
||||
project/bob> update
|
||||
|
||||
Okay, I'm searching the branch for code that needs to be
|
||||
updated...
|
||||
|
||||
Done.
|
||||
|
||||
project/alice> merge2 /bob
|
||||
|
||||
I couldn't automatically merge bob into alice. However, I've
|
||||
added the definitions that need attention to the top of
|
||||
scratch.u.
|
||||
|
||||
```
|
||||
```unison:added-by-ucm scratch.u
|
||||
type Foo = Baz Nat Nat | Qux Text
|
||||
|
||||
type Foo = Baz Nat | BobQux Text
|
||||
```
|
||||
|
||||
## Term conflict with a constructor
|
||||
|
||||
In this example, Alice updates a type, while Bob "updates" one of the constructors (by changing it to a term), and adds
|
||||
|
||||
Loading…
Reference in New Issue
Block a user