Merge pull request #2652 from unisonweb/cp/namespace.delete.force

Add delete.namespace.force

parser-typechecker/src/Unison/PrettyPrintEnv.hs

@@ -6,6 +6,7 @@ module Unison.PrettyPrintEnv
     patternName,
     termName,
     typeName,
+    labeledRefName,
     -- | Exported only for cases where the codebase's configured hash length is unavailable.
     todoHashLength,
   )
@@ -22,6 +23,8 @@ import           Unison.Referent                ( Referent )
 import qualified Unison.HashQualified          as HQ
 import qualified Unison.Referent               as Referent
 import qualified Unison.ConstructorType as CT
+import Unison.LabeledDependency (LabeledDependency)
+import qualified Unison.LabeledDependency as LD
 
 data PrettyPrintEnv = PrettyPrintEnv {
   -- names for terms, constructors, and requests
@@ -58,6 +61,12 @@ typeName env r =
     Nothing -> HQ.take todoHashLength (HQ.fromReference r)
     Just name -> HQ'.toHQ name
 
+-- | Get a name for a LabeledDependency from the PPE.
+labeledRefName :: PrettyPrintEnv -> LabeledDependency -> HashQualified Name
+labeledRefName ppe = \case
+  LD.TermReferent ref -> termName ppe ref
+  LD.TypeReference ref -> typeName ppe ref
+
 patternName :: PrettyPrintEnv -> ConstructorReference -> HashQualified Name
 patternName env r =
   case patterns env r of

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -83,6 +83,7 @@ import Unison.Runtime.Pattern
 import Unison.Runtime.Serialize as SER
 import Unison.Runtime.Stack
 import qualified Unison.Hashing.V2.Convert as Hashing
+import qualified Unison.ConstructorReference as RF
 
 type Term v = Tm.Term v ()
 
@@ -148,25 +149,31 @@ recursiveDeclDeps seen0 cl d = do
 
 categorize :: RF.LabeledDependency -> (Set Reference, Set Reference)
 categorize
-  = either ((,mempty) . singleton) ((mempty,) . singleton)
-  . RF.toReference
+  = \case
+      RF.TypeReference ref -> (Set.singleton ref, mempty)
+      RF.ConReference (RF.ConstructorReference ref _conId) _conType -> (Set.singleton ref, mempty)
+      RF.TermReference ref -> (mempty, Set.singleton ref)
 
-recursiveTermDeps
-  :: Set RF.LabeledDependency
-  -> CodeLookup Symbol IO ()
-  -> Term Symbol
-  -> IO (Set Reference, Set Reference)
+recursiveTermDeps ::
+  Set RF.LabeledDependency ->
+  CodeLookup Symbol IO () ->
+  Term Symbol ->
+  IO (Set Reference, Set Reference)
 recursiveTermDeps seen0 cl tm = do
-    rec <- for (RF.toReference <$> toList (deps \\ seen0)) $ \case
-      Left (RF.DerivedId i) -> getTypeDeclaration cl i >>= \case
+  rec <- for (toList (deps \\ seen0)) $ \case
+    RF.ConReference (RF.ConstructorReference (RF.DerivedId refId) _conId)  _conType -> handleTypeReferenceId refId
+    RF.TypeReference (RF.DerivedId refId) -> handleTypeReferenceId refId
+    RF.TermReference r -> recursiveRefDeps seen cl r
+    _ -> pure mempty
+  pure $ foldMap categorize deps <> fold rec
+  where
+    handleTypeReferenceId :: RF.Id -> IO (Set Reference, Set Reference)
+    handleTypeReferenceId refId =
+      getTypeDeclaration cl refId >>= \case
         Just d -> recursiveDeclDeps seen cl d
         Nothing -> pure mempty
-      Right r -> recursiveRefDeps seen cl r
-      _ -> pure mempty
-    pure $ foldMap categorize deps <> fold rec
-  where
-  deps = Tm.labeledDependencies tm
-  seen = seen0 <> deps
+    deps = Tm.labeledDependencies tm
+    seen = seen0 <> deps
 
 recursiveRefDeps
   :: Set RF.LabeledDependency

unison-cli/package.yaml

@@ -16,6 +16,7 @@ dependencies:
   - bytestring
   - configurator
   - containers >= 0.6.3
+  - nonempty-containers
   - cryptonite
   - directory
   - errors

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -140,6 +140,8 @@ import qualified Unison.WatchKind as WK
 import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
 import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', eval)
 import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
+import qualified Data.Set.NonEmpty as NESet
+import Data.Set.NonEmpty (NESet)
 
 defaultPatchNameSegment :: NameSegment
 defaultPatchNameSegment = "patch"
@@ -276,8 +278,7 @@ loop = do
         then modifying LoopState.latestFile (fmap (const False) <$>)
         else loadUnisonFile sourceName text
     Right input ->
-      let ifConfirmed = ifM (confirmedCommand input)
-          branchNotFound = respond . BranchNotFound
+      let branchNotFound = respond . BranchNotFound
           branchNotFound' = respond . BranchNotFound . Path.unsplit'
           patchNotFound :: Path.Split' -> Action' m v ()
           patchNotFound s = respond $ PatchNotFound s
@@ -354,7 +355,8 @@ loop = do
             DeleteI thing -> "delete " <> hqs' thing
             DeleteTermI def -> "delete.term " <> hqs' def
             DeleteTypeI def -> "delete.type " <> hqs' def
-            DeleteBranchI opath -> "delete.namespace " <> ops' opath
+            DeleteBranchI Try opath -> "delete.namespace " <> ops' opath
+            DeleteBranchI Force opath -> "delete.namespace.force " <> ops' opath
             DeletePatchI path -> "delete.patch " <> ps' path
             ReplaceI src target p ->
               "replace " <> HQ.toText src <> " "
@@ -460,14 +462,6 @@ loop = do
           unlessGitError = unlessError' Output.GitError
           importRemoteBranch ns mode = ExceptT . eval $ ImportRemoteBranch ns mode
           loadSearchResults = eval . LoadSearchResults
-          handleFailedDelete failed failedDependents = do
-            failed <- loadSearchResults $ SR.fromNames failed
-            failedDependents <- loadSearchResults $ SR.fromNames failedDependents
-            ppe <-
-              fqnPPE
-                =<< makePrintNamesFromLabeled'
-                  (foldMap SR'.labeledDependencies $ failed <> failedDependents)
-            respond $ CantDelete ppe failed failedDependents
           saveAndApplyPatch patchPath'' patchName patch' = do
             stepAtM
               (inputDescription <> " (1/2)")
@@ -593,9 +587,9 @@ loop = do
                     toRel = R.fromList . fmap (name,) . toList
                     -- these names are relative to the root
                     toDelete = Names (toRel tms) (toRel tys)
-                (failed, failedDependents) <-
+                endangerments <-
                   getEndangeredDependents (eval . GetDependents) toDelete rootNames
-                if failed == mempty
+                if null endangerments
                   then do
                     let makeDeleteTermNames = fmap (BranchUtil.makeDeleteTermName resolvedPath) . toList $ tms
                     let makeDeleteTypeNames = fmap (BranchUtil.makeDeleteTypeName resolvedPath) . toList $ tys
@@ -603,7 +597,9 @@ loop = do
                     root'' <- use LoopState.root
                     diffHelper (Branch.head root') (Branch.head root'')
                       >>= respondNumbered . uncurry ShowDiffAfterDeleteDefinitions
-                  else handleFailedDelete failed failedDependents
+                  else do
+                    ppeDecl <- currentPrettyPrintEnvDecl
+                    respondNumbered $ CantDeleteDefinitions ppeDecl endangerments
        in case input of
             CreateMessage pretty ->
               respond $ PrintMessage pretty
@@ -787,35 +783,45 @@ loop = do
                 Just _ -> do
                   stepAt (BranchUtil.makeDeletePatch (resolveSplit' src))
                   success
-            DeleteBranchI Nothing ->
-              ifConfirmed
-                ( do
-                    stepAt (Path.empty, const Branch.empty0)
-                    respond DeletedEverything
-                )
-                (respond DeleteEverythingConfirmation)
-            DeleteBranchI (Just p) ->
-              maybe (branchNotFound' p) go $ getAtSplit' p
+            DeleteBranchI insistence Nothing -> do
+              hasConfirmed <- confirmedCommand input
+              if (hasConfirmed || insistence == Force)
+                then do stepAt (Path.empty, const Branch.empty0)
+                        respond DeletedEverything
+                else respond DeleteEverythingConfirmation
+            DeleteBranchI insistence (Just p) -> do
+              case getAtSplit' p of
+                Nothing -> branchNotFound' p
+                Just (Branch.head -> b0) -> do
+                  endangerments <- computeEndangerments b0
+                  if null endangerments
+                     then doDelete b0
+                     else case insistence of
+                       Force -> do
+                         ppeDecl <- currentPrettyPrintEnvDecl
+                         doDelete b0
+                         respondNumbered $ DeletedDespiteDependents ppeDecl endangerments
+                       Try -> do
+                         ppeDecl <- currentPrettyPrintEnvDecl
+                         respondNumbered $ CantDeleteNamespace ppeDecl endangerments
               where
-                go (Branch.head -> b) = do
-                  (failed, failedDependents) <-
-                    let rootNames = Branch.toNames root0
-                        toDelete =
-                          Names.prefix0
-                            (Path.toName . Path.unsplit . resolveSplit' $ p) -- resolveSplit' incorporates currentPath
-                            (Branch.toNames b)
-                     in getEndangeredDependents (eval . GetDependents) toDelete rootNames
-                  if failed == mempty
-                    then do
+                doDelete b0 = do
                       stepAt $ BranchUtil.makeSetBranch (resolveSplit' p) Branch.empty
                       -- Looks similar to the 'toDelete' above... investigate me! ;)
-                      diffHelper b Branch.empty0
+                      diffHelper b0 Branch.empty0
                         >>= respondNumbered
                           . uncurry
                             ( ShowDiffAfterDeleteBranch $
                                 resolveToAbsolute (Path.unsplit' p)
                             )
-                    else handleFailedDelete failed failedDependents
+                computeEndangerments :: Branch0 m1 -> Action' m v (Map LabeledDependency (NESet LabeledDependency))
+                computeEndangerments b0 = do
+                  let rootNames = Branch.toNames root0
+                      toDelete =
+                        Names.prefix0
+                          (Path.toName . Path.unsplit . resolveSplit' $ p) -- resolveSplit' incorporates currentPath
+                          (Branch.toNames b0)
+                  getEndangeredDependents (eval . GetDependents) toDelete rootNames
             SwitchBranchI maybePath' -> do
               mpath' <- case maybePath' of
                 Nothing ->
@@ -1503,20 +1509,6 @@ loop = do
                 let m = Map.fromList computedTests
                 respond $ TestResults Output.NewlyComputed ppe showOk showFail (oks m) (fails m)
 
-            -- ListBranchesI ->
-            --   eval ListBranches >>= respond . ListOfBranches currentBranchName'
-            -- DeleteBranchI branchNames -> withBranches branchNames $ \bnbs -> do
-            --   uniqueToDelete <- prettyUniqueDefinitions bnbs
-            --   let deleteBranches b =
-            --         traverse (eval . DeleteBranch) b >> respond (Success input)
-            --   if (currentBranchName' `elem` branchNames)
-            --     then respond DeletingCurrentBranch
-            --     else if null uniqueToDelete
-            --       then deleteBranches branchNames
-            --       else ifM (confirmedCommand input)
-            --                (deleteBranches branchNames)
-            --                (respond . DeleteBranchConfirmation $ uniqueToDelete)
-
             PropagatePatchI patchPath scopePath -> do
               patch <- getPatchAt patchPath
               updated <- propagatePatch inputDescription patch (resolveToAbsolute scopePath)
@@ -2560,37 +2552,42 @@ zeroOneOrMore f zero one more = case toList f of
   a : _ -> one a
   _ -> zero
 
--- Goal: If `remaining = root - toBeDeleted` contains definitions X which
--- depend on definitions Y not in `remaining` (which should also be in
--- `toBeDeleted`), then complain by returning (Y, X).
+-- | 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.
 getEndangeredDependents ::
   forall m.
   Monad m =>
+  -- | Function to acquire dependencies
   (Reference -> m (Set Reference)) ->
+  -- | Which names we want to delete
   Names ->
+  -- | All names from the root branch
   Names ->
-  m (Names, Names)
-getEndangeredDependents getDependents toDelete root = do
-  let remaining = root `Names.difference` toDelete
-      toDelete', remaining', extinct :: Set Reference
-      toDelete' = Names.allReferences toDelete
-      remaining' = Names.allReferences remaining -- left over after delete
-      extinct = toDelete' `Set.difference` remaining' -- deleting and not left over
-      accumulateDependents m r = getDependents r <&> \ds -> Map.insert r ds m
-  dependentsOfExtinct :: Map Reference (Set Reference) <-
-    foldM accumulateDependents mempty extinct
-  let orphaned, endangered, failed :: Set Reference
-      orphaned = fold dependentsOfExtinct
-      endangered = orphaned `Set.intersection` remaining'
-      failed = Set.filter hasEndangeredDependent extinct
-      hasEndangeredDependent r =
-        any
-          (`Set.member` endangered)
-          (dependentsOfExtinct Map.! r)
-  pure
-    ( Names.restrictReferences failed toDelete,
-      Names.restrictReferences endangered root `Names.difference` toDelete
-    )
+  -- | map from references going extinct to the set of endangered dependents
+  m (Map LabeledDependency (NESet LabeledDependency))
+getEndangeredDependents getDependents namesToDelete rootNames = do
+  let remainingNames :: Names
+      remainingNames = rootNames `Names.difference` namesToDelete
+      refsToDelete, remainingRefs, extinct :: Set LabeledDependency
+      refsToDelete = Names.labeledReferences namesToDelete
+      remainingRefs = Names.labeledReferences remainingNames -- left over after delete
+      extinct = refsToDelete `Set.difference` remainingRefs -- deleting and not left over
+      accumulateDependents :: LabeledDependency -> m (Map LabeledDependency (Set LabeledDependency))
+      accumulateDependents ld =
+        let ref = LD.fold id Referent.toReference ld
+         in Map.singleton ld . Set.map LD.termRef <$> getDependents 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` remainingRefs
+         in NESet.nonEmptySet remainingEndangered
+  pure extinctToEndangered
 
 -- Applies the selection filter to the adds/updates of a slurp result,
 -- meaning that adds/updates should only contain the selection or its transitive

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -5,6 +5,7 @@ module Unison.Codebase.Editor.Input
   , PatchPath
   , BranchId, parseBranchId
   , HashOrHQSplit'
+  , Insistence(..)
   ) where
 
 import Unison.Prelude
@@ -39,6 +40,10 @@ type PatchPath = Path.Split'
 type BranchId = Either ShortBranchHash Path'
 type HashOrHQSplit' = Either ShortHash Path.HQSplit'
 
+-- | Should we force the operation or not?
+data Insistence = Force | Try
+  deriving (Show, Eq)
+
 parseBranchId :: String -> Either String BranchId
 parseBranchId ('#':s) = case SBH.fromText (Text.pack s) of
   Nothing -> Left "Invalid hash, expected a base32hex string."
@@ -87,7 +92,7 @@ data Input
     | DeleteI Path.HQSplit'
     | DeleteTermI Path.HQSplit'
     | DeleteTypeI Path.HQSplit'
-    | DeleteBranchI (Maybe Path.Split')
+    | DeleteBranchI Insistence (Maybe Path.Split')
     | DeletePatchI Path.Split'
     -- resolving naming conflicts within `branchpath`
       -- Add the specified name after deleting all others for a given reference

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -60,6 +60,7 @@ import qualified Unison.UnisonFile as UF
 import qualified Unison.Util.Pretty as P
 import Unison.Util.Relation (Relation)
 import qualified Unison.WatchKind as WK
+import Data.Set.NonEmpty (NESet)
 
 type ListDetailed = Bool
 
@@ -87,6 +88,12 @@ data NumberedOutput v
   | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
   | -- <authorIdentifier> <authorPath> <relativeBase>
     ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
+  | -- | CantDeleteDefinitions ppe couldntDelete becauseTheseStillReferenceThem
+    CantDeleteDefinitions PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency))
+  | -- | CantDeleteNamespace ppe couldntDelete becauseTheseStillReferenceThem
+    CantDeleteNamespace PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency))
+  | -- | DeletedDespiteDependents ppe deletedThings thingsWhichNowHaveUnnamedReferences
+    DeletedDespiteDependents PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency))
 
 --  | ShowDiff
 
@@ -136,8 +143,6 @@ data Output v
     -- the path is deleted.
     DeleteBranchConfirmation
       [(Path', (Names, [SearchResult' v Ann]))]
-  | -- CantDelete input couldntDelete becauseTheseStillReferenceThem
-    CantDelete PPE.PrettyPrintEnv [SearchResult' v Ann] [SearchResult' v Ann]
   | DeleteEverythingConfirmation
   | DeletedEverything
   | ListNames
@@ -294,7 +299,6 @@ isFailure o = case o of
   TypeTermMismatch {} -> True
   SearchTermsNotFound ts -> not (null ts)
   DeleteBranchConfirmation {} -> False
-  CantDelete {} -> True
   DeleteEverythingConfirmation -> False
   DeletedEverything -> False
   ListNames _ tys tms -> null tms && null tys
@@ -365,3 +369,6 @@ isNumberedFailure = \case
   ShowDiffAfterPull {} -> False
   ShowDiffAfterCreatePR {} -> False
   ShowDiffAfterCreateAuthor {} -> False
+  CantDeleteDefinitions {} -> True
+  CantDeleteNamespace {} -> True
+  DeletedDespiteDependents {} -> False

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -704,22 +704,36 @@ back =
         _ -> Left (I.help cd)
     )
 
-deleteBranch :: InputPattern
-deleteBranch =
+deleteNamespace :: InputPattern
+deleteNamespace =
   InputPattern
     "delete.namespace"
     []
     [(Required, namespaceArg)]
     "`delete.namespace <foo>` deletes the namespace `foo`"
+    (deleteNamespaceParser (I.help deleteNamespace) Input.Try)
+
+deleteNamespaceForce :: InputPattern
+deleteNamespaceForce =
+  InputPattern
+    "delete.namespace.force"
+    []
+    [(Required, namespaceArg)]
+    ("`delete.namespace.force <foo>` deletes the namespace `foo`,"
+    <> "deletion will proceed even if other code depends on definitions in foo.")
+    (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force)
+
+deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input
+deleteNamespaceParser helpText insistence =
     ( \case
         ["."] ->
           first fromString
             . pure
-            $ Input.DeleteBranchI Nothing
+            $ Input.DeleteBranchI insistence Nothing
         [p] -> first fromString $ do
           p <- Path.parseSplit' Path.definitionNameSegment p
-          pure . Input.DeleteBranchI $ Just p
-        _ -> Left (I.help deleteBranch)
+          pure . Input.DeleteBranchI insistence $ Just p
+        _ -> Left helpText
     )
 
 deletePatch :: InputPattern
@@ -1824,7 +1838,8 @@ validInputs =
     cd,
     up,
     back,
-    deleteBranch,
+    deleteNamespace,
+    deleteNamespaceForce,
     renameBranch,
     deletePatch,
     renamePatch,

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -16,6 +16,7 @@ import Data.List.Extra (notNull, nubOrd, nubOrdOn)
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
+import Data.Set.NonEmpty (NESet)
 import qualified Data.Text as Text
 import Data.Text.IO (readFile, writeFile)
 import Data.Tuple (swap)
@@ -305,6 +306,33 @@ notifyNumbered o = case o of
             ]
       )
       (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+  CantDeleteDefinitions ppeDecl endangerments ->
+    (P.warnCallout $
+      P.lines
+        [ P.wrap "I didn't delete the following definitions because they are still in use:",
+          "",
+          endangeredDependentsTable ppeDecl endangerments
+        ]
+    , numberedArgsForEndangerments ppeDecl endangerments)
+  CantDeleteNamespace ppeDecl endangerments ->
+    (P.warnCallout $
+      P.lines
+        [ P.wrap "I didn't delete the namespace because the following definitions are still in use.",
+          "",
+          endangeredDependentsTable ppeDecl endangerments,
+          "",
+          P.wrap "If you want to proceed anyways and leave those definitions without names, use"
+            <> IP.patternName IP.deleteNamespaceForce
+        ]
+    , numberedArgsForEndangerments ppeDecl endangerments)
+  DeletedDespiteDependents ppeDecl endangerments ->
+    (P.warnCallout $
+      P.lines
+        [ P.wrap "Of the things I deleted, the following are still used in the following definitions. They now contain un-named references.",
+          "",
+          endangeredDependentsTable ppeDecl endangerments
+        ]
+    , numberedArgsForEndangerments ppeDecl endangerments)
   where
     e = Path.absoluteEmpty
     undoTip =
@@ -553,17 +581,6 @@ notifyUser dir o = case o of
     pure . P.warnCallout $
       "I was expecting the namespace " <> prettyPath' path
         <> " to be empty for this operation, but it isn't."
-  CantDelete ppe failed failedDependents ->
-    pure . P.warnCallout $
-      P.lines
-        [ P.wrap "I couldn't delete ",
-          "",
-          P.indentN 2 $ listOfDefinitions' ppe False failed,
-          "",
-          "because it's still being used by these definitions:",
-          "",
-          P.indentN 2 $ listOfDefinitions' ppe False failedDependents
-        ]
   CantUndo reason -> case reason of
     CantUndoPastStart -> pure . P.warnCallout $ "Nothing more to undo."
     CantUndoPastMerge -> pure . P.warnCallout $ "Sorry, I can't undo a merge (not implemented yet)."
@@ -2539,6 +2556,11 @@ prettyTermName ppe r =
   P.syntaxToColor $
     prettyHashQualified (PPE.termName ppe r)
 
+prettyTypeName :: PPE.PrettyPrintEnv -> Reference -> Pretty
+prettyTypeName ppe r =
+  P.syntaxToColor $
+    prettyHashQualified (PPE.typeName ppe r)
+
 prettyReadRepo :: ReadRepo -> Pretty
 prettyReadRepo (RemoteRepo.ReadGitRepo url) = P.blue (P.text url)
 
@@ -2554,3 +2576,53 @@ isTestOk tm = case tm of
           && ref == DD.testResultRef
       isSuccess _ = False
   _ -> False
+
+-- | Get the list of numbered args corresponding to an endangerment map, which is used by a
+-- few outputs. See 'endangeredDependentsTable'.
+numberedArgsForEndangerments ::
+  PPE.PrettyPrintEnvDecl ->
+  Map LabeledDependency (NESet LabeledDependency) ->
+  NumberedArgs
+numberedArgsForEndangerments (PPE.unsuffixifiedPPE -> ppe) m =
+  m
+    & Map.elems
+    & concatMap toList
+    & fmap (HQ.toString . PPE.labeledRefName ppe)
+
+-- | Format and render all dependents which are endangered by references going extinct.
+endangeredDependentsTable ::
+  PPE.PrettyPrintEnvDecl ->
+  Map LabeledDependency (NESet LabeledDependency) ->
+  P.Pretty P.ColorText
+endangeredDependentsTable ppeDecl m =
+  m
+    & Map.toList
+    & fmap (second toList)
+    & numberDependents
+    & map
+      ( \(dependency, dependents) ->
+          (prettyLabeled suffixifiedEnv dependency, prettyDependents dependents)
+      )
+    & List.intersperse spacer
+    & P.column2Header "Dependency" "Referenced In"
+  where
+    numberDependents :: [(x, [LabeledDependency])] -> [(x, [(Int, LabeledDependency)])]
+    numberDependents xs =
+      let (_acc, numbered) =
+            mapAccumLOf
+              (traversed . _2 . traversed)
+              (\n ld -> (n + 1, (n, ld)))
+              1
+              xs
+       in numbered
+    spacer = ("", "")
+    suffixifiedEnv = (PPE.suffixifiedPPE ppeDecl)
+    fqnEnv = (PPE.unsuffixifiedPPE ppeDecl)
+    prettyLabeled ppe = \case
+      LD.TermReferent ref -> prettyTermName ppe ref
+      LD.TypeReference ref -> prettyTypeName ppe ref
+    numArg = (\n -> P.hiBlack . fromString $ show n <> ". ")
+    prettyDependents refs =
+      refs
+        & fmap (\(n, dep) -> numArg n <> prettyLabeled fqnEnv dep)
+        & P.lines

unison-cli/unison-cli.cabal

@@ -93,6 +93,7 @@ library
     , lens
     , megaparsec >=5.0.0 && <7.0.0
     , mtl
+    , nonempty-containers
     , open-browser
     , random >=1.2.0
     , regex-tdfa
@@ -158,6 +159,7 @@ executable integration-tests
     , lens
     , megaparsec >=5.0.0 && <7.0.0
     , mtl
+    , nonempty-containers
     , open-browser
     , process
     , random >=1.2.0
@@ -227,6 +229,7 @@ executable transcripts
     , lens
     , megaparsec >=5.0.0 && <7.0.0
     , mtl
+    , nonempty-containers
     , open-browser
     , process
     , random >=1.2.0
@@ -296,6 +299,7 @@ executable unison
     , lens
     , megaparsec >=5.0.0 && <7.0.0
     , mtl
+    , nonempty-containers
     , open-browser
     , optparse-applicative >=0.16.1.0
     , random >=1.2.0
@@ -376,6 +380,7 @@ test-suite tests
     , lens
     , megaparsec >=5.0.0 && <7.0.0
     , mtl
+    , nonempty-containers
     , open-browser
     , random >=1.2.0
     , regex-tdfa

unison-core/src/Unison/LabeledDependency.hs

@@ -10,50 +10,66 @@ module Unison.LabeledDependency
   , effectConstructor
   , fold
   , referents
-  , toReference
-  , LabeledDependency
+  , LabeledDependency(..)
+  , pattern ConReference
+  , pattern TermReference
   , partition
   ) where
 
 import Unison.Prelude hiding (fold)
 
-import Control.Lens ((^.))
 import Unison.ConstructorReference (ConstructorReference)
-import qualified Unison.ConstructorReference as ConstructorReference
 import Unison.ConstructorType (ConstructorType(Data, Effect))
 import Unison.Reference (Reference(DerivedId), Id)
-import Unison.Referent (Referent, pattern Ref, pattern Con)
+import Unison.Referent (Referent)
 import qualified Data.Set as Set
+import qualified Unison.Referent as Referent
 
--- dumb constructor name is private
-newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show)
+-- | A Union Type which contains either Type References or Term Referents.
+data LabeledDependency =
+    TypeReference Reference
+  | TermReferent Referent
+  deriving (Eq, Ord, Show)
+
+-- | Match on a TermReferent which is a Constructor.
+pattern ConReference :: ConstructorReference -> ConstructorType -> LabeledDependency
+pattern ConReference ref conType = TermReferent (Referent.Con ref conType)
+-- | Match on a TermReferent which is NOT a Constructor.
+pattern TermReference :: Reference -> LabeledDependency
+pattern TermReference ref = TermReferent (Referent.Ref ref)
+{-# COMPLETE ConReference, TermReference, TypeReference #-}
+
+
+derivedType :: Id -> LabeledDependency
+derivedType = TypeReference . DerivedId
+
+derivedTerm :: Id -> LabeledDependency
+derivedTerm = TermReference . DerivedId
+
+typeRef :: Reference -> LabeledDependency
+typeRef = TypeReference
+
+termRef :: Reference -> LabeledDependency
+termRef = TermReference
 
-derivedType, derivedTerm :: Id -> LabeledDependency
-typeRef, termRef :: Reference -> LabeledDependency
 referent :: Referent -> LabeledDependency
-dataConstructor :: ConstructorReference -> LabeledDependency
-effectConstructor :: ConstructorReference -> LabeledDependency
+referent = TermReferent
 
-derivedType = X . Left . DerivedId
-derivedTerm = X . Right . Ref . DerivedId
-typeRef = X . Left
-termRef = X . Right . Ref
-referent = X . Right
-dataConstructor r = X . Right $ Con r Data
-effectConstructor r = X . Right $ Con r Effect
+dataConstructor :: ConstructorReference -> LabeledDependency
+dataConstructor r = ConReference r Data
+
+effectConstructor :: ConstructorReference -> LabeledDependency
+effectConstructor r = ConReference r Effect
 
 referents :: Foldable f => f Referent -> Set LabeledDependency
 referents rs = Set.fromList (map referent $ toList rs)
 
 fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a
-fold f g (X e) = either f g e
+fold f _ (TypeReference r) = f r
+fold _ g (TermReferent r) = g r
 
 partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent])
-partition = partitionEithers . map (\(X e) -> e) . toList
-
--- | Left TypeRef | Right TermRef
-toReference :: LabeledDependency -> Either Reference Reference
-toReference = \case
-  X (Left r)             -> Left r
-  X (Right (Ref r))     -> Right r
-  X (Right (Con r _)) -> Left (r ^. ConstructorReference.reference_)
+partition =
+  foldMap \case
+    TypeReference ref -> ([ref], [])
+    TermReferent ref -> ([], [ref])

unison-core/src/Unison/Names.hs

@@ -8,7 +8,7 @@ module Unison.Names
   ( Names(..)
   , addTerm
   , addType
-  , allReferences
+  , labeledReferences
   , conflicts
   , contains
   , difference
@@ -73,6 +73,9 @@ import qualified Unison.ShortHash             as SH
 import           Unison.ShortHash             (ShortHash)
 import qualified Text.FuzzyFind               as FZF
 import qualified Unison.ConstructorType as CT
+import Unison.LabeledDependency (LabeledDependency)
+import qualified Unison.LabeledDependency as LD
+import qualified Unison.Util.Relation as Relation
 
 -- This will support the APIs of both PrettyPrintEnv and the old Names.
 -- For pretty-printing, we need to look up names for References.
@@ -146,10 +149,15 @@ fuzzyFind query names =
                          query
           )
 
-termReferences, typeReferences, allReferences :: Names -> Set Reference
+termReferences, typeReferences :: Names -> Set Reference
 termReferences Names{..} = Set.map Referent.toReference $ R.ran terms
 typeReferences Names{..} = R.ran types
-allReferences n = termReferences n <> typeReferences n
+
+-- | Collect all references in the given Names, tagged with their type.
+labeledReferences :: Names -> Set LabeledDependency
+labeledReferences Names{..} =
+  Set.map LD.typeRef (Relation.ran types)
+  <> Set.map LD.referent (Relation.ran terms)
 
 termReferents :: Names -> Set Referent
 termReferents Names{..} = R.ran terms

unison-src/transcripts/delete-namespace.md

@@ -0,0 +1,57 @@
+# delete.namespace.force
+
+```ucm:hide
+.> builtins.merge
+```
+
+```unison:hide
+no_dependencies.thing = "no dependents on this term"
+
+dependencies.term1 = 1
+dependencies.term2 = 2
+
+dependents.usage1 = dependencies.term1 + dependencies.term2
+dependents.usage2 = dependencies.term1 * dependencies.term2
+```
+
+```ucm:hide
+.> add
+```
+
+Deleting a namespace with no external dependencies should succeed.
+
+```ucm
+.> delete.namespace no_dependencies
+```
+
+Deleting a namespace with external dependencies should fail and list all dependents.
+
+```ucm:error
+.> delete.namespace dependencies
+```
+
+Deleting a namespace with external dependencies should succeed when using `delete.namespace.force`
+
+```ucm
+.> delete.namespace.force dependencies
+```
+
+I should be able to view an affected dependency by number
+
+```ucm
+.> view 2
+```
+
+Deleting the root namespace should require confirmation if not forced.
+
+```ucm
+.> delete.namespace .
+.> delete.namespace .
+```
+
+Deleting the root namespace shouldn't require confirmation if forced.
+
+```ucm
+.> delete.namespace.force .
+```
+

unison-src/transcripts/delete-namespace.output.md

@@ -0,0 +1,108 @@
+# delete.namespace.force
+
+```unison
+no_dependencies.thing = "no dependents on this term"
+
+dependencies.term1 = 1
+dependencies.term2 = 2
+
+dependents.usage1 = dependencies.term1 + dependencies.term2
+dependents.usage2 = dependencies.term1 * dependencies.term2
+```
+
+Deleting a namespace with no external dependencies should succeed.
+
+```ucm
+.> delete.namespace no_dependencies
+
+  Removed definitions:
+  
+    1. thing : Text
+  
+  Tip: You can use `undo` or `reflog` to undo this change.
+
+```
+Deleting a namespace with external dependencies should fail and list all dependents.
+
+```ucm
+.> delete.namespace dependencies
+
+  ⚠️
+  
+  I didn't delete the namespace because the following
+  definitions are still in use.
+  
+  Dependency   Referenced In
+  term2        1. dependents.usage2
+               2. dependents.usage1
+               
+  term1        3. dependents.usage2
+               4. dependents.usage1
+  
+  If you want to proceed anyways and leave those definitions
+  without names, usedelete.namespace.force
+
+```
+Deleting a namespace with external dependencies should succeed when using `delete.namespace.force`
+
+```ucm
+.> delete.namespace.force dependencies
+
+  Removed definitions:
+  
+    1. term1 : Nat
+    2. term2 : Nat
+  
+  Tip: You can use `undo` or `reflog` to undo this change.
+
+  ⚠️
+  
+  Of the things I deleted, the following are still used in the
+  following definitions. They now contain un-named references.
+  
+  Dependency   Referenced In
+  term2        1. dependents.usage2
+               2. dependents.usage1
+               
+  term1        3. dependents.usage2
+               4. dependents.usage1
+
+```
+I should be able to view an affected dependency by number
+
+```ucm
+.> view 2
+
+  dependents.usage1 : Nat
+  dependents.usage1 =
+    use Nat +
+    #jk19sm5bf8 + #0ja1qfpej6
+
+```
+Deleting the root namespace should require confirmation if not forced.
+
+```ucm
+.> delete.namespace .
+
+  ⚠️
+  
+  Are you sure you want to clear away everything?
+  You could use `namespace` to switch to a new namespace instead.
+
+.> delete.namespace .
+
+  Okay, I deleted everything except the history. Use `undo` to
+  undo, or `builtins.merge` to restore the absolute basics to
+  the current path.
+
+```
+Deleting the root namespace shouldn't require confirmation if forced.
+
+```ucm
+.> delete.namespace.force .
+
+  Okay, I deleted everything except the history. Use `undo` to
+  undo, or `builtins.merge` to restore the absolute basics to
+  the current path.
+
+```