Merge pull request #2990 from unisonweb/topic/updateNoPatch

Add update.nopatch command

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

@@ -377,7 +377,12 @@ loop = do
             ResolveTermNameI path -> "resolve.termName " <> hqs' path
             ResolveTypeNameI path -> "resolve.typeName " <> hqs' path
             AddI _selection -> "add"
-            UpdateI p _selection -> "update " <> opatch p
+            UpdateI p _selection ->
+              "update" <> (case p of
+                NoPatch -> ".nopatch"
+                DefaultPatch -> " " <> ps' defaultPatchPath
+                UsePatch p -> " " <> ps' p
+              )
             PropagatePatchI p scope -> "patch " <> ps' p <> " " <> p' scope
             UndoI {} -> "undo"
             ApiI -> "api"
@@ -1283,7 +1288,8 @@ loop = do
                 let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
                 previewResponse sourceName sr uf
               _ -> respond NoUnisonFile
-            UpdateI maybePatchPath requestedNames -> handleUpdate input maybePatchPath requestedNames
+            UpdateI optionalPatch requestedNames ->
+              handleUpdate input optionalPatch requestedNames
             PreviewUpdateI requestedNames -> case (latestFile', uf) of
               (Just (sourceName, _), Just uf) -> do
                 let vars = Set.map Name.toVar requestedNames
@@ -1808,8 +1814,8 @@ handleShowDefinition outputLoc inputQuery = do
             Just (path, _) -> Just path
 
 -- | Handle an @update@ command.
-handleUpdate :: forall m v. (Monad m, Var v) => Input -> Maybe PatchPath -> Set Name -> Action' m v ()
-handleUpdate input maybePatchPath requestedNames = do
+handleUpdate :: forall m v. (Monad m, Var v) => Input -> OptionalPatch -> Set Name -> Action' m v ()
+handleUpdate input optionalPatch requestedNames = do
   let requestedVars = Set.map Name.toVar requestedNames
   use LoopState.latestTypecheckedFile >>= \case
     Nothing -> respond NoUnisonFile
@@ -1822,7 +1828,10 @@ handleUpdate input maybePatchPath requestedNames = do
             let (p, seg) = Path.toAbsoluteSplit currentPath' patchPath'
             b <- getAt p
             eval . Eval $ Branch.getPatch seg (Branch.head b)
-      let patchPath = fromMaybe defaultPatchPath maybePatchPath
+      let patchPath = case optionalPatch of
+                        NoPatch -> Nothing
+                        DefaultPatch -> Just defaultPatchPath
+                        UsePatch p -> Just p
       slurpCheckNames <- slurpResultNames
       let currentPathNames = slurpCheckNames
       let sr = Slurp.slurpFile uf requestedVars Slurp.UpdateOp slurpCheckNames
@@ -1871,82 +1880,82 @@ handleUpdate input maybePatchPath requestedNames = do
               | (oldTypeRef, _) <- Map.elems typeEdits,
                 (n, r) <- Names.constructorsForType oldTypeRef currentPathNames
             ]
