unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 02:25:39 +03:00
Code Issues Projects Releases Wiki Activity

tweak ppe to fix bug

Browse Source
This commit is contained in:
Mitchell Rosen 2024-04-23 12:47:28 -04:00
parent 149b5b4f86
commit 57011a9b62
5 changed files with 117 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs
View File

@ -43,7 +43,7 @@ import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
import Unison.Codebase.Editor.HandleInput.Update2
( getNamespaceDependentsOf2,
makeParsingEnv,
prettyParseTypecheck,
prettyParseTypecheck2,
typecheckedUnisonFileToBranchUpdates,
)
import Unison.Codebase.Editor.HandleInput.Update2 qualified as Update2
@ -99,7 +99,7 @@ import Unison.Syntax.Name qualified as Name
import Unison.UnisonFile (UnisonFile')
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, hoistDefnsF, zipDefnsWith, zipDefnsWith3)
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3)
import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree)
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
@ -163,54 +163,47 @@ handleMerge bobBranchName = do
-- Identify the unconflicted 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)
dependents <-
dependents0 <-
Cli.runTransaction do
identifyDependents (ThreeWay.forgetLca defns) conflicts unconflicts
liftIO (debugFunctions.debugDependents dependents)
liftIO (debugFunctions.debugDependents dependents0)
let dependents1 = whatsit dependents
let dependents = whatsit dependents0
let newDefns2 :: DefnsF (Map Name) Referent TypeReference
newDefns2 =
let f :: BiMultimap ref Name -> Unconflicts ref -> Set Name -> Map Name ref
f refs unconflicts names =
refs
& BiMultimap.range
& Unconflicts.apply unconflicts
& (`Map.withoutKeys` names)
let bumpedDefns :: DefnsF (Map Name) Referent TypeReference
bumpedDefns =
bumpDefns
(ThreeWay.forgetLca declNameLookups)
conflicts
unconflicts
dependents
(bimap BiMultimap.range BiMultimap.range defns.lca)
g :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> DefnsF Set Name Name
g defns =
fold (refIdsToNames <$> ThreeWay.forgetLca declNameLookups <*> defns)
in zipDefnsWith3 f f defns.lca unconflicts (g conflicts <> g dependents1)
liftIO (debugFunctions.debugMergedDefns newDefns2)
liftIO (debugFunctions.debugBumpedDefns bumpedDefns)
-- Create the Unison file, which may have conflicts, in which case we don't bother trying to parse and typecheck it.
unisonFile <-
Cli.runTransactionWithRollback \abort -> do
conflictsFile <- conflictsToUnisonFile abort codebase (ThreeWay.forgetLca declNameLookups) conflicts
dependentsFile <- dependentsToUnisonFile abort codebase (ThreeWay.forgetLca declNameLookups) dependents1
dependentsFile <- dependentsToUnisonFile abort codebase (ThreeWay.forgetLca declNameLookups) dependents
pure (conflictsFile <> dependentsFile)
-- Load and merge Alice's and Bob's libdeps
libdeps <-
mergedLibdeps <-
Cli.runTransaction do
libdeps <- loadLibdeps branches
libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps)
let newBranchIO = defnsAndLibdepsToBranch0 codebase newDefns2 libdeps
-- Put together a branch with the bump definitions and merged libdeps; this will be used to typecheck the merged
-- updates 'n' stuff against, and if that succeeds, we'll apply updates from the typechecked Unison file to it.
let bumpedBranch0 = defnsAndLibdepsToBranch0 codebase bumpedDefns mergedLibdeps
let bumpedNames = Branch.toNames bumpedBranch0
let mergedNames = Branch.toNames newBranchIO
let deletedNames = defnsRangeToNames (hoistDefnsF (fold . view #deletes) unconflicts)
-- FIXME this is wrong - doesn't include names for auto-propagated things!
let ppedNames = mergedNames <> deletedNames
let pped = PPED.makePPED (PPE.namer ppedNames) (PPE.suffixifyByName ppedNames)
currentPath <- Cli.getCurrentPath
let prettyUf =
let names = defnsToNames defns.alice <> defnsToNames defns.bob
ppe = PPED.makePPED (PPE.namer names) (PPE.suffixifyByName names)
in Pretty.prettyUnisonFile ppe unisonFile
maybeTypecheckedUnisonFile <-
let thisMergeHasConflicts =
@ -219,17 +212,18 @@ handleMerge bobBranchName = do
in if thisMergeHasConflicts
then pure Nothing
else do
parsingEnv <- makeParsingEnv currentPath mergedNames
prettyParseTypecheck unisonFile pped parsingEnv <&> eitherToMaybe
currentPath <- Cli.getCurrentPath
parsingEnv <- makeParsingEnv currentPath bumpedNames
prettyParseTypecheck2 prettyUf parsingEnv <&> eitherToMaybe
case maybeTypecheckedUnisonFile of
Nothing -> promptUser info (Pretty.prettyUnisonFile pped unisonFile) newBranchIO
Nothing -> theMergeFailed info prettyUf bumpedBranch0
Just tuf -> do
mergedBranchPlusTuf <-
Cli.runTransactionWithRollback \abort -> do
Codebase.addDefsToCodebase codebase tuf
updates <- typecheckedUnisonFileToBranchUpdates abort undefined tuf
pure (Branch.batchUpdates updates newBranchIO)
pure (Branch.batchUpdates updates bumpedBranch0)
Cli.stepAt
(textualDescriptionOfMerge info)
( Path.unabsolute info.paths.alice,
@ -419,18 +413,15 @@ whatsit xs =
-- terms = { "foo", "Maybe.Nothing", "Maybe.Just" }
-- types = { "Maybe" }
-- }
refIdsToNames ::
DeclNameLookup ->
DefnsF (Map Name) TermReferenceId TypeReferenceId ->
DefnsF Set Name Name
refIdsToNames :: DeclNameLookup -> DefnsF (Map Name) term typ -> DefnsF Set Name Name
refIdsToNames declNameLookup =
bifoldMap goTerms goTypes
where
goTerms :: Map Name terms -> DefnsF Set Name Name
goTerms :: Map Name term -> DefnsF Set Name Name
goTerms terms =
Defns {terms = Map.keysSet terms, types = Set.empty}
goTypes :: Map Name types -> DefnsF Set Name Name
goTypes :: Map Name typ -> DefnsF Set Name Name
goTypes types =
Defns
{ terms = foldMap (Set.fromList . expectConstructorNames declNameLookup) names,
@ -688,6 +679,24 @@ mergeUnconflictedDependents conflicts unconflictedSoloDeletedNames unconflictedS
-- Case 2b2 or 2b3, the choice doesn't matter
| otherwise = Just (AliceAndBob alice)
bumpDefns ::
TwoWay DeclNameLookup ->
TwoWay (DefnsF (Map Name) termid typeid) ->
DefnsF Unconflicts term typ ->
TwoWay (DefnsF (Map Name) termid typeid) ->
DefnsF (Map Name) term typ ->
DefnsF (Map Name) term typ
bumpDefns declNameLookups conflicts unconflicts dependents =
zipDefnsWith3 bumpDefnsV bumpDefnsV unconflicts (f conflicts <> f dependents)
where
f :: TwoWay (DefnsF (Map Name) term typ) -> DefnsF Set Name Name
f defns =
fold (refIdsToNames <$> declNameLookups <*> defns)
bumpDefnsV :: Unconflicts v -> Set Name -> Map Name v -> Map Name v
bumpDefnsV unconflicts namesToDelete =
(`Map.withoutKeys` namesToDelete) . Unconflicts.apply unconflicts
restrictDefnsToNames ::
DefnsF Set Name Name ->
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
@ -699,19 +708,15 @@ defnsReferences :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Na
defnsReferences =
bifoldMap (Set.map Referent.toReference . BiMultimap.dom) BiMultimap.dom
defnsRangeToNames :: DefnsF (Map Name) Referent TypeReference -> Names
defnsRangeToNames Defns {terms, types} =
defnsToNames :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> Names
defnsToNames defns =
Names.Names
{ terms = Relation.fromMap terms,
types = Relation.fromMap types
{ terms = Relation.fromMap (BiMultimap.range defns.terms),
types = Relation.fromMap (BiMultimap.range defns.types)
}
promptUser ::
MergeInfo ->
Pretty ColorText ->
Branch0 IO ->
Cli a
promptUser mergeInfo prettyUnisonFile newBranch = do
theMergeFailed :: MergeInfo -> Pretty ColorText -> Branch0 IO -> Cli ()
theMergeFailed mergeInfo prettyUnisonFile newBranch = do
Cli.Env {writeSource} <- ask
let currentProjectId = mergeInfo.project.projectId
let targetBranchName = mergeInfo.projectBranches.bob.name
@ -732,7 +737,11 @@ promptUser mergeInfo prettyUnisonFile newBranch = do
Nothing -> "scratch.u"
Just (file, _) -> file
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
Cli.returnEarly (Output.MergeFailure scratchFilePath (aliceProjectAndBranchName mergeInfo) (bobProjectAndBranchName mergeInfo))
Cli.respond $
Output.MergeFailure
scratchFilePath
(aliceProjectAndBranchName mergeInfo)
(bobProjectAndBranchName mergeInfo)
findTemporaryBranchName :: ProjectId -> ProjectBranchName -> ProjectBranchName -> Transaction ProjectBranchName
findTemporaryBranchName projectId other self = do
@ -762,7 +771,7 @@ loadNamespaceInfo abort db branch = do
-- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
-- in the "lib" namespace.
loadNamespaceInfo0 ::
(Monad m) =>
Monad m =>
(V2.Referent -> m Referent) ->
V2.Branch m ->
m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference))
@ -994,8 +1003,7 @@ data DebugFunctions = DebugFunctions
DefnsF Unconflicts Referent TypeReference ->
IO (),
debugDependents :: DefnsF2 (Map Name) EitherWayI TermReferenceId TypeReferenceId -> IO (),
debugMergedDefns :: DefnsF (Map Name) Referent TypeReference -> IO (),
debugMergedConstructorNames :: DeclNameLookup -> IO ()
debugBumpedDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
}
realDebugFunctions :: DebugFunctions
@ -1006,13 +1014,12 @@ realDebugFunctions =
debugCombinedDiff = realDebugCombinedDiff,
debugPartitionedDiff = realDebugPartitionedDiff,
debugDependents = realDebugDependents,
debugMergedDefns = realDebugMergedDefns,
debugMergedConstructorNames = realDebugMergedConstructorNames
debugBumpedDefns = realDebugBumpedDefns
}
fakeDebugFunctions :: DebugFunctions
fakeDebugFunctions =
DebugFunctions mempty mempty mempty mempty mempty mempty mempty
DebugFunctions mempty mempty mempty mempty mempty mempty
realDebugDefns ::
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
@ -1214,15 +1221,10 @@ realDebugDependents dependents = do
)
<> ")"
realDebugMergedDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
realDebugMergedDefns mergedDefns = do
Text.putStrLn (Text.bold "\n=== Merged definitions ===")
debugDefns1 mergedDefns
realDebugMergedConstructorNames :: DeclNameLookup -> IO ()
realDebugMergedConstructorNames mergedDeclNameLookup = do
Text.putStrLn (Text.bold "\n=== Merged constructor names ===")
debugConstructorNames mergedDeclNameLookup.declToConstructors
realDebugBumpedDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
realDebugBumpedDefns defns = do
Text.putStrLn (Text.bold "\n=== Bumped definitions ===")
debugDefns1 defns
debugConstructorNames :: Map Name [Name] -> IO ()
debugConstructorNames names =

