Merge pull request #4477 from unisonweb/travis/move-all

unison-cli/src/Unison/Cli/MonadUtils.hs

@@ -51,6 +51,7 @@ module Unison.Cli.MonadUtils
     updateRoot,
     updateAtM,
     updateAt,
+    updateAndStepAt,
 
     -- * Terms
     getTermsAt,
@@ -87,6 +88,7 @@ import Control.Monad.Reader (ask)
 import Control.Monad.State
 import Data.Configurator qualified as Configurator
 import Data.Configurator.Types qualified as Configurator
+import Data.Foldable
 import Data.Set qualified as Set
 import U.Codebase.Branch qualified as V2 (Branch)
 import U.Codebase.Branch qualified as V2Branch
@@ -446,6 +448,19 @@ updateAt ::
 updateAt reason p f = do
   updateAtM reason p (pure . f)
 
+updateAndStepAt ::
+  (Foldable f, Foldable g) =>
+  Text ->
+  f (Path.Absolute, Branch IO -> Branch IO) ->
+  g (Path, Branch0 IO -> Branch0 IO) ->
+  Cli ()
+updateAndStepAt reason updates steps = do
+  root <-
+    (Branch.stepManyAt steps)
+      . (\root -> foldl' (\b (Path.Absolute p, f) -> Branch.modifyAt p f b) root updates)
+      <$> getRootBranch
+  updateRoot root reason
+
 updateRoot :: Branch IO -> Text -> Cli ()
 updateRoot new reason =
   Cli.time "updateRoot" do

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

@@ -71,7 +71,10 @@ import Unison.Codebase.Editor.HandleInput.Branches (handleBranches)
 import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
 import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
 import Unison.Codebase.Editor.HandleInput.MetadataUtils (addDefaultMetadata, manageLinks)
+import Unison.Codebase.Editor.HandleInput.MoveAll (handleMoveAll)
 import Unison.Codebase.Editor.HandleInput.MoveBranch (doMoveBranch)
+import Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm)
+import Unison.Codebase.Editor.HandleInput.MoveType (doMoveType)
 import Unison.Codebase.Editor.HandleInput.NamespaceDependencies qualified as NamespaceDependencies
 import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
 import Unison.Codebase.Editor.HandleInput.ProjectClone (handleClone)
@@ -783,58 +786,12 @@ loop e = do
                 d = Referent.Ref . Reference.DerivedId
                 base :: Path.Split' = (Path.relativeEmpty', "metadata")
                 authorPath' = base |> "authors" |> authorNameSegment
