Merge pull request #4471 from unisonweb/23-12-05-fix-upgrade-alias-bug

parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Unison.PrettyPrintEnv.Names (fromNames, fromSuffixNames) where
+module Unison.PrettyPrintEnv.Names
+  ( fromNames,
+    fromSuffixNames,
+    prioritize,
+    shortestUniqueSuffixes,
+  )
+where
 
 import Data.Set qualified as Set
 import Unison.HashQualified' qualified as HQ'
@@ -46,16 +52,16 @@ fromSuffixNames len names = PrettyPrintEnv terms' types'
       NamesWithHistory.termName len r names
         & Set.toList
         & fmap (\n -> (n, n))
-        & shortestUniqueSuffixes r (Names.terms $ NamesWithHistory.currentNames names)
+        & shortestUniqueSuffixes (Names.terms $ NamesWithHistory.currentNames names)
         & prioritize
     types' r =
       NamesWithHistory.typeName len r names
         & Set.toList
         & fmap (\n -> (n, n))
-        & shortestUniqueSuffixes r (Names.types $ NamesWithHistory.currentNames names)
+        & shortestUniqueSuffixes (Names.types $ NamesWithHistory.currentNames names)
         & prioritize
 
 -- | Reduce the provided names to their minimal unique suffix within the scope of the given
 -- relation.
-shortestUniqueSuffixes :: (Ord ref) => ref -> Rel.Relation Name ref -> [(a, HQ'.HashQualified Name)] -> [(a, HQ'.HashQualified Name)]
-shortestUniqueSuffixes ref rel names = names <&> second (fmap (\name -> Name.shortestUniqueSuffix name ref rel))
+shortestUniqueSuffixes :: (Ord ref) => Rel.Relation Name ref -> [(a, HQ'.HashQualified Name)] -> [(a, HQ'.HashQualified Name)]
+shortestUniqueSuffixes rel names = names <&> second (fmap (\name -> Name.shortestUniqueSuffix name rel))

parser-typechecker/tests/Unison/Core/Test/Name.hs

@@ -92,24 +92,24 @@ testSuffixSearch =
         (Name.searchBySuffix (n "map") rel)
       expectEqual'
         (n "List.map")
-        (Name.shortestUniqueSuffix (n "base.List.map") 1 rel)
+        (Name.shortestUniqueSuffix (n "base.List.map") rel)
       expectEqual'
         (n "Set.map")
-        (Name.shortestUniqueSuffix (n "base.Set.map") 2 rel)
+        (Name.shortestUniqueSuffix (n "base.Set.map") rel)
       expectEqual'
         (n "baz")
-        (Name.shortestUniqueSuffix (n "foo.bar.baz") 3 rel)
+        (Name.shortestUniqueSuffix (n "foo.bar.baz") rel)
       expectEqual'
         (n "a.b.c")
-        (Name.shortestUniqueSuffix (n "a.b.c") 3 rel)
+        (Name.shortestUniqueSuffix (n "a.b.c") rel)
       expectEqual'
         (n "a1.b.c")
-        (Name.shortestUniqueSuffix (n "a1.b.c") 3 rel)
+        (Name.shortestUniqueSuffix (n "a1.b.c") rel)
       note . show $ Name.reverseSegments (n ".")
       note . show $ Name.reverseSegments (n "..")
       tests
         [ scope "(.) shortest unique suffix" $
-            expectEqual' (n ".") (Name.shortestUniqueSuffix (n "..") 6 rel),
+            expectEqual' (n ".") (Name.shortestUniqueSuffix (n "..") rel),
           scope "(.) search by suffix" $
             expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n ".") rel)
         ]

unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs

@@ -33,17 +33,23 @@ import Unison.Codebase.Editor.HandleInput.Update2
   )
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Path qualified as Path
+import Unison.HashQualified' qualified as HQ'
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
+import Unison.Names (Names (..))
 import Unison.Names qualified as Names
 import Unison.NamesWithHistory qualified as NamesWithHistory
 import Unison.Prelude