18
unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs
View File

@ -11,6 +11,7 @@ module Unison.Codebase.Editor.HandleInput.Update2
forwardCtorNames,
makeParsingEnv,
prettyParseTypecheck,
prettyParseTypecheck2,
typecheckedUnisonFileToBranchUpdates,
getNamespaceDependentsOf,
getNamespaceDependentsOf2,
@ -161,9 +162,16 @@ prettyParseTypecheck ::
PrettyPrintEnvDecl ->
Parser.ParsingEnv Transaction ->
Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann))
prettyParseTypecheck bigUf pped parsingEnv = do
prettyParseTypecheck bigUf pped =
prettyParseTypecheck2 (Pretty.prettyUnisonFile pped bigUf)
-- TODO: find a better module for this function, as it's used in a couple places
prettyParseTypecheck2 ::
Pretty Pretty.ColorText ->
Parser.ParsingEnv Transaction ->
Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann))
prettyParseTypecheck2 prettyUf parsingEnv = do
Cli.Env {codebase} <- ask
let prettyUf = Pretty.prettyUnisonFile pped bigUf
let stringUf = Pretty.toPlain 80 prettyUf
Debug.whenDebug Debug.Update do
liftIO do
@ -233,13 +241,13 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
where
makeDataDeclUpdates (symbol, (typeRefId, dataDecl)) = makeDeclUpdates (symbol, (typeRefId, Right dataDecl))
makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclUpdates (symbol, (typeRefId, Left effectDecl))
makeDeclUpdates :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> Transaction [(Path, Branch0 m -> Branch0 m)]
makeDeclUpdates (symbol, (typeRefId, decl)) = do
-- some decls will be deleted, we want to delete their
-- constructors as well
deleteConstructorActions <- case maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol) of
Left err -> abort err
Right actions -> pure actions
deleteConstructorActions <-
(maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol)) & onLeft abort
let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split
split = splitVar symbol
insertTypeAction = BranchUtil.makeAddTypeName split (Reference.fromId typeRefId)