-            MoveTermI src' dest' -> do
-              src <- Cli.resolveSplit' src'
-              srcTerms <- Cli.getTermsAt src
-              srcTerm <-
-                Set.asSingleton srcTerms & onNothing do
-                  if Set.null srcTerms
-                    then Cli.returnEarly (TermNotFound src')
-                    else do
-                      hqLength <- Cli.runTransaction Codebase.hashLength
-                      Cli.returnEarly (DeleteNameAmbiguous hqLength src' srcTerms Set.empty)
-              dest <- Cli.resolveSplit' dest'
-              destTerms <- Cli.getTermsAt (Path.convert dest)
-              when (not (Set.null destTerms)) do
-                Cli.returnEarly (TermAlreadyExists dest' destTerms)
-              description <- inputDescription input
-              let p = Path.convert src
-              srcMetadata <- do
-                root0 <- Cli.getRootBranch0
-                pure (BranchUtil.getTermMetadataAt p srcTerm root0)
-              Cli.stepManyAt
-                description
-                [ -- Mitchell: throwing away any hash-qualification here seems wrong!
-                  BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
-                  BranchUtil.makeAddTermName (Path.convert dest) srcTerm srcMetadata
-                ]
-              Cli.respond Success
-            MoveTypeI src' dest' -> do
-              src <- Cli.resolveSplit' src'
-              srcTypes <- Cli.getTypesAt src
-              srcType <-
-                Set.asSingleton srcTypes & onNothing do
-                  if Set.null srcTypes
-                    then Cli.returnEarly (TypeNotFound src')
-                    else do
-                      hqLength <- Cli.runTransaction Codebase.hashLength
-                      Cli.returnEarly (DeleteNameAmbiguous hqLength src' Set.empty srcTypes)
-              dest <- Cli.resolveSplit' dest'
-              destTypes <- Cli.getTypesAt (Path.convert dest)
-              when (not (Set.null destTypes)) do
-                Cli.returnEarly (TypeAlreadyExists dest' destTypes)
-              description <- inputDescription input
-              let p = Path.convert src
-              srcMetadata <- do
-                root0 <- Cli.getRootBranch0
-                pure (BranchUtil.getTypeMetadataAt p srcType root0)
-              Cli.stepManyAt
-                description
-                [ -- Mitchell: throwing away any hash-qualification here seems wrong!
-                  BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
-                  BranchUtil.makeAddTypeName (Path.convert dest) srcType srcMetadata
-                ]
-              Cli.respond Success
+            MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input
+            MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input
+            MoveAllI src' dest' -> do
+              hasConfirmed <- confirmedCommand input
+              desc <- inputDescription input
+              handleMoveAll hasConfirmed src' dest' desc
             DeleteI dtarget -> case dtarget of
               DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs
               DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs
@@ -1477,6 +1434,10 @@ inputDescription input =
       src <- p' src0
       dest <- p' dest0
       pure ("move.namespace " <> src <> " " <> dest)
+    MoveAllI src0 dest0 -> do
+      src <- p' src0
+      dest <- p' dest0
+      pure ("move " <> src <> " " <> dest)
     MovePatchI src0 dest0 -> do
       src <- ps' src0
       dest <- ps' dest0
@@ -1861,7 +1822,7 @@ handleDependencies hq = do
   let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results)
   #numberedArgs
     .= map (Text.unpack . Reference.toText . snd) types
-      <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms
+    <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms
   Cli.respond $ ListDependencies ppe lds (fst <$> types) (fst <$> terms)
 
 handleDependents :: HQ.HashQualified Name -> Cli ()
@@ -2142,12 +2103,12 @@ handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do
           q r = \case
             Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) ->
               if
-                | ref == DD.testResultRef ->
-                    if
-                      | cid == DD.okConstructorId -> Just (Right (r, msg))
-                      | cid == DD.failConstructorId -> Just (Left (r, msg))
-                      | otherwise -> Nothing
-                | otherwise -> Nothing
+                  | ref == DD.testResultRef ->
+                      if
+                          | cid == DD.okConstructorId -> Just (Right (r, msg))
+                          | cid == DD.failConstructorId -> Just (Left (r, msg))
+                          | otherwise -> Nothing
+                  | otherwise -> Nothing
             _ -> Nothing
   let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests)
   names <-

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

@@ -0,0 +1,27 @@
+module Unison.Codebase.Editor.HandleInput.MoveAll (handleMoveAll) where
+
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Cli.MonadUtils qualified as Cli
+import Unison.Codebase.Editor.Output qualified as Output
+import Unison.Codebase.Path qualified as Path
+import Unison.HashQualified' qualified as HQ'
+import Unison.Prelude
+import Unison.Codebase.Editor.HandleInput.MoveBranch (moveBranchFunc)
+import Unison.Codebase.Editor.HandleInput.MoveTerm (moveTermSteps)
+import Unison.Codebase.Editor.HandleInput.MoveType (moveTypeSteps)
+
+handleMoveAll :: Bool -> Path.Path' -> Path.Path' -> Text -> Cli ()
+handleMoveAll hasConfirmed src' dest' description = do
+  moveBranchFunc <- moveBranchFunc hasConfirmed src' dest'
+  moveTermTypeSteps <- case (,) <$> Path.toSplit' src' <*> Path.toSplit' dest' of
+    Nothing -> pure []
+    Just (fmap HQ'.NameOnly -> src, dest) -> do
+      termSteps <- moveTermSteps src dest
+      typeSteps <- moveTypeSteps src dest
+      pure (termSteps ++ typeSteps)
+  case (moveBranchFunc, moveTermTypeSteps) of
+    (Nothing, []) -> Cli.respond (Output.MoveNothingFound src')
+    (mupdates, steps) -> do
+      Cli.updateAndStepAt description (maybeToList mupdates) steps
+      Cli.respond Output.Success

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

@@ -1,33 +1,42 @@
-module Unison.Codebase.Editor.HandleInput.MoveBranch where
+module Unison.Codebase.Editor.HandleInput.MoveBranch (doMoveBranch, moveBranchFunc) where
 
 import Unison.Cli.Monad (Cli)
 import Unison.Cli.Monad qualified as Cli
 import Unison.Cli.MonadUtils qualified as Cli
+import Unison.Codebase.Branch (Branch)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Editor.Output (Output (..))
 import Unison.Codebase.Path qualified as Path
 import Unison.Prelude
 
--- | Moves a branch and its history from one location to another, and saves the new root
--- branch.
-doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
-doMoveBranch actionDescription hasConfirmed src' dest' = do
+moveBranchFunc :: Bool -> Path.Path' -> Path.Path' -> Cli (Maybe (Path.Absolute, Branch IO -> Branch IO))
+moveBranchFunc hasConfirmed src' dest' = do
   srcAbs <- Cli.resolvePath' src'
   destAbs <- Cli.resolvePath' dest'
   destBranchExists <- Cli.branchExistsAtPath' dest'
   let isRootMove = (Path.isRoot srcAbs || Path.isRoot destAbs)
   when (isRootMove && not hasConfirmed) do
     Cli.returnEarly MoveRootBranchConfirmation
-  srcBranch <- Cli.expectBranchAtPath' src'
+  Cli.getMaybeBranchAt srcAbs >>= traverse \srcBranch -> do
+    -- We want the move to appear as a single step in the root namespace, but we need to make
+    -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
+    -- those changes such that they appear as a single change in the root.
+    let (changeRootPath, srcLoc, destLoc) = Path.longestPathPrefix (Path.unabsolute srcAbs) (Path.unabsolute destAbs)
+    let doMove changeRoot = 
+          changeRoot
+          & Branch.modifyAt srcLoc (const Branch.empty)
+          & Branch.modifyAt destLoc (const srcBranch)
+    if (destBranchExists && not isRootMove)
+      then Cli.respond (MovedOverExistingBranch dest')
+      else pure ()
+    pure (Path.Absolute changeRootPath, doMove)
 
-  -- We want the move to appear as a single step in the root namespace, but we need to make
-  -- surgical changes in both the root and the destination, so we make our modifications at the shared parent of
-  -- those changes such that they appear as a single change in the root.
-  let (changeRootPath, srcLoc, destLoc) = Path.longestPathPrefix (Path.unabsolute srcAbs) (Path.unabsolute destAbs)
-  Cli.updateAt actionDescription (Path.Absolute changeRootPath) \changeRoot ->
-    changeRoot
-      & Branch.modifyAt srcLoc (const Branch.empty)
-      & Branch.modifyAt destLoc (const srcBranch)
-  if (destBranchExists && not isRootMove)
-    then Cli.respond (MovedOverExistingBranch dest')
-    else Cli.respond Success
+-- | Moves a branch and its history from one location to another, and saves the new root
+-- branch.
+doMoveBranch :: Text -> Bool -> Path.Path' -> Path.Path' -> Cli ()
+doMoveBranch actionDescription hasConfirmed src' dest' = do
+  moveBranchFunc hasConfirmed src' dest' >>= \case
+    Nothing -> Cli.respond (BranchNotFound src')
+    Just (path, func) -> do
+      _ <- Cli.updateAt actionDescription path func
+      Cli.respond Success

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

@@ -0,0 +1,48 @@
+module Unison.Codebase.Editor.HandleInput.MoveTerm (doMoveTerm, moveTermSteps) where
+
+import Control.Lens (over, _2)
+import Data.Set qualified as Set
+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 (Branch0)
+import Unison.Codebase.BranchUtil qualified as BranchUtil
+import Unison.Codebase.Editor.Output qualified as Output
+import Unison.Codebase.Path (Path, Path')
+import Unison.Codebase.Path qualified as Path
+import Unison.HashQualified' qualified as HQ'
+import Unison.NameSegment (NameSegment)
+import Unison.Prelude
+
+moveTermSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
+moveTermSteps src' dest' = do
+  src <- Cli.resolveSplit' src'
+  srcTerms <- Cli.getTermsAt src
+  case Set.toList srcTerms of
+    [] -> pure []
+    _:_:_ -> do
+      hqLength <- Cli.runTransaction Codebase.hashLength
+      Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' srcTerms Set.empty)
+    [srcTerm] -> do
+      dest <- Cli.resolveSplit' dest'
+      destTerms <- Cli.getTermsAt (Path.convert dest)
+      when (not (Set.null destTerms)) do
+        Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
+      let p = Path.convert src
+      srcMetadata <- do
+        root0 <- Cli.getRootBranch0
+        pure (BranchUtil.getTermMetadataAt p srcTerm root0)
+      pure
+        [ -- Mitchell: throwing away any hash-qualification here seems wrong!
+          BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
+          BranchUtil.makeAddTermName (Path.convert dest) srcTerm srcMetadata
+        ]
+
+doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
+doMoveTerm src' dest' description = do
+  steps <- moveTermSteps src' dest'
+  when (null steps) do
+    Cli.returnEarly (Output.TermNotFound src')
+  Cli.stepManyAt description steps
+  Cli.respond Output.Success

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

@@ -0,0 +1,48 @@
+module Unison.Codebase.Editor.HandleInput.MoveType (doMoveType, moveTypeSteps) where
+
+import Control.Lens (over, _2)
+import Data.Set qualified as Set
+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 (Branch0)
+import Unison.Codebase.BranchUtil qualified as BranchUtil
+import Unison.Codebase.Editor.Output qualified as Output
+import Unison.Codebase.Path (Path, Path')
+import Unison.Codebase.Path qualified as Path
+import Unison.HashQualified' qualified as HQ'
+import Unison.NameSegment (NameSegment)
+import Unison.Prelude
+
+moveTypeSteps :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Cli [(Path, Branch0 m -> Branch0 m)]
+moveTypeSteps src' dest' = do
+  src <- Cli.resolveSplit' src'
+  srcTypes <- Cli.getTypesAt src
+  case Set.toList srcTypes of
+    [] -> pure []
+    _:_:_ -> do
+      hqLength <- Cli.runTransaction Codebase.hashLength
+      Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' Set.empty srcTypes)
+    [srcType] -> do
+      dest <- Cli.resolveSplit' dest'
+      destTypes <- Cli.getTypesAt (Path.convert dest)
+      when (not (Set.null destTypes)) do
+        Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
+      let p = Path.convert src
+      srcMetadata <- do
+        root0 <- Cli.getRootBranch0
+        pure (BranchUtil.getTypeMetadataAt p srcType root0)
+      pure
+        [ -- Mitchell: throwing away any hash-qualification here seems wrong!
+          BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
+          BranchUtil.makeAddTypeName (Path.convert dest) srcType srcMetadata
+        ]
+
+doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
+doMoveType src' dest' description = do
+  steps <- moveTypeSteps src' dest'
+  when (null steps) do
+    Cli.returnEarly (Output.TypeNotFound src')
+  Cli.stepManyAt description steps
+  Cli.respond Output.Success

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

@@ -131,6 +131,7 @@ data Input
   | AliasTermI HashOrHQSplit' Path.Split'
   | AliasTypeI HashOrHQSplit' Path.Split'
   | AliasManyI [Path.HQSplit] Path'
+  | MoveAllI Path.Path' Path.Path'
   | -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name.
     MoveTermI Path.HQSplit' Path.Split'
   | MoveTypeI Path.HQSplit' Path.Split'

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

@@ -195,6 +195,7 @@ data Output
   | PatchNotFound Path.Split'
   | TypeNotFound Path.HQSplit'
   | TermNotFound Path.HQSplit'
+  | MoveNothingFound Path'
   | TypeNotFound' ShortHash
   | TermNotFound' ShortHash
   | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name)
@@ -501,6 +502,7 @@ isFailure o = case o of
   TypeNotFound {} -> True
   TypeNotFound' {} -> True
   TermNotFound {} -> True
+  MoveNothingFound {} -> True
   TermNotFound' {} -> True
   TypeTermMismatch {} -> True
   SearchTermsNotFound ts -> not (null ts)

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

@@ -678,6 +678,27 @@ renameTerm =
               "`rename.term` takes two arguments, like `rename.term oldname newname`."
     )
 
+moveAll :: InputPattern
+moveAll =
+  InputPattern
+    "move"
+    []
+    I.Visible
+    [ (Required, namespaceOrDefinitionArg),
+      (Required, newNameArg)
+    ]
+    "`move foo bar` renames the term, type, and namespace foo to bar."
+    ( \case
+        [oldName, newName] -> first fromString $ do
+          src <- Path.parsePath' oldName
+          target <- Path.parsePath' newName
+          pure $ Input.MoveAllI src target
+        _ ->
+          Left . P.warnCallout $
+            P.wrap
+              "`move` takes two arguments, like `move oldname newname`."
+    )
+
 renameType :: InputPattern
 renameType =
   InputPattern
@@ -2923,6 +2944,7 @@ validInputs =
       renamePatch,
       renameTerm,
       renameType,
+      moveAll,
       replace,
       reset,
       resetRoot,