mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 05:37:14 +03:00
continue attempting to properly partition diff into conflicted and unconflicted
This commit is contained in:
Mitchell Rosen
parent
75ae8120af
commit
da3e716e49
@ -3,6 +3,9 @@
|
||||
module Unison.Util.Defns
|
||||
( Defns (..),
|
||||
DefnsF,
|
||||
DefnsF2,
|
||||
DefnsF3,
|
||||
DefnsF4,
|
||||
alignDefnsWith,
|
||||
defnsAreEmpty,
|
||||
mapDefns,
|
||||
@ -44,6 +47,15 @@ instance Bitraversable Defns where
|
||||
type DefnsF f terms types =
|
||||
Defns (f terms) (f types)
|
||||
|
||||
type DefnsF2 f g terms types =
|
||||
Defns (f (g terms)) (f (g types))
|
||||
|
||||
type DefnsF3 f g h terms types =
|
||||
Defns (f (g (h terms))) (f (g (h types)))
|
||||
|
||||
type DefnsF4 f g h i terms types =
|
||||
Defns (f (g (h (i terms)))) (f (g (h (i types))))
|
||||
|
||||
alignDefnsWith :: Semialign f => (These a b -> c) -> Defns (f a) (f b) -> f c
|
||||
alignDefnsWith f defns =
|
||||
alignWith f defns.terms defns.types
|
||||
|
||||
@ -92,7 +92,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, alignDefnsWith, zipDefnsWith)
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, zipDefnsWith)
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree)
|
||||
import Unison.Util.Pretty (ColorText, Pretty)
|
||||
@ -451,7 +451,7 @@ bumpLca declNameLookups conflicts unconflicts dependents lca =
|
||||
-- Apply the updates to the LCA
|
||||
& runNamespaceUpdate (defnsRangeOnly lca)
|
||||
where
|
||||
deleteTheConflicts :: DefnsF NamespaceUpdate (Map Name Referent) (Map Name TypeReference)
|
||||
deleteTheConflicts :: DefnsF2 NamespaceUpdate (Map Name) Referent TypeReference
|
||||
deleteTheConflicts =
|
||||
bimap shedConflicted shedConflicted conflictedNames
|
||||
where
|
||||
@ -460,7 +460,7 @@ bumpLca declNameLookups conflicts unconflicts dependents lca =
|
||||
fold (conflictsToConflictedNames <$> declNameLookups <*> conflicts)
|
||||
|
||||
-- Compute the adds to apply to the LCA
|
||||
applyTheAdds :: DefnsF NamespaceUpdate (Map Name Referent) (Map Name TypeReference)
|
||||
applyTheAdds :: DefnsF2 NamespaceUpdate (Map Name) Referent TypeReference
|
||||
applyTheAdds =
|
||||
Defns
|
||||
{ terms =
|
||||
@ -484,7 +484,7 @@ bumpLca declNameLookups conflicts unconflicts dependents lca =
|
||||
}
|
||||
|
||||
-- Compute the deletes to apply to the LCA
|
||||
applyTheDeletes :: DefnsF NamespaceUpdate (Map Name Referent) (Map Name TypeReference)
|
||||
applyTheDeletes :: DefnsF2 NamespaceUpdate (Map Name) Referent TypeReference
|
||||
applyTheDeletes =
|
||||
bimap deletes1 deletes1 unconflicts
|
||||
where
|
||||
@ -545,7 +545,7 @@ defnsAndLibdepsToBranch0 ::
|
||||
Branch0 IO
|
||||
defnsAndLibdepsToBranch0 codebase defns libdeps =
|
||||
let -- Unflatten the collection of terms into tree, ditto for types
|
||||
nametrees :: DefnsF Nametree (Map NameSegment Referent) (Map NameSegment TypeReference)
|
||||
nametrees :: DefnsF2 Nametree (Map NameSegment) Referent TypeReference
|
||||
nametrees =
|
||||
bimap go go defns
|
||||
|
||||
@ -887,7 +887,7 @@ loadNamespaceInfo0 ::
|
||||
(Monad m) =>
|
||||
(V2.Referent -> m Referent) ->
|
||||
V2.Branch m ->
|
||||
m (Nametree (DefnsF (Map NameSegment) (Set Referent) (Set TypeReference)))
|
||||
m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference))
|
||||
loadNamespaceInfo0 referent2to1 branch = do
|
||||
terms <-
|
||||
branch.terms
|
||||
@ -904,7 +904,7 @@ loadNamespaceInfo0_ ::
|
||||
(Monad m) =>
|
||||
(V2.Referent -> m Referent) ->
|
||||
V2.Branch m ->
|
||||
m (Nametree (DefnsF (Map NameSegment) (Set Referent) (Set TypeReference)))
|
||||
m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference))
|
||||
loadNamespaceInfo0_ referent2to1 branch = do
|
||||
terms <-
|
||||
branch.terms
|
||||
@ -919,7 +919,7 @@ loadNamespaceInfo0_ referent2to1 branch = do
|
||||
|
||||
-- | Assert that there are no unconflicted names in a namespace.
|
||||
assertNamespaceHasNoConflictedNames ::
|
||||
Nametree (DefnsF (Map NameSegment) (Set Referent) (Set TypeReference)) ->
|
||||
Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference) ->
|
||||
Either Merge.PreconditionViolation (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
|
||||
assertNamespaceHasNoConflictedNames =
|
||||
traverseNametreeWithName \names defns -> do
|
||||
@ -989,7 +989,7 @@ assertNamespaceSatisfiesPreconditions db abort maybeBranchName branch defns = do
|
||||
findOneConflictedAlias ::
|
||||
TwoWay ProjectBranch ->
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
TwoWay (DefnsF (Map Name) (DiffOp (Synhashed Referent)) (DiffOp (Synhashed TypeReference))) ->
|
||||
TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) ->
|
||||
Maybe Merge.PreconditionViolation
|
||||
findOneConflictedAlias projectBranchNames lcaDefns diffs =
|
||||
aliceConflictedAliases <|> bobConflictedAliases
|
||||
@ -1021,7 +1021,7 @@ findOneConflictedAlias projectBranchNames lcaDefns diffs =
|
||||
-- This function currently doesn't return whether the conflicted alias is a decl or a term, but it certainly could.
|
||||
findConflictedAlias ::
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
DefnsF (Map Name) (DiffOp (Synhashed Referent)) (DiffOp (Synhashed TypeReference)) ->
|
||||
DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference ->
|
||||
Maybe (Name, Name)
|
||||
findConflictedAlias defns diff =
|
||||
asum [go defns.terms diff.terms, go defns.types diff.types]
|
||||
@ -1132,7 +1132,7 @@ debugDefns declNameLookups defns =
|
||||
|
||||
debugDiffs ::
|
||||
MonadIO m =>
|
||||
TwoWay (DefnsF (Map Name) (DiffOp (Synhashed Referent)) (DiffOp (Synhashed TypeReference))) ->
|
||||
TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) ->
|
||||
m ()
|
||||
debugDiffs diffs =
|
||||
Debug.whenDebug Debug.Merge do
|
||||
|
||||
@ -6,18 +6,16 @@ module Unison.Merge.CombineDiffs
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Lens', over, view, (%~), (.~), _1, _2)
|
||||
import Control.Lens (Lens', over, view, (%~), (.~))
|
||||
import Data.Bifoldable (binull)
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Semialign (alignWith)
|
||||
import Data.These (These (..))
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
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.DeclNameLookup (DeclNameLookup (..), expectConstructorNames, expectDeclName)
|
||||
import Unison.Merge.DiffOp (DiffOp (..))
|
||||
import Unison.Merge.Synhashed (Synhashed (..))
|
||||
import Unison.Merge.TwoDiffOps (TwoDiffOps (..), combineTwoDiffOps)
|
||||
@ -26,158 +24,60 @@ 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 (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as 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)
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, DefnsF4)
|
||||
|
||||
-- | The combined result of two diffs on the same thing.
|
||||
data DiffOp2 v
|
||||
= Added2 !AliceIorBob !v
|
||||
| Updated2 !AliceIorBob !v -- new value
|
||||
| Deleted2 !AliceIorBob !v -- old value
|
||||
| -- | An add-add or an update-update conflict. We don't consider update-delete a conflict; the delete gets ignored.
|
||||
Conflict !(TwoWay v)
|
||||
|
||||
data Flicts v = Flicts
|
||||
{ conflicts :: !(Map Name (TwoWay v)),
|
||||
unconflicts :: !(Unconflicts v)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
data CombinedDiffOps ref
|
||||
= CombinedDiffOps'Add !AliceIorBob !ref
|
||||
| CombinedDiffOps'Delete !AliceIorBob !ref -- old value
|
||||
| CombinedDiffOps'Update !AliceIorBob !ref !ref -- 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)
|
||||
|
||||
-- | Combine LCA->Alice diff and LCA->Bob diff, then partition into conflicted and unconflicted things.
|
||||
combineDiffs ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
TwoWay (DefnsF (Map Name) (DiffOp (Synhashed Referent)) (DiffOp (Synhashed TypeReference))) ->
|
||||
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 honk =
|
||||
oingoBoingo
|
||||
declNameLookups
|
||||
defns
|
||||
( bimap
|
||||
(twoWay (alignWith combine'terms))
|
||||
(twoWay (Map.alignWithKey (combine'types declNameLookups)))
|
||||
(TwoWay.sequenceDefns diffs)
|
||||
)
|
||||
let diffs1 :: DefnsF4 TwoWay (Map Name) DiffOp Synhashed Referent TypeReference
|
||||
diffs1 =
|
||||
TwoWay.sequenceDefns diffs
|
||||
|
||||
let (termConflicts0, termUnconflicts0) = partition2 (TwoWay.justTheTerms diffs)
|
||||
(typeConflicts0, typeUnconflicts0) = partition2 (TwoWay.justTheTypes diffs)
|
||||
let diffs2 :: DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference
|
||||
diffs2 =
|
||||
let f = twoWay (alignWith combine)
|
||||
in bimap f f diffs1
|
||||
|
||||
let initialConflicts :: TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
initialConflicts =
|
||||
twiddleTermConflicts declNameLookups termConflicts0 <> justTypes (sequenceA typeConflicts0)
|
||||
let conflicts0 = identifyConflicts declNameLookups defns diffs2
|
||||
|
||||
let moreTermConflicts :: TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
moreTermConflicts =
|
||||
justTerms (discoverTermConflicts declNameLookups (view #terms <$> defns) (TwoWay.justTheTypes initialConflicts))
|
||||
let unconflicts = identifyUnconflicts declNameLookups conflicts0 diffs2
|
||||
|
||||
conflicts <- assertThereAreNoBuiltins (initialConflicts <> moreTermConflicts)
|
||||
conflicts <- assertThereAreNoBuiltins conflicts0
|
||||
|
||||
let termUnconflicts = dropConflictedUnconflictedTerms declNameLookups conflicts termUnconflicts0
|
||||
let typeUnconflicts = dropConflictedUnconflictedTypes (TwoWay.justTheTypes conflicts) typeUnconflicts0
|
||||
Right (conflicts, unconflicts)
|
||||
|
||||
Right (conflicts, Defns termUnconflicts typeUnconflicts)
|
||||
|
||||
oingoBoingo ::
|
||||
identifyConflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
Defns (Map Name (DiffOp2 Referent)) (Map Name (DiffOp2 TypeReference)) ->
|
||||
DefnsF2 (Map Name) CombinedDiffOps Referent TypeReference ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
oingoBoingo declNameLookups defns diff =
|
||||
let initialQueues :: TwoWay (DefnsF [] Name Name)
|
||||
initialQueues =
|
||||
bitraverse honkTerms honkTypes diff
|
||||
|
||||
-- added term: we keep the add
|
||||
--
|
||||
-- added constructor:
|
||||
-- - if its type is me-conflicted then we drop the add
|
||||
-- - else if its type is them-conflicted then we promote our type to me-conflicted
|
||||
-- - example:
|
||||
-- LCA: type Foo = Foo | Bar
|
||||
-- Alice: type Foo = Foo | Bar | Baz
|
||||
-- Bob: type Foo = Foo | Oink
|
||||
--
|
||||
-- Alice diff:
|
||||
-- updated type Foo
|
||||
-- updated con Foo.Bar
|
||||
-- updated con Foo.Baz
|
||||
--
|
||||
-- Bob diff:
|
||||
-- deleted con Foo.Bar
|
||||
-- added con Foo.Oink
|
||||
--
|
||||
-- in this example, "Foo.Oink" is added in Bob, "Foo" is not conflicted in Bob, but
|
||||
--
|
||||
--
|
||||
-- after finding an initial batch of type conflicts,
|
||||
--
|
||||
-- 1. some constructor adds/updates will be for types that are conflicted. we can drop these!
|
||||
-- 2. others will be for types that are updates, but aren't conflicted. we keep these!
|
||||
-- 3. others will be for types that haven't been updated, but we only keep these if the other person's type isn't
|
||||
-- conflicted or updated; if it is, then our changes to the type's constructor essentially promote the type to
|
||||
-- conflicted! uh oh! this can cascade... so what order do we do these checks in?
|
||||
|
||||
honkTerms :: Map Name (DiffOp2 term) -> TwoWay [Name]
|
||||
honkTerms =
|
||||
Map.foldlWithKey' f (TwoWay [] [])
|
||||
where
|
||||
f :: TwoWay [Name] -> Name -> DiffOp2 term -> TwoWay [Name]
|
||||
f acc name = \case
|
||||
Conflict _ -> (name :) <$> acc
|
||||
-- FIXME are these right? just dealing with conflicts for now, then will circle back and think
|
||||
Added2 _ _ -> acc
|
||||
Deleted2 _ _ -> acc
|
||||
Updated2 _ _ -> acc
|
||||
|
||||
-- FIXME same as honkTerms, forever tho?
|
||||
honkTypes :: Map Name (DiffOp2 typ) -> TwoWay [Name]
|
||||
honkTypes =
|
||||
Map.foldlWithKey' f (TwoWay [] [])
|
||||
where
|
||||
f :: TwoWay [Name] -> Name -> DiffOp2 typ -> TwoWay [Name]
|
||||
f acc name = \case
|
||||
Conflict _ -> (name :) <$> acc
|
||||
-- FIXME are these right? just dealing with conflicts for now, then will circle back and think
|
||||
Added2 _ _ -> acc
|
||||
Deleted2 _ _ -> acc
|
||||
Updated2 _ _ -> acc
|
||||
in boingo2
|
||||
declNameLookups
|
||||
defns
|
||||
S
|
||||
{ me = Alice,
|
||||
conflicts = mempty,
|
||||
stacks = initialQueues
|
||||
}
|
||||
|
||||
data S = S
|
||||
{ me :: !AliceXorBob,
|
||||
conflicts :: !(TwoWay (DefnsF (Map Name) TermReference TypeReference)),
|
||||
stacks :: !(TwoWay (DefnsF [] Name Name))
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
boingo2 ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
S ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
boingo2 declNameLookups defns =
|
||||
loop
|
||||
identifyConflicts declNameLookups defns =
|
||||
\diff -> loop (makeInitialIdentifyConflictsState diff)
|
||||
where
|
||||
loop :: S -> TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
loop s =
|
||||
@ -187,12 +87,14 @@ boingo2 declNameLookups defns =
|
||||
([], [], 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 :)
|
||||
|
||||
poppedType :: Name -> S -> S
|
||||
poppedType name =
|
||||
case BiMultimap.lookupRan name (view (me_ . #types) defns) of
|
||||
Nothing -> id
|
||||
@ -235,214 +137,153 @@ boingo2 declNameLookups defns =
|
||||
theirTermStack_ :: Lens' S [Name]
|
||||
theirTermStack_ = theirStacks_ . #terms
|
||||
|
||||
partition2 :: TwoWay (Map Name (DiffOp (Synhashed v))) -> (Map Name (TwoWay v), Unconflicts v)
|
||||
partition2 =
|
||||
partition . twoWay (alignWith (combine Alice Bob))
|
||||
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))
|
||||
|
||||
partition :: Map Name (DiffOp2 v) -> (Map Name (TwoWay v), Unconflicts v)
|
||||
partition =
|
||||
Map.foldlWithKey'
|
||||
(\s k v -> insert k v s)
|
||||
( Map.empty,
|
||||
let empty = TwoWayI Map.empty Map.empty Map.empty
|
||||
in Unconflicts empty empty empty
|
||||
)
|
||||
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
|
||||
insert :: Name -> DiffOp2 v -> (Map Name (TwoWay v), Unconflicts v) -> (Map Name (TwoWay v), Unconflicts v)
|
||||
insert k = \case
|
||||
Conflict v -> _1 %~ Map.insert k v
|
||||
Added2 who v -> _2 . #adds . TwoWayI.who_ who %~ Map.insert k v
|
||||
Deleted2 who v -> _2 . #deletes . TwoWayI.who_ who %~ Map.insert k v
|
||||
Updated2 who v -> _2 . #updates . TwoWayI.who_ who %~ Map.insert k v
|
||||
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
|
||||
|
||||
combine :: AliceXorBob -> AliceXorBob -> These (DiffOp (Synhashed v)) (DiffOp (Synhashed v)) -> DiffOp2 v
|
||||
combine this that = \case
|
||||
This x -> one this x
|
||||
That x -> one that x
|
||||
These (DiffOp'Add x) (DiffOp'Add y)
|
||||
| x /= y -> Conflict (two this x.value y.value)
|
||||
| otherwise -> Added2 AliceAndBob x.value
|
||||
These (DiffOp'Update _ x) (DiffOp'Update _ y)
|
||||
| x /= y -> Conflict (two this x.value y.value)
|
||||
| otherwise -> Updated2 AliceAndBob x.value
|
||||
-- Not a conflict, perhaps only temporarily, because it's easier to implement (we ignore these deletes):
|
||||
These (DiffOp'Update _ x) (DiffOp'Delete _) -> Updated2 (xor2ior this) x.value
|
||||
These (DiffOp'Delete x) (DiffOp'Delete _) -> Deleted2 AliceAndBob x.value
|
||||
-- Handle delete+update the same as update+delete
|
||||
These x@(DiffOp'Delete _) y -> combine that this (These y x)
|
||||
-- These don't make sense - e.g. someone can't update something that wasn't there
|
||||
These (DiffOp'Update _ _) (DiffOp'Add _) -> error "impossible"
|
||||
These (DiffOp'Add _) (DiffOp'Delete _) -> error "impossible"
|
||||
These (DiffOp'Add _) (DiffOp'Update _ _) -> error "impossible"
|
||||
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
|
||||
one :: AliceXorBob -> DiffOp (Synhashed v) -> DiffOp2 v
|
||||
one who = \case
|
||||
DiffOp'Add x -> Added2 (xor2ior who) x.value
|
||||
DiffOp'Delete x -> Deleted2 (xor2ior who) x.value
|
||||
DiffOp'Update _ x -> Updated2 (xor2ior who) x.value
|
||||
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
|
||||
|
||||
-- Make a two way, given who is on the left.
|
||||
two :: AliceXorBob -> v -> v -> TwoWay v
|
||||
two Alice alice bob = TwoWay {alice, bob}
|
||||
two Bob bob alice = TwoWay {alice, bob}
|
||||
typeIsConflicted :: TwoWay Bool
|
||||
typeIsConflicted =
|
||||
Map.member name <$> conflicts
|
||||
|
||||
combine'terms :: These (DiffOp (Synhashed term)) (DiffOp (Synhashed term)) -> DiffOp2 term
|
||||
combine'terms =
|
||||
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 =
|
||||
combineTwoDiffOps >>> \case
|
||||
TwoDiffOps'Add who x -> Added2 (xor2ior who) x.value
|
||||
TwoDiffOps'Delete who x -> Deleted2 (xor2ior who) x.value
|
||||
TwoDiffOps'Update who _old new -> Updated2 (xor2ior who) new.value
|
||||
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'AddAdd TwoWay {alice, bob}
|
||||
| alice /= bob -> Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> Added2 AliceAndBob alice.value
|
||||
TwoDiffOps'DeleteDelete x -> Deleted2 AliceAndBob x.value
|
||||
| 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
|
||||
-- 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 -> Updated2 OnlyBob new.value
|
||||
TwoDiffOps'UpdateDelete _old new -> Updated2 OnlyAlice new.value
|
||||
TwoDiffOps'UpdateUpdate _old TwoWay {alice, bob}
|
||||
| alice /= bob -> Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> Updated2 AliceAndBob alice.value
|
||||
|
||||
combine'types ::
|
||||
TwoWay DeclNameLookup ->
|
||||
Name ->
|
||||
These (DiffOp (Synhashed typ)) (DiffOp (Synhashed typ)) ->
|
||||
DiffOp2 typ
|
||||
combine'types declNameLookups name =
|
||||
combineTwoDiffOps >>> \case
|
||||
TwoDiffOps'Add who x -> Added2 (xor2ior who) x.value
|
||||
TwoDiffOps'Delete who x -> Deleted2 (xor2ior who) x.value
|
||||
-- Treat one person updating a type and the other just moving constructors around as a conflict
|
||||
TwoDiffOps'Update who old new
|
||||
| differentNamesForConstructors ->
|
||||
TwoWay {alice = new.value, bob = old.value}
|
||||
& (case who of Alice -> id; Bob -> TwoWay.swap)
|
||||
& Conflict
|
||||
| otherwise -> Updated2 (xor2ior who) new.value
|
||||
TwoDiffOps'AddAdd TwoWay {alice, bob}
|
||||
| conflicting alice bob -> Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> Added2 AliceAndBob alice.value
|
||||
TwoDiffOps'DeleteDelete x -> Deleted2 AliceAndBob x.value
|
||||
TwoDiffOps'DeleteUpdate _old new -> Updated2 OnlyBob new.value
|
||||
TwoDiffOps'UpdateDelete _old new -> Updated2 OnlyAlice new.value
|
||||
TwoDiffOps'UpdateUpdate _old TwoWay {alice, bob}
|
||||
| conflicting alice bob -> Conflict TwoWay {alice = alice.value, bob = bob.value}
|
||||
| otherwise -> Updated2 AliceAndBob alice.value
|
||||
where
|
||||
-- We consider type decls in conflict if they are different (obviously) *or* if they don't have the exact same names
|
||||
-- for all of the constructors.
|
||||
--
|
||||
-- This is, in a sense, a conservative definition of "conflicted" - surely Alice ought to be able to rename one
|
||||
-- constructor, and Bob another.
|
||||
--
|
||||
-- However, it simplifies two cases, and possibly more, to just throw this kind of thing back to the user to
|
||||
-- resolve:
|
||||
--
|
||||
-- 1. Alice and Bob each rename the same constructor to two different things, resulting in a decl that violates
|
||||
-- the condition that each constructor has one name.
|
||||
--
|
||||
-- 2. Alice updates a type decl while Bob merely renames one of its constructors.
|
||||
conflicting :: Synhashed typ -> Synhashed typ -> Bool
|
||||
conflicting alice bob =
|
||||
alice /= bob || differentNamesForConstructors
|
||||
|
||||
differentNamesForConstructors :: Bool
|
||||
differentNamesForConstructors =
|
||||
expectConstructorNames declNameLookups.alice name /= expectConstructorNames declNameLookups.bob name
|
||||
TwoDiffOps'DeleteUpdate old new -> CombinedDiffOps'Update OnlyBob old.value new.value
|
||||
TwoDiffOps'UpdateDelete old new -> CombinedDiffOps'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
|
||||
|
||||
xor2ior :: AliceXorBob -> AliceIorBob
|
||||
xor2ior = \case
|
||||
Alice -> OnlyAlice
|
||||
Bob -> OnlyBob
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Conflict twiddling
|
||||
|
||||
-- returned maps don't necessarily have the same keys, e.g. if incoming conflict is
|
||||
--
|
||||
-- {
|
||||
-- terms = {
|
||||
-- "Maybe.Just" => {
|
||||
-- alice = #Alice#0,
|
||||
-- bob = #bob
|
||||
-- }
|
||||
-- }
|
||||
-- }
|
||||
--
|
||||
-- (where Alice has a constructor and Bob has a term), then the outgoing maps will be
|
||||
--
|
||||
-- {
|
||||
-- alice = {
|
||||
-- types = {
|
||||
-- "Maybe" => #Alice
|
||||
-- }
|
||||
-- },
|
||||
-- bob = {
|
||||
-- terms = {
|
||||
-- "Maybe.Just" => #bob
|
||||
-- }
|
||||
-- }
|
||||
-- }
|
||||
|
||||
twiddleTermConflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
Map Name (TwoWay Referent) ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
twiddleTermConflicts declNameLookups =
|
||||
Map.foldlWithKey' f (let empty = Defns Map.empty Map.empty in TwoWay empty empty)
|
||||
where
|
||||
f ::
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Name ->
|
||||
TwoWay Referent ->
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference)
|
||||
f acc name referents =
|
||||
twiddleTermConflict name <$> declNameLookups <*> referents <*> acc
|
||||
|
||||
twiddleTermConflict ::
|
||||
Name ->
|
||||
DeclNameLookup ->
|
||||
Referent ->
|
||||
DefnsF (Map Name) TermReference TypeReference ->
|
||||
DefnsF (Map Name) TermReference TypeReference
|
||||
twiddleTermConflict name declNameLookup = \case
|
||||
Referent'.Con' (ConstructorReference ref _) _ -> over #types (Map.insert (expectDeclName declNameLookup name) ref)
|
||||
Referent'.Ref' ref -> over #terms (Map.insert name ref)
|
||||
|
||||
discoverTermConflicts ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (BiMultimap Referent Name) ->
|
||||
TwoWay (Map Name TypeReference) ->
|
||||
TwoWay (Map Name TermReference)
|
||||
discoverTermConflicts declNameLookups terms typeConflicts =
|
||||
TwoWay.swap (f <$> declNameLookups <*> typeConflicts <*> TwoWay.swap terms)
|
||||
where
|
||||
f ::
|
||||
DeclNameLookup ->
|
||||
Map Name TypeReference ->
|
||||
BiMultimap Referent Name ->
|
||||
Map Name TermReference
|
||||
f myDeclNameLookup myTypeConflicts theirTerms =
|
||||
Map.foldlWithKey' (g myDeclNameLookup theirTerms) Map.empty myTypeConflicts
|
||||
|
||||
g ::
|
||||
DeclNameLookup ->
|
||||
BiMultimap Referent Name ->
|
||||
Map Name TermReference ->
|
||||
Name ->
|
||||
TypeReference ->
|
||||
Map Name TermReference
|
||||
g myDeclNameLookup theirTerms acc myDeclName _ =
|
||||
List.foldl' (h theirTerms) acc (expectConstructorNames myDeclNameLookup myDeclName)
|
||||
|
||||
h :: BiMultimap Referent Name -> Map Name TermReference -> Name -> Map Name TermReference
|
||||
h theirTerms acc myConName =
|
||||
fromMaybe acc do
|
||||
theirReferent <- BiMultimap.lookupRan myConName theirTerms
|
||||
theirTerm <- Referent.toTermReference theirReferent
|
||||
Just (Map.insert myConName theirTerm acc)
|
||||
|
||||
assertThereAreNoBuiltins ::
|
||||
TwoWay (DefnsF (Map Name) TermReference TypeReference) ->
|
||||
Either Name (TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId))
|
||||
@ -461,55 +302,3 @@ assertThereAreNoBuiltins =
|
||||
case Reference.toId ref of
|
||||
Nothing -> Left name
|
||||
Just refId -> Right refId
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Unconflict twiddling
|
||||
|
||||
dropConflictedUnconflictedTerms ::
|
||||
TwoWay DeclNameLookup ->
|
||||
TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) ->
|
||||
Unconflicts Referent ->
|
||||
Unconflicts Referent
|
||||
dropConflictedUnconflictedTerms declNameLookups conflicts =
|
||||
over #adds f . over #updates f
|
||||
where
|
||||
f :: TwoWayI (Map Name Referent) -> TwoWayI (Map Name Referent)
|
||||
f =
|
||||
over #alice (Map.filterWithKey aliceIsConflicted)
|
||||
. over #bob (Map.filterWithKey bobIsConflicted)
|
||||
. over #both (Map.filterWithKey \name ref -> aliceIsConflicted name ref || bobIsConflicted name ref)
|
||||
where
|
||||
isConflicted :: DeclNameLookup -> DefnsF (Map Name) TermReferenceId TypeReferenceId -> Name -> Referent -> Bool
|
||||
isConflicted declNameLookup conflicts name = \case
|
||||
Referent'.Con' _ _ -> Map.notMember (expectDeclName declNameLookup name) conflicts.types
|
||||
Referent'.Ref' _ -> Map.notMember name conflicts.terms
|
||||
|
||||
aliceIsConflicted = isConflicted declNameLookups.alice conflicts.alice
|
||||
bobIsConflicted = isConflicted declNameLookups.bob conflicts.bob
|
||||
|
||||
dropConflictedUnconflictedTypes ::
|
||||
TwoWay (Map Name types) ->
|
||||
Unconflicts TypeReference ->
|
||||
Unconflicts TypeReference
|
||||
dropConflictedUnconflictedTypes conflicts =
|
||||
over #adds f . over #updates f
|
||||
where
|
||||
f :: TwoWayI (Map Name Reference) -> TwoWayI (Map Name Reference)
|
||||
f =
|
||||
over #alice dropAliceConflicted
|
||||
. over #bob dropBobConflicted
|
||||
. over #both (dropAliceConflicted . dropBobConflicted)
|
||||
where
|
||||
dropAliceConflicted = (`Map.difference` conflicts.alice)
|
||||
dropBobConflicted = (`Map.difference` conflicts.bob)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Misc. helpers
|
||||
|
||||
justTerms :: TwoWay (Map name terms) -> TwoWay (DefnsF (Map name) terms types)
|
||||
justTerms =
|
||||
fmap (\terms -> Defns terms Map.empty)
|
||||
|
||||
justTypes :: TwoWay (Map name types) -> TwoWay (DefnsF (Map name) terms types)
|
||||
justTypes =
|
||||
fmap (\types -> Defns Map.empty types)
|
||||
|
||||
@ -34,7 +34,7 @@ import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Type (Type)
|
||||
import Unison.Util.BiMultimap (BiMultimap)
|
||||
import Unison.Util.BiMultimap qualified as BiMultimap
|
||||
import Unison.Util.Defns (Defns (..), DefnsF)
|
||||
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:
|
||||
@ -51,14 +51,7 @@ nameBasedNamespaceDiff ::
|
||||
MergeDatabase ->
|
||||
ThreeWay DeclNameLookup ->
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
Transaction
|
||||
( TwoWay
|
||||
( DefnsF
|
||||
(Map Name)
|
||||
(DiffOp (Synhashed Referent))
|
||||
(DiffOp (Synhashed TypeReference))
|
||||
)
|
||||
)
|
||||
Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference))
|
||||
nameBasedNamespaceDiff db declNameLookups defns = do
|
||||
diffs <- sequence (synhashDefns <$> declNameLookups <*> defns)
|
||||
pure (diffNamespaceDefns diffs.lca <$> TwoWay {alice = diffs.alice, bob = diffs.bob})
|
||||
@ -66,7 +59,7 @@ nameBasedNamespaceDiff db declNameLookups defns = do
|
||||
synhashDefns ::
|
||||
DeclNameLookup ->
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
Transaction (DefnsF (Map Name) (Synhashed Referent) (Synhashed TypeReference))
|
||||
Transaction (DefnsF2 (Map Name) Synhashed Referent TypeReference)
|
||||
synhashDefns declNameLookup =
|
||||
-- FIXME: use cache so we only synhash each thing once
|
||||
synhashDefnsWith
|
||||
@ -101,26 +94,23 @@ withAccurateConstructorNames load declNameLookup name ref = do
|
||||
(expectConstructorNames declNameLookup name)
|
||||
|
||||
diffNamespaceDefns ::
|
||||
DefnsF (Map Name) (Synhashed Referent) (Synhashed TypeReference) ->
|
||||
DefnsF (Map Name) (Synhashed Referent) (Synhashed TypeReference) ->
|
||||
DefnsF (Map Name) (DiffOp (Synhashed Referent)) (DiffOp (Synhashed TypeReference))
|
||||
diffNamespaceDefns oldDefns newDefns =
|
||||
Defns
|
||||
{ terms = go oldDefns.terms newDefns.terms,
|
||||
types = go oldDefns.types newDefns.types
|
||||
}
|
||||
DefnsF2 (Map Name) Synhashed term typ ->
|
||||
DefnsF2 (Map Name) Synhashed term typ ->
|
||||
DefnsF3 (Map Name) DiffOp Synhashed term typ
|
||||
diffNamespaceDefns =
|
||||
zipDefnsWith f f
|
||||
where
|
||||
go :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> Map Name (DiffOp (Synhashed ref))
|
||||
go old new =
|
||||
Map.mapMaybe id (alignWith f old new)
|
||||
where
|
||||
f :: Eq x => These x x -> Maybe (DiffOp x)
|
||||
f = \case
|
||||
This x -> Just (DiffOp'Delete x)
|
||||
That y -> Just (DiffOp'Add y)
|
||||
These x y
|
||||
| x == y -> Nothing
|
||||
| otherwise -> Just (DiffOp'Update x y)
|
||||
f :: Map Name (Synhashed ref) -> Map Name (Synhashed ref) -> Map Name (DiffOp (Synhashed ref))
|
||||
f old new =
|
||||
Map.mapMaybe id (alignWith g old new)
|
||||
|
||||
g :: Eq x => These x x -> Maybe (DiffOp x)
|
||||
g = \case
|
||||
This x -> Just (DiffOp'Delete x)
|
||||
That y -> Just (DiffOp'Add y)
|
||||
These x y
|
||||
| x == y -> Nothing
|
||||
| otherwise -> Just (DiffOp'Update x y)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Pretty-print env helpers
|
||||
@ -145,7 +135,7 @@ synhashDefnsWith ::
|
||||
(term -> m Hash) ->
|
||||
(Name -> typ -> m Hash) ->
|
||||
Defns (BiMultimap term Name) (BiMultimap typ Name) ->
|
||||
m (DefnsF (Map Name) (Synhashed term) (Synhashed typ))
|
||||
m (DefnsF2 (Map Name) Synhashed term typ)
|
||||
synhashDefnsWith hashTerm hashType = do
|
||||
bitraverse
|
||||
(traverse hashTerm1 . BiMultimap.range)
|
||||
|
||||
@ -1,7 +1,9 @@
|
||||
module Unison.Merge.TwoWay
|
||||
( TwoWay (..),
|
||||
bothWays,
|
||||
justTheTerms,
|
||||
justTheTypes,
|
||||
or,
|
||||
sequenceDefns,
|
||||
swap,
|
||||
twoWay,
|
||||
@ -17,8 +19,8 @@ import Data.These (These (These))
|
||||
import Data.Zip (Zip, unzipWith, zipWith)
|
||||
import Unison.Merge.AliceXorBob (AliceXorBob (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Defns (Defns (..))
|
||||
import Prelude hiding (zipWith)
|
||||
import Unison.Util.Defns (Defns (..), DefnsF)
|
||||
import Prelude hiding (or, zipWith)
|
||||
|
||||
data TwoWay a = TwoWay
|
||||
{ alice :: a,
|
||||
@ -41,6 +43,10 @@ instance Zip TwoWay where
|
||||
zipWith f (TwoWay x1 x2) (TwoWay y1 y2) =
|
||||
TwoWay (f x1 y1) (f x2 y2)
|
||||
|
||||
bothWays :: a -> TwoWay a
|
||||
bothWays x =
|
||||
TwoWay x x
|
||||
|
||||
justTheTerms :: TwoWay (Defns terms types) -> TwoWay terms
|
||||
justTheTerms =
|
||||
fmap (view #terms)
|
||||
@ -49,7 +55,11 @@ justTheTypes :: TwoWay (Defns terms types) -> TwoWay types
|
||||
justTheTypes =
|
||||
fmap (view #types)
|
||||
|
||||
sequenceDefns :: TwoWay (Defns terms types) -> Defns (TwoWay terms) (TwoWay types)
|
||||
or :: TwoWay Bool -> Bool
|
||||
or =
|
||||
twoWay (||)
|
||||
|
||||
sequenceDefns :: TwoWay (Defns terms types) -> DefnsF TwoWay terms types
|
||||
sequenceDefns defns =
|
||||
Defns (justTheTerms defns) (justTheTypes defns)
|
||||
|
||||
|
||||
@ -2,12 +2,14 @@
|
||||
|
||||
module Unison.Merge.Unconflicts
|
||||
( Unconflicts (..),
|
||||
empty,
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Merge.TwoWayI (TwoWayI)
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Unison.Merge.TwoWayI (TwoWayI (..))
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
import Unison.Prelude hiding (empty)
|
||||
|
||||
data Unconflicts v = Unconflicts
|
||||
{ adds :: !(TwoWayI (Map Name v)),
|
||||
@ -15,3 +17,9 @@ data Unconflicts v = Unconflicts
|
||||
updates :: !(TwoWayI (Map Name v))
|
||||
}
|
||||
deriving stock (Foldable, Functor, Generic)
|
||||
|
||||
empty :: Unconflicts v
|
||||
empty =
|
||||
Unconflicts x x x
|
||||
where
|
||||
x = TwoWayI Map.empty Map.empty Map.empty
|
||||
|
||||
Loading…
Reference in New Issue
Block a user