From 354a89397715bfd00f3a1b379e5c220640bedbfc Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 14 Nov 2023 12:21:40 -0500 Subject: [PATCH] make findCtorNames return an Output instead of `error` and thread that through everywhere --- unison-cli/src/Unison/Cli/Monad.hs | 1 + .../Codebase/Editor/HandleInput/Update2.hs | 87 +++++++++++-------- .../src/Unison/Codebase/Editor/Output.hs | 3 + .../src/Unison/CommandLine/OutputMessages.hs | 21 ++++- .../update-type-missing-constructor.md | 24 +++++ .../update-type-missing-constructor.output.md | 63 ++++++++++++++ .../update-type-stray-constructor.md | 9 +- .../update-type-stray-constructor.output.md | 23 ++++- 8 files changed, 188 insertions(+), 43 deletions(-) create mode 100644 unison-src/transcripts/update-type-missing-constructor.md create mode 100644 unison-src/transcripts/update-type-missing-constructor.output.md diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 44f4640afe..3a61e6407a 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -417,6 +417,7 @@ runTransaction action = do liftIO (Codebase.runTransaction codebase action) -- | Run a transaction that can abort early with an output message. +-- todo: rename to runTransactionWithReturnEarly runTransactionWithRollback :: ((forall void. Output -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a runTransactionWithRollback action = do Env {codebase} <- ask diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 08dd6dfc4a..545a20641c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -6,6 +6,7 @@ module Unison.Codebase.Editor.HandleInput.Update2 where import Control.Lens (over, (^.)) +import Control.Lens qualified as Lens import Control.Monad.RWS (ask) import Data.Foldable qualified as Foldable import Data.List.NonEmpty qualified as NonEmpty @@ -27,6 +28,7 @@ import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Branch.Type (Branch0) import Unison.Codebase.BranchUtil qualified as BranchUtil +import Unison.Codebase.Editor.Output (Output) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path @@ -55,6 +57,7 @@ import Unison.Prelude import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPE +import Unison.Reference (TypeReferenceId) import Unison.Reference qualified as Reference (fromId) import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -70,6 +73,7 @@ import Unison.Type (Type) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.UnisonFile.Type (TypecheckedUnisonFile, UnisonFile) +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty (Pretty) import Unison.Util.Pretty qualified as Pretty import Unison.Util.Relation qualified as Relation @@ -98,14 +102,14 @@ handleUpdate2 = do let ctorNames = forwardCtorNames namesExcludingLibdeps Cli.respond Output.UpdateLookingForDependents - (pped, bigUf) <- Cli.runTransactionWithRollback \_abort -> do + (pped, bigUf) <- Cli.runTransactionWithRollback \abort -> do dependents <- Ops.dependentsWithinScope (namespaceReferences 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 codebase tuf dependents namesExcludingLibdeps + bigUf <- buildBigUnisonFile abort codebase tuf dependents namesExcludingLibdeps let tufPped = PPE.fromNamesDecl 8 (Names.NamesWithHistory (UF.typecheckedToNames tuf) mempty) pure (pped `PPED.addFallback` tufPped, bigUf) @@ -183,30 +187,31 @@ mkTypecheckFn codebase generateUniqueName currentPath parseNames unisonFile = do pure maybeTypecheckedUnisonFile -- save definitions and namespace -saveTuf :: (Name -> [Name]) -> TypecheckedUnisonFile Symbol Ann -> Cli () +saveTuf :: (Name -> Either Output [Name]) -> TypecheckedUnisonFile Symbol Ann -> Cli () saveTuf getConstructors tuf = do Cli.Env {codebase} <- ask currentPath <- Cli.getCurrentPath - Cli.runTransaction $ Codebase.addDefsToCodebase codebase tuf + declUpdates <- Cli.runTransactionWithRollback \abort -> do + Codebase.addDefsToCodebase codebase tuf + makeDeclUpdates abort Cli.stepAt "update" (Path.unabsolute currentPath, Branch.batchUpdates (declUpdates ++ termUpdates)) where - declUpdates :: [(Path, Branch0 m -> Branch0 m)] - declUpdates = - fold - [ foldMap makeDataDeclUpdates (Map.toList $ UF.dataDeclarationsId' tuf), - foldMap makeEffectDeclUpdates (Map.toList $ UF.effectDeclarationsId' tuf) - ] + makeDeclUpdates :: forall m. (forall void. Output -> Transaction void) -> Transaction [(Path, Branch0 m -> Branch0 m)] + makeDeclUpdates abort = do + dataDeclUpdates <- Monoid.foldMapM makeDataDeclUpdates (Map.toList $ UF.dataDeclarationsId' tuf) + effectDeclUpdates <- Monoid.foldMapM makeEffectDeclUpdates (Map.toList $ UF.effectDeclarationsId' tuf) + pure $ dataDeclUpdates <> effectDeclUpdates where makeDataDeclUpdates (symbol, (typeRefId, dataDecl)) = makeDeclUpdates (symbol, (typeRefId, Right dataDecl)) makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclUpdates (symbol, (typeRefId, Left effectDecl)) - makeDeclUpdates (symbol, (typeRefId, decl)) = + makeDeclUpdates :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> Transaction [(Path, Branch0 m -> Branch0 m)] + makeDeclUpdates (symbol, (typeRefId, decl)) = do + -- some decls will be deleted, we want to delete their + -- constructors as well + deleteConstructorActions <- case map (BranchUtil.makeAnnihilateTermName . Path.splitFromName) <$> getConstructors (Name.unsafeFromVar symbol) of + Left err -> abort err + Right actions -> pure actions let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split - -- some decls will be deleted, we want to delete their - -- constructors as well - deleteConstructorActions = - map - (BranchUtil.makeAnnihilateTermName . Path.splitFromName) - (getConstructors (Name.unsafeFromVar symbol)) split = splitVar symbol insertTypeAction = BranchUtil.makeAddTypeName split (Reference.fromId typeRefId) Map.empty insertTypeConstructorActions = @@ -219,7 +224,7 @@ saveTuf getConstructors tuf = do referentIdsWithNames deleteStuff = deleteTypeAction : deleteConstructorActions addStuff = insertTypeAction : insertTypeConstructorActions - in deleteStuff ++ addStuff + pure $ deleteStuff ++ addStuff termUpdates :: [(Path, Branch0 m -> Branch0 m)] termUpdates = @@ -243,8 +248,8 @@ getExistingReferencesNamed defns names = fromTerms <> fromTypes fromTerms = foldMap (\n -> Set.map Referent.toReference $ Relation.lookupDom n $ Names.terms names) (defns ^. #terms) fromTypes = foldMap (\n -> Relation.lookupDom n $ Names.types names) (defns ^. #types) -buildBigUnisonFile :: Codebase IO Symbol Ann -> TypecheckedUnisonFile Symbol Ann -> Map Reference.Id ReferenceType -> Names -> Transaction (UnisonFile Symbol Ann) -buildBigUnisonFile c tuf dependents names = +buildBigUnisonFile :: (forall a. Output -> Transaction a) -> Codebase IO Symbol Ann -> TypecheckedUnisonFile Symbol Ann -> Map Reference.Id ReferenceType -> Names -> Transaction (UnisonFile Symbol Ann) +buildBigUnisonFile abort c tuf dependents names = -- for each dependent, add its definition with all its names to the UnisonFile foldM addComponent (UF.discardTypes tuf) (Map.toList dependents') where @@ -252,7 +257,7 @@ buildBigUnisonFile c tuf dependents names = addComponent :: UnisonFile Symbol Ann -> (Hash, ReferenceType) -> Transaction (UnisonFile Symbol Ann) addComponent uf (h, rt) = case rt of Reference.RtTerm -> addTermComponent h uf - Reference.RtType -> addDeclComponent h uf + Reference.RtType -> addDeclComponent abort h uf ctorNames = forwardCtorNames names addTermComponent :: Hash -> UnisonFile Symbol Ann -> Transaction (UnisonFile Symbol Ann) addTermComponent h uf = do @@ -273,32 +278,37 @@ buildBigUnisonFile c tuf dependents names = -- given a dependent hash, include that component in the scratch file -- todo: wundefined: cut off constructor name prefixes - addDeclComponent :: Hash -> UnisonFile Symbol Ann -> Transaction (UnisonFile Symbol Ann) - addDeclComponent h uf = do + addDeclComponent :: (forall a. Output -> Transaction a) -> Hash -> UnisonFile Symbol Ann -> Transaction (UnisonFile Symbol Ann) + addDeclComponent abort h uf = do declComponent <- fromJust <$> Codebase.getDeclComponent h - pure $ foldl' addDeclElement uf (zip declComponent [0 ..]) + foldM addDeclElement uf (zip declComponent [0 ..]) where -- for each name a decl has, update its constructor names according to what exists in the namespace - addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> UnisonFile Symbol Ann + addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann) addDeclElement uf (decl, i) = do let declNames = Relation.lookupRan (Reference.Derived h i) (names.types) -- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition. - foldl' (addRebuiltDefinition decl) uf declNames + foldM (addRebuiltDefinition decl) uf declNames where -- skip any definitions that already have names, we don't want to overwrite what the user has supplied + addRebuiltDefinition :: (Decl Symbol Ann) -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann) addRebuiltDefinition decl uf name = case decl of - Left ed -> uf {UF.effectDeclarationsId = Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration $ overwriteConstructorNames name ed.toDataDecl) uf.effectDeclarationsId} - Right dd -> uf {UF.dataDeclarationsId = Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, overwriteConstructorNames name dd) uf.dataDeclarationsId} - overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> DataDeclaration Symbol Ann + Left ed -> + overwriteConstructorNames name ed.toDataDecl >>= \case + ed' -> pure uf {UF.effectDeclarationsId = Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration ed') uf.effectDeclarationsId} + Right dd -> + overwriteConstructorNames name dd >>= \case + dd' -> pure uf {UF.dataDeclarationsId = Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, dd') uf.dataDeclarationsId} + overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann) overwriteConstructorNames name dd = - let constructorNames :: [Symbol] - constructorNames = - Name.toVar . fromJust . Name.stripNamePrefix name - <$> findCtorNames names ctorNames (Just $ Decl.constructorCount dd) name + let constructorNames :: Transaction [Symbol] + constructorNames = case findCtorNames names ctorNames (Just $ Decl.constructorCount dd) name of + Left err -> abort err + Right array -> pure $ Name.toVar . fromJust . Name.stripNamePrefix name <$> array swapConstructorNames oldCtors = let (annotations, _vars, types) = unzip3 oldCtors - in zip3 annotations constructorNames types - in over Decl.constructors_ swapConstructorNames dd + in zip3 annotations <$> constructorNames <*> pure types + in Lens.traverseOf Decl.constructors_ swapConstructorNames dd -- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c) forwardCtorNames :: Names -> Map ForwardName (Referent, Name) @@ -310,7 +320,7 @@ forwardCtorNames names = ] -- | given a decl name, find names for all of its constructors, in order. -findCtorNames :: Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> [Name] +findCtorNames :: Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name] findCtorNames names forwardCtorNames ctorCount n = let declRef = Set.findMin $ Relation.lookupDom n names.types f = ForwardName.fromName n @@ -329,9 +339,10 @@ findCtorNames names forwardCtorNames ctorCount n = m = foldl' insertShortest mempty (Foldable.toList center) ctorCountGuess = fromMaybe (Map.size m) ctorCount in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m) [0 .. fromIntegral ctorCountGuess - 1] - then Map.elems m - else error $ "incomplete constructor mapping for " ++ show n ++ ": " ++ show (Map.keys m) ++ " out of " ++ show ctorCountGuess + then Right $ Map.elems m + else Left $ Output.UpdateIncompleteConstructorSet n m ctorCountGuess +-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly. -- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux" -- ForwardName {toList = "foo" :| ["bar","quuy"]} incrementLastSegmentChar :: ForwardName -> ForwardName diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 94eb9ce7e2..5877c7b747 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -49,6 +49,7 @@ import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.Type (GitError) import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.LabeledDependency (LabeledDependency) @@ -389,6 +390,7 @@ data Output | UpdateStartTypechecking | UpdateTypecheckingFailure | UpdateTypecheckingSuccess + | UpdateIncompleteConstructorSet Name (Map ConstructorId Name) Int -- | What did we create a project branch from? -- @@ -454,6 +456,7 @@ isFailure o = case o of UpdateStartTypechecking -> False UpdateTypecheckingFailure {} -> True UpdateTypecheckingSuccess {} -> False + UpdateIncompleteConstructorSet {} -> True AmbiguousCloneLocal {} -> True AmbiguousCloneRemote {} -> True ClonedProjectBranch {} -> False diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 7edf4e02c8..14fe208d9e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2185,6 +2185,25 @@ notifyUser dir = \case <> "Once the file is compiling, try" <> makeExample' IP.update <> "again." + UpdateIncompleteConstructorSet name ctorMap expectedCount -> + pure $ + P.lines + [ P.wrap $ + "I couldn't complete the update because I couldn't find" + <> fromString (show expectedCount) + <> "constructor(s) for" + <> prettyName name + <> "where I expected to." + <> "I found:" + <> fromString (show (Map.toList ctorMap)), + "", + P.wrap $ + "You can use" + <> P.indentNAfterNewline 2 (IP.makeExample IP.view [prettyName name]) + <> "and" + <> P.indentNAfterNewline 2 (IP.makeExample IP.aliasTerm ["", prettyName name <> "."]) + <> "to give names to each constructor, and then try again." + ] where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" @@ -2453,7 +2472,7 @@ displayOutputRewrittenFile ppe fp msg (vs, uf) = do "The rewritten file has been added to the top of " <> fromString fp ] -foldLine :: IsString s => P.Pretty s +foldLine :: (IsString s) => P.Pretty s foldLine = "\n\n---- Anything below this line is ignored by Unison.\n\n" prettyUnisonFile :: forall v a. (Var v, Ord a) => PPED.PrettyPrintEnvDecl -> UF.UnisonFile v a -> Pretty diff --git a/unison-src/transcripts/update-type-missing-constructor.md b/unison-src/transcripts/update-type-missing-constructor.md new file mode 100644 index 0000000000..c9ec7bdc5f --- /dev/null +++ b/unison-src/transcripts/update-type-missing-constructor.md @@ -0,0 +1,24 @@ +```ucm:hide +.> builtins.merge +.> move.namespace builtin lib.builtin +``` + +```unison +unique type Foo = Bar Nat +``` + +```ucm +.> add +.> delete.term Foo.Bar +``` + +Now we've set up a situation where the original constructor missing. + +```unison +unique type Foo = Bar Nat Nat +``` + +```ucm:error +.> view Foo +.> update +``` diff --git a/unison-src/transcripts/update-type-missing-constructor.output.md b/unison-src/transcripts/update-type-missing-constructor.output.md new file mode 100644 index 0000000000..9058463f18 --- /dev/null +++ b/unison-src/transcripts/update-type-missing-constructor.output.md @@ -0,0 +1,63 @@ +```unison +unique type Foo = Bar Nat +``` + +```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`: + + unique type Foo + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + unique type Foo + +.> delete.term Foo.Bar + + Done. + +``` +Now we've set up a situation where the original constructor missing. + +```unison +unique type Foo = Bar Nat Nat +``` + +```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 names already exist. You can `update` them to your + new definition: + + unique type Foo + +``` +```ucm +.> view Foo + + unique type Foo = #b509v3eg4k#0 Nat + +.> update + + Okay, I'm searching the branch for code that needs to be + updated... + + I couldn't complete the update because I couldn't find 1 + constructor(s) for Foo where I expected to. I found: [] + + You can use `view Foo` and + `alias.term Foo.` to give names to + each constructor, and then try again. + +``` diff --git a/unison-src/transcripts/update-type-stray-constructor.md b/unison-src/transcripts/update-type-stray-constructor.md index c66094f523..2f7dd27a31 100644 --- a/unison-src/transcripts/update-type-stray-constructor.md +++ b/unison-src/transcripts/update-type-stray-constructor.md @@ -12,10 +12,15 @@ unique type Foo = Bar Nat .> move.term Foo.Bar Stray.Bar ``` +Now we've set up a situation where the constructor is not where it's supposed to be; it's somewhere else. + ```unison unique type Foo = Bar Nat Nat ``` -Bug: this update crashes ucm. Oops we can't even capture that in a transcript. +Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`) doesn't really exist, it's just showing up due to a pretty-printer bug. -# .> update +```ucm:error +.> view Foo +.> update +``` diff --git a/unison-src/transcripts/update-type-stray-constructor.output.md b/unison-src/transcripts/update-type-stray-constructor.output.md index 47175f7bf3..028661c703 100644 --- a/unison-src/transcripts/update-type-stray-constructor.output.md +++ b/unison-src/transcripts/update-type-stray-constructor.output.md @@ -25,6 +25,8 @@ unique type Foo = Bar Nat Done. ``` +Now we've set up a situation where the constructor is not where it's supposed to be; it's somewhere else. + ```unison unique type Foo = Bar Nat Nat ``` @@ -41,6 +43,23 @@ unique type Foo = Bar Nat Nat unique type Foo ``` -Bug: this update crashes ucm. Oops we can't even capture that in a transcript. +Note that the constructor name shown here (implied to be called `Foo.Stray.Bar`) doesn't really exist, it's just showing up due to a pretty-printer bug. + +```ucm +.> view Foo + + unique type Foo = Stray.Bar Nat + +.> update -# .> update + Okay, I'm searching the branch for code that needs to be + updated... + + I couldn't complete the update because I couldn't find 1 + constructor(s) for Foo where I expected to. I found: [] + + You can use `view Foo` and + `alias.term Foo.` to give names to + each constructor, and then try again. + +```