15
unison-core/src/Unison/Name.hs
View File

@ -506,12 +506,10 @@ unqualified :: Name -> Name
unqualified (Name _ (s :| _)) =
Name Relative (s :| [])
-- Tries to shorten `fqn` to the smallest suffix that still
-- unambiguously refers to the same name. Uses an efficient
-- Tries to shorten `fqn` to the smallest suffix that still unambiguously refers to the same name. Uses an efficient
-- logarithmic lookup in the provided relation.
--
-- NB: Only works if the `Ord` instance for `Name` orders based on
-- `Name.reverseSegments`.
-- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`.
suffixifyByName :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
suffixifyByName fqn rel =
fromMaybe fqn (List.find isOk (suffixes' fqn))
@ -523,13 +521,10 @@ suffixifyByName fqn rel =
matchingNameCount =
getSum (R.searchDomG (\_ _ -> Sum 1) (compareSuffix suffix) rel)
-- Tries to shorten `fqn` to the smallest suffix that still refers the same references.
-- Uses an efficient logarithmic lookup in the provided relation.
-- The returned `Name` may refer to multiple hashes if the original FQN
-- did as well.
-- Tries to shorten `fqn` to the smallest suffix that still refers the same references. Uses an efficient logarithmic
-- lookup in the provided relation. The returned `Name` may refer to multiple hashes if the original FQN did as well.
--
-- NB: Only works if the `Ord` instance for `Name` orders based on
-- `Name.reverseSegments`.
-- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`.
suffixifyByHash :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
suffixifyByHash fqn rel =
fromMaybe fqn (List.find isOk (suffixes' fqn))

22
unison-src/transcripts/merge2.md
View File

@ -1,10 +1,12 @@
# The `merge` command
The `merge` command merges together two branches in the same project: the current branch (unspecificed), and the target
branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`. Let's see a simple,
unconflicted merge in action, wherein Alice (us) and Bob (them) have added different terms.
branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`.
## Basic merge
Let's see a simple unconflicted merge in action: Alice (us) and Bob (them) add different terms. The merged result
contains both additions.
## Basic merge with two unconflicted adds
```ucm:hide
.> project.create-empty project
@ -42,8 +44,9 @@ project/alice> view foo bar
## Update propagation
Updates are propagated. In this example, Alice updates `foo`, and Bob adds a new dependent `bar` of (the old) `foo`.
When Bob's branch is merged into Alice's, her update to `foo` is propagated to `bar`.
Updates that occur in one branch are propagated to the other. In this example, Alice updates `foo`, while Bob adds a new
dependent `bar` of (the old) `foo`. When Bob's branch is merged into Alice's, her update to `foo` is propagated to his
`bar`.
```ucm:hide
.> project.create-empty project
@ -87,9 +90,12 @@ project/alice> view foo bar
## Update propagation with common dependent
Different hashes don't necessarily imply an update. In this example, Alice and Bob both update different dependencies
`bar` and `baz` of a common dependent `foo`, so their `foo`s have different hashes. However, we can merge these changes
together just fine, resulting in a `foo` that incorporates both updates.
We classify something as an "update" if its "syntactic hash" - not its normal Unison hash - differs. This allows us to
cleanly merge unconflicted updates that were individually propagated to a common dependent.
Let's see an example. We have `foo`, which depends on `bar` and `baz`. Alice updates `bar` (propagating to `foo`),
and Bob updates `baz` (propagating to `foo`). When we merge their updates, both updates will be reflected in the final
`foo`.
```ucm:hide
.> project.create-empty project

150
unison-src/transcripts/merge2.output.md
View File

@ -1,10 +1,12 @@
# The `merge` command
The `merge` command merges together two branches in the same project: the current branch (unspecificed), and the target
branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`. Let's see a simple,
unconflicted merge in action, wherein Alice (us) and Bob (them) have added different terms.
branch. For example, to merge `topic` into `main`, switch to `main` and run `merge topic`.
## Basic merge
Let's see a simple unconflicted merge in action: Alice (us) and Bob (them) add different terms. The merged result
contains both additions.
## Basic merge with two unconflicted adds
```ucm
project/main> branch alice
@ -88,8 +90,9 @@ project/alice> view foo bar
```
## Update propagation
Updates are propagated. In this example, Alice updates `foo`, and Bob adds a new dependent `bar` of (the old) `foo`.
When Bob's branch is merged into Alice's, her update to `foo` is propagated to `bar`.
Updates that occur in one branch are propagated to the other. In this example, Alice updates `foo`, while Bob adds a new
dependent `bar` of (the old) `foo`. When Bob's branch is merged into Alice's, her update to `foo` is propagated to his
`bar`.
```unison
foo : Text
@ -201,9 +204,12 @@ project/alice> view foo bar
```
## Update propagation with common dependent
Different hashes don't necessarily imply an update. In this example, Alice and Bob both update different dependencies
`bar` and `baz` of a common dependent `foo`, so their `foo`s have different hashes. However, we can merge these changes
together just fine, resulting in a `foo` that incorporates both updates.
We classify something as an "update" if its "syntactic hash" - not its normal Unison hash - differs. This allows us to
cleanly merge unconflicted updates that were individually propagated to a common dependent.
Let's see an example. We have `foo`, which depends on `bar` and `baz`. Alice updates `bar` (propagating to `foo`),
and Bob updates `baz` (propagating to `foo`). When we merge their updates, both updates will be reflected in the final
`foo`.
```unison
foo : Text
@ -800,133 +806,9 @@ project/alice> merge2 /bob
```
```unison:added-by-ucm scratch.u
type Foo = Baz Nat Nat | Qux Text
type Foo = Qux Text | Baz Nat Nat
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
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.
```unison
unique type Foo
= MkFooOne Nat
| MkFooTwo Nat Nat
```
```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
= MkFooOne Nat Text
| MkFooTwo Nat Nat
```
```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
= MkFooOne Nat
| MkFooTwoRenamed Nat Nat
Foo.MkFooTwo : Text
Foo.MkFooTwo = "hello"
```
```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:
⊡ Previously added definitions will be ignored: Foo
⍟ These new definitions are ok to `add`:
Foo.MkFooTwo : Text
```
```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 = MkFooTwo Nat Nat | MkFooOne Nat Text
type Foo = MkFooTwoRenamed Nat Nat | MkFooOne Nat
Foo.MkFooTwo : Text
Foo.MkFooTwo = "hello"
type Foo = BobQux Text | Baz Nat
```
## Precondition violations