+import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
+import Unison.PrettyPrintEnv.Names qualified as PPE.Names
+import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
 import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
 import Unison.PrettyPrintEnvDecl.Names qualified as PPED
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
 import Unison.Sqlite (Transaction)
 import Unison.UnisonFile qualified as UnisonFile
+import Unison.Util.Relation qualified as Relation
 import Witch (unsafeFrom)
 
 handleUpgrade :: NameSegment -> NameSegment -> Cli ()
@@ -61,14 +67,12 @@ handleUpgrade oldDepName newDepName = do
 
   currentV1Branch <- Cli.getBranch0At projectPath
   let currentV1BranchWithoutOldDep = deleteLibdep oldDepName currentV1Branch
-  let currentV1BranchWithoutOldAndNewDeps = deleteLibdep newDepName currentV1BranchWithoutOldDep
   oldDepV1Branch <- Cli.expectBranch0AtPath' oldDepPath
   _newDepV1Branch <- Cli.expectBranch0AtPath' newDepPath
 
   let namesExcludingLibdeps = Branch.toNames (currentV1Branch & over Branch.children (Map.delete Name.libSegment))
   let constructorNamesExcludingLibdeps = forwardCtorNames namesExcludingLibdeps
   let namesExcludingOldDep = Branch.toNames currentV1BranchWithoutOldDep
-  let namesExcludingOldAndNewDeps = Branch.toNames currentV1BranchWithoutOldAndNewDeps
 
   -- High-level idea: we are trying to perform substitution in every term that depends on something in `old` with the
   -- corresponding thing in `new`, by first rendering the user's code with a particular pretty-print environment, then
@@ -113,27 +117,9 @@ handleUpgrade oldDepName newDepName = do
           dependents
           UnisonFile.emptyUnisonFile
       hashLength <- Codebase.hashLength
-      let namesToPPED = PPED.fromNamesDecl hashLength . NamesWithHistory.fromCurrentNames
-      let printPPE1 = namesToPPED namesExcludingOldDep
-      -- These "fake names" are all of things in `lib.old`, with the `old` segment swapped out for `new`
-      --
-      -- If we fall back to this second PPE, we know we have a reference in `fakeNames` (i.e. a reference originally
-      -- from `old`, and found nowhere else in our project+libdeps), but we have to include
-      -- `namesExcludingOldAndNewDeps` as well, so that we don't over-suffixify.
-      --
-      -- For example, consider the names
-      --
-      --   #old = lib.new.foobaloo
-      --   #thing = my.project.foobaloo
-      --
-      -- Were we to fall back on this PPE looking up a name for #old, we'd not want to return "foobaloo", but rather
-      -- "new.foobaloo".
-      let fakeNames =
-            oldDepV1Branch
-              & Branch.toNames
-              & Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment]))
-      let printPPE2 = namesToPPED (namesExcludingOldAndNewDeps <> fakeNames)
-      pure (unisonFile, printPPE1 `PPED.addFallback` printPPE2)
+      let primaryPPE = makeOldDepPPE newDepName namesExcludingOldDep oldDepV1Branch
+      let secondaryPPE = PPED.fromNamesDecl hashLength (NamesWithHistory.fromCurrentNames namesExcludingOldDep)
+      pure (unisonFile, primaryPPE `PPED.addFallback` secondaryPPE)
 
   parsingEnv <- makeParsingEnv projectPath namesExcludingOldDep
   typecheckedUnisonFile <-
@@ -155,12 +141,13 @@ handleUpgrade oldDepName newDepName = do
       Cli.respond (Output.UpgradeFailure oldDepName newDepName)
       Cli.returnEarlyWithoutOutput
 
