adjust upgrade PPE to fix alias mishap bug

previously, any alias of an "old" thing would essentially prevent it from being updated to the new corresponding thing. this patch attempts to solve that problem by adjusting the PPE we use to print things
unisonweb · Dec 5, 2023 · ee758a2 · ee758a2
1 parent 38c39ba
commit ee758a2
Show file tree

Hide file tree

Showing 4 changed files with 94 additions and 41 deletions.
diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/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))
diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/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)
         ]

diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/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 <-
@@ -172,6 +158,67 @@ handleUpgrade oldDepName newDepName = do
     textualDescriptionOfUpgrade =
       Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
 
+makeOldDepPPE :: NameSegment -> Names -> Branch0 m -> PrettyPrintEnvDecl
+makeOldDepPPE newDepName namesExcludingOldDep oldDepV1Branch =
+  PrettyPrintEnvDecl
+    { unsuffixifiedPPE =
+        let termNames ref =
+              if Set.member ref termsDirectlyInOldDep
+                then
+                  Names.namesForReferent fakeNames ref
+                    & Set.toList
+                    & map (\name -> (HQ'.fromName name, HQ'.fromName name))
+                    & 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))
+                    & PPE.Names.prioritize
+                else []
+         in PrettyPrintEnv {termNames, typeNames},
+      suffixifiedPPE =
+        let termNames ref =
+              if Set.member ref termsDirectlyInOldDep
+                then
+                  Names.namesForReferent fakeNames ref
+                    & Set.toList
+                    & map (\name -> (HQ'.fromName name, HQ'.fromName name))
+                    & PPE.Names.shortestUniqueSuffixes bogusoidTermNames
+                    & 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))
+                    & PPE.Names.shortestUniqueSuffixes bogusoidTypeNames
+                    & PPE.Names.prioritize
+                else []
+         in PrettyPrintEnv {termNames, typeNames}
+    }
+  where
+    oldDepMinusItsDepsV1Branch = over Branch.children (Map.delete Name.libSegment) oldDepV1Branch
+    termsDirectlyInOldDep = Branch.deepReferents oldDepMinusItsDepsV1Branch
+    typesDirectlyInOldDep = Branch.deepTypeReferences oldDepMinusItsDepsV1Branch
+    fakeNames =
+      oldDepMinusItsDepsV1Branch
+        & Branch.toNames
+        & Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment]))
+    bogusoidTermNames =
+      namesExcludingOldDep
+        & Names.terms
+        & Relation.subtractRan termsDirectlyInOldDep
+        & Relation.union (Names.terms fakeNames)
+    bogusoidTypeNames =
+      namesExcludingOldDep
+        & Names.types
+        & Relation.subtractRan typesDirectlyInOldDep
+        & Relation.union (Names.types fakeNames)
+
 -- @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

diff --git a/unison-core/src/Unison/Name.hs b/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 =