+      patchOps <- for patchPath $ \patchPath -> do
+        ye'ol'Patch <- getPatchAt patchPath
+        -- If `uf` updates a -> a', we want to replace all (a0 -> a) in patch
+        -- with (a0 -> a') in patch'.
+        -- So for all (a0 -> a) in patch, for all (a -> a') in `uf`,
+        -- we must know the type of a0, a, a'.
+        let -- we need:
+            -- all of the `old` references from the `new` edits,
+            -- plus all of the `old` references for edits from patch we're replacing
+            collectOldForTyping :: [(Reference, Reference)] -> Patch -> Set Reference
+            collectOldForTyping new old = foldl' f mempty (new ++ fromOld)
+              where
+                f acc (r, _r') = Set.insert r acc
+                newLHS = Set.fromList . fmap fst $ new
+                fromOld :: [(Reference, Reference)]
+                fromOld =
+                  [ (r, r') | (r, TermEdit.Replace r' _) <- R.toList . Patch._termEdits $ old, Set.member r' newLHS
+                  ]
+            neededTypes = collectOldForTyping (toList termEdits) ye'ol'Patch
 
-      ye'ol'Patch <- getPatchAt patchPath
-      -- If `uf` updates a -> a', we want to replace all (a0 -> a) in patch
-      -- with (a0 -> a') in patch'.
-      -- So for all (a0 -> a) in patch, for all (a -> a') in `uf`,
-      -- we must know the type of a0, a, a'.
-      let -- we need:
-          -- all of the `old` references from the `new` edits,
-          -- plus all of the `old` references for edits from patch we're replacing
-          collectOldForTyping :: [(Reference, Reference)] -> Patch -> Set Reference
-          collectOldForTyping new old = foldl' f mempty (new ++ fromOld)
-            where
-              f acc (r, _r') = Set.insert r acc
-              newLHS = Set.fromList . fmap fst $ new
-              fromOld :: [(Reference, Reference)]
-              fromOld =
-                [ (r, r') | (r, TermEdit.Replace r' _) <- R.toList . Patch._termEdits $ old, Set.member r' newLHS
-                ]
-          neededTypes = collectOldForTyping (toList termEdits) ye'ol'Patch
+        allTypes :: Map Reference (Type v Ann) <-
+          fmap Map.fromList . for (toList neededTypes) $ \r ->
+            (r,) . fromMaybe (Type.builtin External "unknown type")
+              <$> (eval . LoadTypeOfTerm) r
 
-      allTypes :: Map Reference (Type v Ann) <-
-        fmap Map.fromList . for (toList neededTypes) $ \r ->
-          (r,) . fromMaybe (Type.builtin External "unknown type")
-            <$> (eval . LoadTypeOfTerm) r
+        let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of
+              (Just t1, Just t2)
+                | Typechecker.isEqual t1 t2 -> TermEdit.Same
+                | Typechecker.isSubtype t1 t2 -> TermEdit.Subtype
+                | otherwise -> TermEdit.Different
+              e ->
+                error $
+                  "compiler bug: typing map not constructed properly\n"
+                    <> "typing "
+                    <> show r1
+                    <> " "
+                    <> show r2
+                    <> " : "
+                    <> show e
 
-      let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of
-            (Just t1, Just t2)
-              | Typechecker.isEqual t1 t2 -> TermEdit.Same
-              | Typechecker.isSubtype t1 t2 -> TermEdit.Subtype
-              | otherwise -> TermEdit.Different
-            e ->
-              error $
-                "compiler bug: typing map not constructed properly\n"
-                  <> "typing "
-                  <> show r1
-                  <> " "
-                  <> show r2
-                  <> " : "
-                  <> show e
-
-      let updatePatch :: Patch -> Patch
-          updatePatch p = foldl' step2 p' termEdits
-            where
-              p' = foldl' step1 p typeEdits
-              step1 p (r, r') = Patch.updateType r (TypeEdit.Replace r') p
-              step2 p (r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p
-          (p, seg) = Path.toAbsoluteSplit currentPath' patchPath
-          updatePatches :: Branch0 m -> m (Branch0 m)
-          updatePatches = Branch.modifyPatches seg updatePatch
+            updatePatch :: Patch -> Patch
+            updatePatch p = foldl' step2 p' termEdits
+              where
+                p' = foldl' step1 p typeEdits
+                step1 p (r, r') = Patch.updateType r (TypeEdit.Replace r') p
+                step2 p (r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p
+            (p, seg) = Path.toAbsoluteSplit currentPath' patchPath
+            updatePatches :: Branch0 m -> m (Branch0 m)
+            updatePatches = Branch.modifyPatches seg updatePatch
+        pure (updatePatch ye'ol'Patch, updatePatches, p)
 
       when (Slurp.hasAddsOrUpdates sr) $ do
         -- take a look at the `updates` from the SlurpResult
         -- and make a patch diff to record a replacement from the old to new references
         stepManyAtMNoSync
           Branch.CompressHistory
-          [ ( Path.unabsolute currentPath',
+          ([ ( Path.unabsolute currentPath',
               pure . doSlurpUpdates typeEdits termEdits termDeprecations
             ),
             ( Path.unabsolute currentPath',
               pure . doSlurpAdds addsAndUpdates uf
-            ),
-            (Path.unabsolute p, updatePatches)
-          ]
+            )] ++ case patchOps of
+                    Nothing -> []
+                    Just (_, update, p) -> [(Path.unabsolute p, update)])
         eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
       ppe <- prettyPrintEnvDecl =<< displayNames uf
       respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
       -- propagatePatch prints TodoOutput
-      void $ propagatePatchNoSync (updatePatch ye'ol'Patch) currentPath'
+      for_ patchOps $ \case
+        (updatedPatch, _, _) -> void $ propagatePatchNoSync updatedPatch currentPath'
       addDefaultMetadata addsAndUpdates
-      let patchString :: Text
-          patchString =
-            patchPath
-              & Path.unsplit'
-              & Path.resolve @_ @_ @Path.Absolute currentPath'
-              & tShow
-      syncRoot ("update " <> patchString)
+      syncRoot $ case patchPath of
+                   Nothing -> "update.nopatch"
+                   Just p -> p & Path.unsplit'
+                               & Path.resolve @_ @_ @Path.Absolute currentPath'
+                               & tShow
 
 -- Add default metadata to all added types and terms in a slurp component.
 --
@@ -1955,6 +1964,7 @@ addDefaultMetadata :: (Monad m, Var v) => SlurpComponent v -> Action m (Either E
 addDefaultMetadata adds =
   when (not (SC.isEmpty adds)) do
     currentPath' <- use LoopState.currentPath
+
     let addedVs = Set.toList $ SC.types adds <> SC.terms adds
         addedNs = traverse (Path.hqSplitFromName' . Name.unsafeFromVar) addedVs
     case addedNs of

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

@@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Input
     HashOrHQSplit',
     Insistence (..),
     PullMode (..),
+    OptionalPatch (..),
   )
 where
 
@@ -42,6 +43,9 @@ type SourceName = Text -- "foo.u" or "buffer 7"
 
 type PatchPath = Path.Split'
 
+data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
+  deriving (Eq, Ord, Show)
+
 type BranchId = Either ShortBranchHash Path'
 
 type AbsBranchId = Either ShortBranchHash Path.Absolute
@@ -116,7 +120,7 @@ data Input
     LoadI (Maybe FilePath)
   | AddI (Set Name)
   | PreviewAddI (Set Name)
-  | UpdateI (Maybe PatchPath) (Set Name)
+  | UpdateI OptionalPatch (Set Name)
   | PreviewUpdateI (Set Name)
   | TodoI (Maybe PatchPath) Path'
   | PropagatePatchI PatchPath Path'

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

@@ -187,16 +187,48 @@ previewAdd =
     )
     $ \ws -> pure $ Input.PreviewAddI (Set.fromList $ map Name.unsafeFromString ws)
 
+updateNoPatch :: InputPattern
+updateNoPatch =
+  InputPattern
+    "update.nopatch"
+    ["un"]
+    [(ZeroPlus, noCompletions)]
+    ( P.wrap
+        ( makeExample' updateNoPatch
+            <> "works like"
+            <> P.group (makeExample' update <> ",")
+            <> "except it doesn't add a patch entry for any updates. "
+            <> "Use this when you want to make changes to definitions without "
+            <> "pushing those changes to dependents beyond your codebase. "
+            <> "An example is when updating docs, or when updating a term you "
+            <> "just added."
+        )
+        <> P.wrapColumn2
+          [ ( makeExample' updateNoPatch,
+              "updates all definitions in the .u file."
+            ),
+            ( makeExample updateNoPatch ["foo", "bar"],
+              "updates `foo`, `bar`, and their dependents from the .u file."
+            )
+          ]
+    )
+    ( \case
+        ws -> do
+          pure $
+            Input.UpdateI
+              Input.NoPatch
+              (Set.fromList $ map Name.unsafeFromString ws)
+    )
+
 update :: InputPattern
 update =
   InputPattern
     "update"
     []
-    [ (Optional, patchArg),
-      (ZeroPlus, noCompletions)
-    ]
+    [(Optional, patchArg), (ZeroPlus, noCompletions)]
     ( P.wrap
-        ( makeExample' update <> "works like"
+        ( makeExample' update
+            <> "works like"
             <> P.group (makeExample' add <> ",")
             <> "except that if a definition in the file has the same name as an"
             <> "existing definition, the name gets updated to point to the new"
@@ -221,9 +253,14 @@ update =
     )
     ( \case
         patchStr : ws -> do
-          patch <- first fromString $ Path.parseSplit' Path.definitionNameSegment patchStr
-          pure $ Input.UpdateI (Just patch) (Set.fromList $ map Name.unsafeFromString ws)
-        [] -> Right $ Input.UpdateI Nothing mempty
+          patch <-
+            first fromString $
+              Path.parseSplit' Path.definitionNameSegment patchStr
+          pure $
+            Input.UpdateI
+              (Input.UsePatch patch)
+              (Set.fromList $ map Name.unsafeFromString ws)
+        [] -> Right $ Input.UpdateI Input.DefaultPatch mempty
     )
 
 previewUpdate :: InputPattern
@@ -385,7 +422,7 @@ findShallow :: InputPattern
 findShallow =
   InputPattern
     "list"
-    ["ls"]
+    ["ls", "dir"]
     [(Optional, namespaceArg)]
     ( P.wrapColumn2
         [ ("`list`", "lists definitions and namespaces at the current level of the current namespace."),
@@ -1878,6 +1915,7 @@ validInputs =
     previewAdd,
     update,
     previewUpdate,
+    updateNoPatch,
     delete,
     forkLocal,
     mergeLocal,