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 =