From ee758a2e22194ec903d1c8f4e06c21ca51f695a1 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Dec 2023 12:36:32 -0500 Subject: [PATCH] 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 --- .../src/Unison/PrettyPrintEnv/Names.hs | 16 +++- .../tests/Unison/Core/Test/Name.hs | 12 +-- .../Codebase/Editor/HandleInput/Upgrade.hs | 93 ++++++++++++++----- unison-core/src/Unison/Name.hs | 14 +-- 4 files changed, 94 insertions(+), 41 deletions(-) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/Names.hs index bc09a0d3bd..3989a91b38 100644 --- 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 index d64c7d296b..0776d9bc3e 100644 --- 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 index 271a57d7e5..b6a02722b2 100644 --- 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--to-". findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index a891fffd14..5b48ddc9e6 100644 --- 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 =