diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index bc2b81cbd3..3300abdf1a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -17,7 +17,6 @@ import Data.List.Extra (nubOrd) import Data.List.NonEmpty qualified as Nel import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet import Data.Text qualified as Text import Data.Time (UTCTime) @@ -57,6 +56,7 @@ import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefi import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges import Unison.Codebase.Editor.HandleInput.DebugSynhashTerm (handleDebugSynhashTerm) import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) +import Unison.Codebase.Editor.HandleInput.DeleteNamespace (getEndangeredDependents, handleDeleteNamespace) import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject) import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI, handleTextFindI) @@ -150,7 +150,6 @@ import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.Share.Codeserver qualified as Codeserver import Unison.ShortHash qualified as SH -import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (parseTextWith, toText) import Unison.Syntax.Lexer.Unison qualified as L @@ -573,43 +572,7 @@ loop e = do delete input doutput getTerms getTypes hqs DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) getTypes hqs DeleteTarget'Term doutput hqs -> delete input doutput getTerms (const (pure Set.empty)) hqs - DeleteTarget'Namespace insistence Nothing -> do - hasConfirmed <- confirmedCommand input - if hasConfirmed || insistence == Force - then do - description <- inputDescription input - pp <- Cli.getCurrentProjectPath - _ <- Cli.updateAt description pp (const Branch.empty) - Cli.respond DeletedEverything - else Cli.respond DeleteEverythingConfirmation - DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do - branch <- Cli.expectBranchAtPath (Path.unsplit p) - description <- inputDescription input - let toDelete = - Names.prefix0 - (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p) - (Branch.toNames (Branch.head branch)) - afterDelete <- do - names <- Cli.currentNames - endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) - case (null endangerments, insistence) of - (True, _) -> pure (Cli.respond Success) - (False, Force) -> do - let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) - pure do - Cli.respond Success - Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments - (False, Try) -> do - let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) - Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments - Cli.returnEarlyWithoutOutput - parentPathAbs <- Cli.resolvePath parentPath - -- We have to modify the parent in order to also wipe out the history at the - -- child. - Cli.updateAt description parentPathAbs \parentBranch -> - parentBranch - & Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty - afterDelete + DeleteTarget'Namespace insistence path -> handleDeleteNamespace input insistence path DeleteTarget'ProjectBranch name -> handleDeleteBranch name DeleteTarget'Project name -> handleDeleteProject name DisplayI outputLoc namesToDisplay -> do @@ -975,7 +938,8 @@ inputDescription input = UndoI {} -> pure "undo" ExecuteI s args -> pure ("execute " <> Text.unwords (HQ.toText s : fmap Text.pack args)) IOTestI native hq -> pure (cmd <> HQ.toText hq) - where cmd | native = "io.test.native " | otherwise = "io.test " + where + cmd | native = "io.test.native " | otherwise = "io.test " IOTestAllI native -> pure (if native then "io.test.native.all" else "io.test.all") UpdateBuiltinsI -> pure "builtins.update" @@ -1485,7 +1449,9 @@ checkDeletes typesTermsTuples doutput inputs = do toRel setRef name = R.fromList (fmap (name,) (toList setRef)) let toDelete = fmap (\(_, names, types, terms) -> Names (toRel terms names) (toRel types names)) splitsNames -- make sure endangered is compeletely contained in paths - projectNames <- Branch.toNames <$> Cli.getCurrentProjectRoot0 + currentBranch <- Cli.getCurrentProjectRoot0 + let projectNames = Branch.toNames currentBranch + projectNamesSansLib = Branch.toNames (Branch.deleteLibdeps currentBranch) -- get only once for the entire deletion set let allTermsToDelete :: Set LabeledDependency allTermsToDelete = Set.unions (fmap Names.labeledReferences toDelete) @@ -1493,9 +1459,7 @@ checkDeletes typesTermsTuples doutput inputs = do endangered <- Cli.runTransaction $ traverse - ( \targetToDelete -> - getEndangeredDependents targetToDelete (allTermsToDelete) projectNames - ) + (\targetToDelete -> getEndangeredDependents targetToDelete allTermsToDelete projectNames projectNamesSansLib) toDelete -- If the overall dependency map is not completely empty, abort deletion let endangeredDeletions = List.filter (\m -> not $ null m || Map.foldr (\s b -> null s || b) False m) endangered @@ -1523,54 +1487,6 @@ checkDeletes typesTermsTuples doutput inputs = do let combineRefs = List.foldl (Map.unionWith NESet.union) Map.empty endangeredDeletions Cli.respondNumbered (CantDeleteDefinitions ppeDecl combineRefs) --- | Goal: When deleting, we might be removing the last name of a given definition (i.e. the --- definition is going "extinct"). In this case we may wish to take some action or warn the --- user about these "endangered" definitions which would now contain unnamed references. --- The argument `otherDesiredDeletions` is included in this function because the user might want to --- delete a term and all its dependencies in one command, so we give this function access to --- the full set of entities that the user wishes to delete. -getEndangeredDependents :: - -- | Prospective target for deletion - Names -> - -- | All entities we want to delete (including the target) - Set LabeledDependency -> - -- | Names from the current branch - Names -> - -- | map from references going extinct to the set of endangered dependents - Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency)) -getEndangeredDependents targetToDelete otherDesiredDeletions rootNames = do - -- names of terms left over after target deletion - let remainingNames :: Names - remainingNames = rootNames `Names.difference` targetToDelete - -- target refs for deletion - let refsToDelete :: Set LabeledDependency - refsToDelete = Names.labeledReferences targetToDelete - -- refs left over after deleting target - let remainingRefs :: Set LabeledDependency - remainingRefs = Names.labeledReferences remainingNames - -- remove the other targets for deletion from the remaining terms - let remainingRefsWithoutOtherTargets :: Set LabeledDependency - remainingRefsWithoutOtherTargets = Set.difference remainingRefs otherDesiredDeletions - -- deleting and not left over - let extinct :: Set LabeledDependency - extinct = refsToDelete `Set.difference` remainingRefs - let accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency)) - accumulateDependents ld = - let ref = LD.fold id Referent.toReference ld - in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents Queries.ExcludeOwnComponent ref - -- All dependents of extinct, including terms which might themselves be in the process of being deleted. - allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <- - Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents - - -- Filtered to only include dependencies which are not being deleted, but depend one which - -- is going extinct. - let extinctToEndangered :: Map LabeledDependency (NESet LabeledDependency) - extinctToEndangered = - allDependentsOfExtinct & Map.mapMaybe \endangeredDeps -> - let remainingEndangered = endangeredDeps `Set.intersection` remainingRefsWithoutOtherTargets - in NESet.nonEmptySet remainingEndangered - pure extinctToEndangered - displayI :: OutputLocation -> HQ.HashQualified Name -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs new file mode 100644 index 0000000000..14281adc33 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteNamespace.hs @@ -0,0 +1,134 @@ +module Unison.Codebase.Editor.HandleInput.DeleteNamespace + ( handleDeleteNamespace, + getEndangeredDependents, + ) +where + +import Control.Lens hiding (from) +import Control.Lens qualified as Lens +import Control.Monad.State qualified as State +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as NESet +import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Branch qualified as Branch +import Unison.Codebase.Branch.Names qualified as Branch +import Unison.Codebase.Editor.Input +import Unison.Codebase.Editor.Output +import Unison.Codebase.Path (Path) +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as ProjectPath +import Unison.LabeledDependency (LabeledDependency) +import Unison.LabeledDependency qualified as LD +import Unison.NameSegment qualified as NameSegment +import Unison.Names (Names) +import Unison.Names qualified as Names +import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl.Names qualified as PPED +import Unison.Referent qualified as Referent +import Unison.Sqlite qualified as Sqlite + +handleDeleteNamespace :: Input -> Insistence -> Maybe (Path, NameSegment.NameSegment) -> Cli () +handleDeleteNamespace input insistence = \case + Nothing -> do + loopState <- State.get + if loopState.lastInput == Just input || insistence == Force + then do + pp <- Cli.getCurrentProjectPath + _ <- Cli.updateAt (commandName <> " .") pp (const Branch.empty) + Cli.respond DeletedEverything + else Cli.respond DeleteEverythingConfirmation + Just p@(parentPath, childName) -> do + branch <- Cli.expectBranchAtPath (Path.unsplit p) + let toDelete = + Names.prefix0 + (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p) + (Branch.toNames (Branch.head branch)) + afterDelete <- do + currentBranch <- Cli.getCurrentProjectRoot0 + let names = Branch.toNames currentBranch + namesSansLib = Branch.toNames (Branch.deleteLibdeps currentBranch) + endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names namesSansLib) + case (null endangerments, insistence) of + (True, _) -> pure (Cli.respond Success) + (False, Force) -> do + let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + pure do + Cli.respond Success + Cli.respondNumbered $ DeletedDespiteDependents ppeDecl endangerments + (False, Try) -> do + let ppeDecl = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) + Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments + Cli.returnEarlyWithoutOutput + parentPathAbs <- Cli.resolvePath parentPath + let description = commandName <> " " <> into @Text (parentPathAbs & ProjectPath.absPath_ %~ (`Lens.snoc` childName)) + -- We have to modify the parent in order to also wipe out the history at the + -- child. + Cli.updateAt description parentPathAbs (Branch.modifyAt (Path.singleton childName) \_ -> Branch.empty) + afterDelete + where + commandName :: Text + commandName = + case insistence of + Try -> "delete.namespace" + Force -> "delete.namespace.force" + +-- How I might do it (is this any better than the current algorithm?) +-- +-- 1. Get all direct dependents of the deleted things in the current namespace. +-- 2. For each direct dependent, check a Names built from the deleted namespace – is it there? If not it's the last +-- name. + +-- | Goal: When deleting, we might be removing the last name of a given definition (i.e. the +-- definition is going "extinct"). In this case we may wish to take some action or warn the +-- user about these "endangered" definitions which would now contain unnamed references. +-- The argument `otherDesiredDeletions` is included in this function because the user might want to +-- delete a term and all its dependencies in one command, so we give this function access to +-- the full set of entities that the user wishes to delete. +getEndangeredDependents :: + -- | Prospective target for deletion + Names -> + -- | All entities we want to delete (including the target) + Set LabeledDependency -> + -- | Names from the current branch + Names -> + -- | Names from the current branch, sans `lib` + Names -> + -- | map from references going extinct to the set of endangered dependents + Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency)) +getEndangeredDependents targetToDelete otherDesiredDeletions rootNames rootNamesSansLib = do + -- deleting and not left over + let extinct :: Set LabeledDependency + extinct = Names.labeledReferences targetToDelete `Set.difference` refsAfterDeletingTarget rootNames + + let accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency)) + accumulateDependents ld = + let ref = LD.fold id Referent.toReference ld + in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents Queries.ExcludeOwnComponent ref + + -- All dependents of extinct, including terms which might themselves be in the process of being deleted. + allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <- + Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents + + -- Of all the dependents of things going extinct, we filter down to only those that are not themselves being deleted + -- too (per `otherDesiredDeletion`), and are also somewhere outside `lib`. This allows us to proceed with deleting + -- an entire dependency out of `lib` even if for some reason it contains the only source of names for some other + -- dependency. + let extinctToEndangered :: Map LabeledDependency (NESet LabeledDependency) + extinctToEndangered = + Map.mapMaybe + ( NESet.nonEmptySet + . Set.intersection (Set.difference (refsAfterDeletingTarget rootNamesSansLib) otherDesiredDeletions) + ) + allDependentsOfExtinct + pure extinctToEndangered + where + refsAfterDeletingTarget :: Names -> Set LabeledDependency + refsAfterDeletingTarget names = + Names.labeledReferences (names `Names.difference` targetToDelete) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 51f1087988..64ca37846e 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -56,6 +56,7 @@ library Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DebugSynhashTerm Unison.Codebase.Editor.HandleInput.DeleteBranch + Unison.Codebase.Editor.HandleInput.DeleteNamespace Unison.Codebase.Editor.HandleInput.DeleteProject Unison.Codebase.Editor.HandleInput.EditNamespace Unison.Codebase.Editor.HandleInput.FindAndReplace diff --git a/unison-src/transcripts/fix-5446.md b/unison-src/transcripts/fix-5446.md new file mode 100644 index 0000000000..344da5279e --- /dev/null +++ b/unison-src/transcripts/fix-5446.md @@ -0,0 +1,18 @@ +Previously `delete.namespace` would refuse to delete a namespace if it would leave any nameless references in `lib`. + +```ucm:hide +scratch/main> builtins.merge lib.builtin +``` + +```unison +lib.one.foo = 17 +lib.two.bar = foo Nat.+ foo +``` + +```ucm +scratch/main> add +``` + +```ucm +scratch/main> delete.namespace lib.one +``` diff --git a/unison-src/transcripts/fix-5446.output.md b/unison-src/transcripts/fix-5446.output.md new file mode 100644 index 0000000000..1746d3fd5d --- /dev/null +++ b/unison-src/transcripts/fix-5446.output.md @@ -0,0 +1,36 @@ +Previously `delete.namespace` would refuse to delete a namespace if it would leave any nameless references in `lib`. + +``` unison +lib.one.foo = 17 +lib.two.bar = foo Nat.+ foo +``` + +``` ucm + + Loading changes detected in scratch.u. + + 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`: + + lib.one.foo : Nat + lib.two.bar : Nat + +``` +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + lib.one.foo : Nat + lib.two.bar : Nat + +``` +``` ucm +scratch/main> delete.namespace lib.one + + Done. + +```