diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 7396511b49..ed066419f3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -74,12 +74,13 @@ handleUpgrade oldDepName newDepName = do currentV1Branch <- Cli.getBranch0At projectPath let currentV1BranchWithoutOldDep = deleteLibdep oldDepName currentV1Branch oldDep <- Cli.expectBranch0AtPath' oldDepPath - let oldDepWithoutDeps = over Branch.children (Map.delete Name.libSegment) oldDep + let oldDepWithoutDeps = deleteLibdeps oldDep let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup Name.libSegment (oldDep ^. Branch.children) - newDepV1Branch <- Cli.expectBranch0AtPath' newDepPath + newDep <- Cli.expectBranch0AtPath' newDepPath + let newDepWithoutDeps = deleteLibdeps newDep - let namesExcludingLibdeps = Branch.toNames (currentV1Branch & over Branch.children (Map.delete Name.libSegment)) + let namesExcludingLibdeps = Branch.toNames (deleteLibdeps currentV1Branch) let constructorNamesExcludingLibdeps = forwardCtorNames namesExcludingLibdeps let namesExcludingOldDep = Branch.toNames currentV1BranchWithoutOldDep @@ -110,7 +111,6 @@ handleUpgrade oldDepName newDepName = do -- -- mything#mything2 = #newfoo + 10 - let newDepWithoutDeps = over Branch.children (Map.delete Name.libSegment) newDepV1Branch let filterUnchangedTerms :: Relation Referent Name -> Set TermReference filterUnchangedTerms oldTerms = let phi ref oldNames = case Referent.toTermReference ref of @@ -170,7 +170,7 @@ handleUpgrade oldDepName newDepName = do dependents UnisonFile.emptyUnisonFile hashLength <- Codebase.hashLength - let primaryPPE = makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep + let primaryPPE = makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDeps newDepWithoutDeps let secondaryPPE = PPED.fromNamesDecl hashLength (NamesWithHistory.fromCurrentNames namesExcludingOldDep) pure (unisonFile, primaryPPE `PPED.addFallback` secondaryPPE) @@ -219,115 +219,71 @@ handleUpgrade oldDepName newDepName = do textualDescriptionOfUpgrade = Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName] --- `makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDepBranch` makes a PPE(D) that only knows how to render --- `old` direct defns; other names should be provided by some fallback PPE. --- --- How we render `old` deps is rather subtle and complicated, but the basic idea is that an `upgrade old new` ought to --- render all of the old things like `lib.old.foo#oldfoo` as `lib.new.foo` to be parsed and typechecked. --- --- To render some reference #foo, if it's not a reference that's directly part of old's API (i.e. it has some name in --- `lib.old.*` that isn't in one of old's deps `lib.old.lib.*`, then return the empty list of names. (Again, the --- fallback PPE will ultimately provide a name for such a #foo). --- --- Otherwise, we have some #foo that has at least one name in `lib.old.*`; say it's called `lib.old.foo`. The goal is to --- render this as `lib.new.foo`, regardless of how many other aliases #foo has in the namespace. (It may be the case --- that #foo has a name outside of the libdeps, like `my.name.for.foo`, or maybe it has a name in another dependency --- entirely, like `lib.otherdep.othername`). -makeOldDepPPE :: NameSegment -> NameSegment -> Names -> Branch0 m -> PrettyPrintEnvDecl -makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDepBranch = +makeOldDepPPE :: + NameSegment -> + NameSegment -> + Names -> + Branch0 m -> + Branch0 m -> + Branch0 m -> + PrettyPrintEnvDecl +makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDeps newDepWithoutDeps = let makePPE suffixifyTerms suffixifyTypes = PrettyPrintEnv { termNames = \ref -> - case ( Set.member ref termsDirectlyInOldDep, - Set.member ref oldTerms, - Relation.memberRan ref (terms namesExcludingOldDep) - ) of - (True, _, _) -> - -- Say ref is #oldfoo, with two names in `old`: - -- - -- [ lib.old.foo, lib.old.fooalias ] - -- - -- We start from that same list of names with `new` swapped in for `old`: - -- - -- [ lib.new.foo, lib.new.fooalias ] - Names.namesForReferent fakeNames ref - & Set.toList - -- We manually lift those to hashless hash-qualified names, which isn't a very significant - -- implementation detail, we just happen to not want hashes, even if the old name like "lib.old.foo" - -- was conflicted in `old`. - & map (\name -> (HQ'.fromName name, HQ'.fromName name)) - -- We find the shortest unique suffix of each name in a naming context which: - -- - -- 1. Starts from all names, minus the entire `lib.old` namespace. - -- - -- 2. Deletes every name for references directly in `lib.old` (i.e. in `lib.old.*` without having - -- to descend into some `lib.old.lib.*`. - -- - -- For example, if there's both - -- - -- lib.old.foo#oldfoo - -- someAlias#oldfoo - -- - -- then (again, because #oldfoo has a name directly in `lib.old`), we delete names like - -- `someAlias#oldfoo`. - -- - -- 3. Adds back in names like `lib.new.*` for every hash directly referenced in `lib.old.*`, which - -- would be - -- - -- [ lib.new.foo#oldfoo, lib.new.fooalias#oldfoo ] - & suffixifyTerms - & PPE.Names.prioritize - (False, True, False) -> - Names.namesForReferent (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) $ Branch.toNames oldDepBranch) ref - & Set.toList - & map (\name -> (HQ'.fromName name, HQ'.fromName name)) - & PPE.Names.prioritize - _ -> [], + let oldDirectNames = Relation.lookupDom ref (Branch.deepTerms oldDepWithoutDeps) + newDirectRefsForOldDirectNames = + Relation.range (Branch.deepTerms newDepWithoutDeps) `Map.restrictKeys` oldDirectNames + in case ( Set.null oldDirectNames, + Map.null newDirectRefsForOldDirectNames, + Set.member ref (Branch.deepReferents oldDep), + Relation.memberRan ref (Names.terms namesExcludingOldDep) + ) of + (False, False, _, _) -> + Names.namesForReferent fakeNames ref + & Set.toList + & map (\name -> (HQ'.fromName name, HQ'.fromName name)) + & suffixifyTerms + & PPE.Names.prioritize + (_, _, True, False) -> + Names.namesForReferent prefixedOldNames ref + & Set.toList + & map (\name -> (HQ'.fromName name, HQ'.fromName name)) + & PPE.Names.prioritize + _ -> [], typeNames = \ref -> - case ( Set.member ref typesDirectlyInOldDep, - Set.member ref oldTypes, - Relation.memberRan ref (types namesExcludingOldDep) - ) of - (True, _, _) -> - Names.namesForReference fakeNames ref - & Set.toList - & map (\name -> (HQ'.fromName name, HQ'.fromName name)) - & suffixifyTypes - & PPE.Names.prioritize - (False, True, False) -> - Names.namesForReference (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) $ Branch.toNames oldDepBranch) ref - & Set.toList - & map (\name -> (HQ'.fromName name, HQ'.fromName name)) - & PPE.Names.prioritize - _ -> [] + let oldDirectNames = Relation.lookupDom ref (Branch.deepTypes oldDepWithoutDeps) + newDirectRefsForOldDirectNames = + Relation.range (Branch.deepTypes newDepWithoutDeps) `Map.restrictKeys` oldDirectNames + in case ( Set.null oldDirectNames, + Map.null newDirectRefsForOldDirectNames, + Set.member ref (Branch.deepTypeReferences oldDep), + Relation.memberRan ref (Names.types namesExcludingOldDep) + ) of + (False, False, _, _) -> + Names.namesForReference fakeNames ref + & Set.toList + & map (\name -> (HQ'.fromName name, HQ'.fromName name)) + & suffixifyTypes + & PPE.Names.prioritize + (_, _, True, False) -> + Names.namesForReference prefixedOldNames ref + & Set.toList + & map (\name -> (HQ'.fromName name, HQ'.fromName name)) + & PPE.Names.prioritize + _ -> [] } in PrettyPrintEnvDecl { unsuffixifiedPPE = makePPE id id, suffixifiedPPE = makePPE - ( PPE.Names.shortestUniqueSuffixes $ - namesExcludingOldDep - & Names.terms - & Relation.subtractRan termsDirectlyInOldDep - & Relation.union (Names.terms fakeNames) - ) - ( PPE.Names.shortestUniqueSuffixes $ - namesExcludingOldDep - & Names.types - & Relation.subtractRan typesDirectlyInOldDep - & Relation.union (Names.types fakeNames) - ) + (PPE.Names.shortestUniqueSuffixes (Names.terms namesExcludingOldDep)) + (PPE.Names.shortestUniqueSuffixes (Names.types namesExcludingOldDep)) } where - oldTypes = Branch.deepTypeReferences oldDepBranch - oldTerms = Branch.deepReferents oldDepBranch - oldDepWithoutItsDeps = over Branch.children (Map.delete Name.libSegment) oldDepBranch - termsDirectlyInOldDep = Branch.deepReferents oldDepWithoutItsDeps - typesDirectlyInOldDep = Branch.deepTypeReferences oldDepWithoutItsDeps - fakeNames = - oldDepWithoutItsDeps - & Branch.toNames - & Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment])) + oldNames = Branch.toNames oldDep + prefixedOldNames = Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) oldNames + fakeNames = Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment])) oldNames -- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name -- like "upgrade--to-". @@ -361,3 +317,7 @@ findTemporaryBranchName projectId oldDepName newDepName = do deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m deleteLibdep dep = over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep) + +deleteLibdeps :: Branch0 m -> Branch0 m +deleteLibdeps = + over Branch.children (Map.delete Name.libSegment)