diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 82c5af515e..3473325bd1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -52,6 +52,7 @@ import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Debug qualified as Debug import Unison.FileParsers qualified as FileParsers import Unison.Hash (Hash) +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Name.Forward (ForwardName (..)) @@ -66,6 +67,8 @@ import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Prelude +import Unison.PrettyPrintEnv (PrettyPrintEnv) +import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPE @@ -113,11 +116,17 @@ handleUpdate2 = do (Names.referenceIds namesExcludingLibdeps) (getExistingReferencesNamed termAndDeclNames namesExcludingLibdeps) -- - construct PPE for printing UF* for typechecking (whatever data structure we decide to print) - pped <- Codebase.hashLength <&> (`PPE.fromNamesDecl` (NamesWithHistory.fromCurrentNames namesIncludingLibdeps)) bigUf <- buildBigUnisonFile abort codebase tuf dependents namesExcludingLibdeps ctorNames - let tufPped = PPE.fromNamesDecl 8 (Names.NamesWithHistory (UF.typecheckedToNames tuf) mempty) + pped <- + ( \hlen -> + shadowNames + hlen + (UF.typecheckedToNames tuf) + (NamesWithHistory.fromCurrentNames namesIncludingLibdeps) + ) + <$> Codebase.hashLength - pure (pped `PPED.addFallback` tufPped, bigUf) + pure (pped, bigUf) -- - typecheck it Cli.respond Output.UpdateStartTypechecking @@ -413,11 +422,43 @@ getTermAndDeclNames tuf = Defns (terms <> effectCtors <> dataCtors) (effects <> keysToNames = Set.map Name.unsafeFromVar . Map.keysSet ctorsToNames = Set.fromList . map Name.unsafeFromVar . Decl.constructorVars --- namespace: --- type Foo = Bar Nat --- baz = 4 --- qux = baz + 1 - --- unison file: --- Foo.Bar = 3 --- baz = 5 +-- | Combines 'n' and 'nwh' then creates a ppe, but all references to +-- any name in 'n' are printed unqualified. +-- +-- This is useful with the current update strategy where, for all +-- updates @#old -> #new@ we want to print dependents of #old and +-- #new, and have all occurrences of #old and #new be printed with the +-- unqualified name. +-- +-- For this usecase the names from the scratch file are passed as 'n' +-- and the names from the codebase are passed in 'nwh'. +shadowNames :: Int -> Names -> NamesWithHistory -> PrettyPrintEnvDecl +shadowNames hashLen n nwh = + let PPED.PrettyPrintEnvDecl unsuffixified0 suffixified0 = PPE.fromNamesDecl hashLen (Names.NamesWithHistory n mempty <> nwh) + unsuffixified = patchPrettyPrintEnv unsuffixified0 + suffixified = patchPrettyPrintEnv suffixified0 + patchPrettyPrintEnv :: PrettyPrintEnv -> PrettyPrintEnv + patchPrettyPrintEnv PPE.PrettyPrintEnv {termNames, typeNames} = + PPE.PrettyPrintEnv + { termNames = patch shadowedTermRefs termNames, + typeNames = patch shadowedTypeRefs typeNames + } + patch shadowed f ref = + let res = f ref + in case Set.member ref shadowed of + True -> map (second stripHashQualified) res + False -> res + stripHashQualified = \case + HQ'.HashQualified b _ -> HQ'.NameOnly b + HQ'.NameOnly b -> HQ'.NameOnly b + shadowedTermRefs = + let names = Relation.dom (Names.terms n) + NamesWithHistory otherNames _ = nwh + otherTermNames = Names.terms otherNames + in Relation.ran (Names.terms n) <> foldMap (\a -> Relation.lookupDom a otherTermNames) names + shadowedTypeRefs = + let names = Relation.dom (Names.types n) + NamesWithHistory otherNames _ = nwh + otherTypeNames = Names.types otherNames + in Relation.ran (Names.types n) <> foldMap (\a -> Relation.lookupDom a otherTypeNames) names + in PPED.PrettyPrintEnvDecl unsuffixified suffixified diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 0d9da35041..28c03a09dd 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -38,7 +38,7 @@ data NamesWithHistory = NamesWithHistory instance Semigroup NamesWithHistory where NamesWithHistory cur1 old1 <> NamesWithHistory cur2 old2 = - NamesWithHistory (cur1 <> old1) (cur2 <> old2) + NamesWithHistory (cur1 <> cur2) (old1 <> old2) instance Monoid NamesWithHistory where mempty = NamesWithHistory mempty mempty diff --git a/unison-src/transcripts/fix4424.md b/unison-src/transcripts/fix4424.md new file mode 100644 index 0000000000..19963478f0 --- /dev/null +++ b/unison-src/transcripts/fix4424.md @@ -0,0 +1,27 @@ +```ucm:hide +.> builtins.merge +``` + +Some basics: + +```unison:hide +unique type Cat.Dog = Mouse Nat +unique type Rat.Dog = Bird + +countCat = cases + Cat.Dog.Mouse x -> Bird +``` + +```ucm +.> add +``` + +Now I want to add a constructor. + +```unison:hide +unique type Rat.Dog = Bird | Mouse +``` + +```ucm +.> update +``` diff --git a/unison-src/transcripts/fix4424.output.md b/unison-src/transcripts/fix4424.output.md new file mode 100644 index 0000000000..daf48abcb3 --- /dev/null +++ b/unison-src/transcripts/fix4424.output.md @@ -0,0 +1,39 @@ +Some basics: + +```unison +unique type Cat.Dog = Mouse Nat +unique type Rat.Dog = Bird + +countCat = cases + Cat.Dog.Mouse x -> Bird +``` + +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Cat.Dog + unique type Rat.Dog + countCat : Cat.Dog -> Rat.Dog + +``` +Now I want to add a constructor. + +```unison +unique type Rat.Dog = Bird | Mouse +``` + +```ucm +.> update + + Okay, I'm searching the branch for code that needs to be + updated... + + That's done. Now I'm making sure everything typechecks... + + Everything typechecks, so I'm saving the results... + + Done. + +```