-  branchUpdates <- Cli.runTransactionWithRollback \abort -> do
-    Codebase.addDefsToCodebase codebase typecheckedUnisonFile
-    typecheckedUnisonFileToBranchUpdates
-      abort
-      (findCtorNames namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
-      typecheckedUnisonFile
+  branchUpdates <-
+    Cli.runTransactionWithRollback \abort -> do
+      Codebase.addDefsToCodebase codebase typecheckedUnisonFile
+      typecheckedUnisonFileToBranchUpdates
+        abort
+        (findCtorNames namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
+        typecheckedUnisonFile
   Cli.stepAt
     textualDescriptionOfUpgrade
     ( Path.unabsolute projectPath,
@@ -172,6 +159,98 @@ handleUpgrade oldDepName newDepName = do
     textualDescriptionOfUpgrade =
       Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
 
+-- `makeOldDepPPE newDepName namesExcludingOldDep oldDepBranch` makes a PPE(D) that only knows how to render `old` deps;
+-- 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 -> Names -> Branch0 m -> PrettyPrintEnvDecl
+makeOldDepPPE newDepName namesExcludingOldDep oldDepBranch =
+  let makePPE suffixifyTerms suffixifyTypes =
+        PrettyPrintEnv
+          { termNames = \ref ->
+              if Set.member ref termsDirectlyInOldDep
+                then
+                  -- 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
+                else [],
+            typeNames = \ref ->
+              if Set.member ref typesDirectlyInOldDep
+                then
+                  Names.namesForReference fakeNames ref
+                    & Set.toList
+                    & map (\name -> (HQ'.fromName name, HQ'.fromName name))
+                    & suffixifyTypes
+                    & PPE.Names.prioritize
+                else []
+          }
+   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)
+              )
+        }
+  where
+    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]))
+
 -- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name
 -- like "upgrade-<oldDepName>-to-<newDepName>".
 findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName

unison-core/src/Unison/Name.hs

@@ -481,23 +481,23 @@ unqualified :: Name -> Name
 unqualified (Name _ (s :| _)) =
   Name Relative (s :| [])
 
--- Tries to shorten `fqn` to the smallest suffix that still refers
--- to to `r`. Uses an efficient logarithmic lookup in the provided relation.
+-- 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`.
-shortestUniqueSuffix :: forall r. (Ord r) => Name -> r -> R.Relation Name r -> Name
-shortestUniqueSuffix fqn r rel =
+shortestUniqueSuffix :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
+shortestUniqueSuffix fqn rel =
   fromMaybe fqn (List.find isOk (suffixes' fqn))
   where
-    allowed :: Set r
-    allowed =
+    allRefs :: Set r
+    allRefs =
       R.lookupDom fqn rel
     isOk :: Name -> Bool
     isOk suffix =
-      (Set.size rs == 1 && Set.findMin rs == r) || rs == allowed
+      Set.size rs == 1 || rs == allRefs
       where
         rs :: Set r
         rs =

unison-src/transcripts/upgrade-with-old-alias.md

@@ -0,0 +1,19 @@
+```ucm:hide
+.> project.create-empty myproject
+myproject/main> builtins.merge
+myproject/main> move.namespace builtin lib.builtin
+```
+
+```unison
+lib.old.foo = 141
+lib.new.foo = 142
+bar = 141
+mything = lib.old.foo + 100
+```
+
+```ucm
+myproject/main> update
+myproject/main> upgrade old new
+myproject/main> view mything
+myproject/main> view bar
+```

unison-src/transcripts/upgrade-with-old-alias.output.md

@@ -0,0 +1,46 @@
+```unison
+lib.old.foo = 141
+lib.new.foo = 142
+bar = 141
+mything = lib.old.foo + 100
+```
+
+```ucm
+
+  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`:
+    
+      bar         : Nat
+      lib.new.foo : Nat
+      lib.old.foo : Nat
+      mything     : Nat
+
+```
+```ucm
+myproject/main> update
+
+  Okay, I'm searching the branch for code that needs to be
+  updated...
+
+  Done.
+
+myproject/main> upgrade old new
+
+  I upgraded old to new, and removed old.
+
+myproject/main> view mything
+
+  mything : Nat
+  mything =
+    use Nat +
+    foo + 100
+
+myproject/main> view bar
+
+  bar : Nat
+  bar = 141
+
+```