Merge remote-tracking branch 'origin/trunk' into fix/no-crash-findCto…

…rNames

# Conflicts:
#	unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs
#	unison-cli/src/Unison/Codebase/Editor/Output.hs
#	unison-cli/src/Unison/CommandLine/OutputMessages.hs

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -33,6 +33,7 @@ module Unison.Codebase.Branch
     -- * properties
     history,
     head,
+    head_,
     headHash,
     children,
     nonEmptyChildren,
@@ -78,6 +79,7 @@ module Unison.Codebase.Branch
 
     -- ** Term/type queries
     deepReferents,
+    deepTermReferences,
     deepTypeReferences,
     consBranchSnapshot,
   )
@@ -120,13 +122,15 @@ import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
 import Unison.Prelude hiding (empty)
-import Unison.Reference (TypeReference)
+import Unison.Reference (TermReference, TypeReference)
 import Unison.Referent (Referent)
+import Unison.Referent qualified as Referent
 import Unison.Util.List qualified as List
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Relation qualified as R
 import Unison.Util.Relation qualified as Relation
 import Unison.Util.Relation4 qualified as R4
+import Unison.Util.Set qualified as Set
 import Unison.Util.Star3 qualified as Star3
 import Prelude hiding (head, read, subtract)
 
@@ -143,6 +147,10 @@ instance Hashing.ContentAddressable (Branch0 m) where
 deepReferents :: Branch0 m -> Set Referent
 deepReferents = R.dom . deepTerms
 
+deepTermReferences :: Branch0 m -> Set TermReference
+deepTermReferences =
+  Set.mapMaybe Referent.toTermReference . deepReferents
+
 deepTypeReferences :: Branch0 m -> Set TypeReference
 deepTypeReferences = R.dom . deepTypes
 

parser-typechecker/src/Unison/Codebase/Path.hs

@@ -138,11 +138,12 @@ isRoot :: Absolute -> Bool
 isRoot = Seq.null . toSeq . unabsolute
 
 absoluteToPath' :: Absolute -> Path'
-absoluteToPath' abs = Path' (Left abs)
+absoluteToPath' = AbsolutePath'
 
 instance Show Path' where
-  show (Path' (Left abs)) = show abs
-  show (Path' (Right rel)) = show rel
+  show = \case
+    AbsolutePath' abs -> show abs
+    RelativePath' rel -> show rel
 
 instance Show Absolute where
   show s = "." ++ show (unabsolute s)
@@ -151,8 +152,9 @@ instance Show Relative where
   show = show . unrelative
 
 unsplit' :: Split' -> Path'
-unsplit' (Path' (Left (Absolute p)), seg) = Path' (Left (Absolute (unsplit (p, seg))))
-unsplit' (Path' (Right (Relative p)), seg) = Path' (Right (Relative (unsplit (p, seg))))
+unsplit' = \case
+  (AbsolutePath' (Absolute p), seg) -> AbsolutePath' (Absolute (unsplit (p, seg)))
+  (RelativePath' (Relative p), seg) -> RelativePath' (Relative (unsplit (p, seg)))
 
 unsplit :: Split -> Path
 unsplit (Path p, a) = Path (p :|> a)
@@ -182,15 +184,15 @@ type HQSplitAbsolute = (Absolute, HQ'.HQSegment)
 --   unprefix .foo.bar id    == id    (relative paths starting w/ nonmatching prefix left alone)
 --   unprefix .foo.bar foo.bar.baz == baz (relative paths w/ common prefix get stripped)
 unprefix :: Absolute -> Path' -> Path
-unprefix (Absolute prefix) (Path' p) = case p of
-  Left abs -> unabsolute abs
-  Right (unrelative -> rel) -> fromList $ dropPrefix (toList prefix) (toList rel)
+unprefix (Absolute prefix) = \case
+  AbsolutePath' abs -> unabsolute abs
+  RelativePath' rel -> fromList $ dropPrefix (toList prefix) (toList (unrelative rel))
 
 -- too many types
 prefix :: Absolute -> Path' -> Path
-prefix (Absolute (Path prefix)) (Path' p) = case p of
-  Left (unabsolute -> abs) -> abs
-  Right (unrelative -> rel) -> Path $ prefix <> toSeq rel
+prefix (Absolute (Path prefix)) = \case
+  AbsolutePath' abs -> unabsolute abs
+  RelativePath' rel -> Path $ prefix <> toSeq (unrelative rel)
 
 -- | Finds the longest shared path prefix of two paths.
 -- Returns (shared prefix, path to first location from shared prefix, path to second location from shared prefix)
@@ -218,22 +220,22 @@ relativeEmpty :: Relative
 relativeEmpty = Relative empty
 
 relativeEmpty' :: Path'
-relativeEmpty' = Path' (Right (Relative empty))
+relativeEmpty' = RelativePath' (Relative empty)
 
 absoluteEmpty' :: Path'
-absoluteEmpty' = Path' (Left (Absolute empty))
+absoluteEmpty' = AbsolutePath' (Absolute empty)
 
 -- | Mitchell: this function is bogus, because an empty name segment is bogus
 toPath' :: Path -> Path'
 toPath' = \case
-  Path (NameSegment "" :<| tail) -> Path' . Left . Absolute . Path $ tail
+  Path (NameSegment "" :<| tail) -> AbsolutePath' . Absolute . Path $ tail
   p -> Path' . Right . Relative $ p
 
 -- Forget whether the path is absolute or relative
 fromPath' :: Path' -> Path
-fromPath' (Path' e) = case e of
-  Left (Absolute p) -> p
-  Right (Relative p) -> p
+fromPath' = \case
+  AbsolutePath' (Absolute p) -> p
+  RelativePath' (Relative p) -> p
 
 toList :: Path -> [NameSegment]
 toList = Foldable.toList . toSeq
@@ -301,8 +303,8 @@ fromName = fromList . List.NonEmpty.toList . Name.segments
 
 fromName' :: Name -> Path'
 fromName' n = case take 1 (Name.toString n) of
-  "." -> Path' . Left . Absolute $ Path seq
-  _ -> Path' . Right $ Relative path
+  "." -> AbsolutePath' . Absolute $ Path seq
+  _ -> RelativePath' $ Relative path
   where
     path = fromName n
     seq = toSeq path
@@ -366,15 +368,13 @@ fromText' :: Text -> Path'
 fromText' txt =
   case Text.uncons txt of
     Nothing -> relativeEmpty'
-    Just ('.', p) ->
-      Path' (Left . Absolute $ fromText p)
-    Just _ ->
-      Path' (Right . Relative $ fromText txt)
+    Just ('.', p) -> AbsolutePath' . Absolute $ fromText p
+    Just _ -> RelativePath' . Relative $ fromText txt
 
 toText' :: Path' -> Text
 toText' = \case
-  Path' (Left (Absolute path)) -> Text.cons '.' (toText path)
-  Path' (Right (Relative path)) -> toText path
+  AbsolutePath' (Absolute path) -> Text.cons '.' (toText path)
+  RelativePath' (Relative path) -> toText path
 
 {-# COMPLETE Empty, (:<) #-}
 
@@ -451,18 +451,18 @@ instance Snoc Path Path NameSegment NameSegment where
       snoc (Path p) ns = Path (p <> pure ns)
 
 instance Snoc Path' Path' NameSegment NameSegment where
-  _Snoc = prism (uncurry snoc') $ \case
-    Path' (Left (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Left s), a)
-    Path' (Right (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Right s), a)
+  _Snoc = prism (uncurry snoc') \case
+    AbsolutePath' (Lens.unsnoc -> Just (s, a)) -> Right (AbsolutePath' s, a)
+    RelativePath' (Lens.unsnoc -> Just (s, a)) -> Right (RelativePath' s, a)
     e -> Left e
     where
       snoc' :: Path' -> NameSegment -> Path'
-      snoc' (Path' e) n = case e of
-        Left abs -> Path' (Left . Absolute $ Lens.snoc (unabsolute abs) n)
-        Right rel -> Path' (Right . Relative $ Lens.snoc (unrelative rel) n)
+      snoc' = \case
+        AbsolutePath' abs -> AbsolutePath' . Absolute . Lens.snoc (unabsolute abs)
+        RelativePath' rel -> RelativePath' . Relative . Lens.snoc (unrelative rel)
 
 instance Snoc Split' Split' NameSegment NameSegment where
-  _Snoc = prism (uncurry snoc') $ \case
+  _Snoc = prism (uncurry snoc') \case
     -- unsnoc
     (Lens.unsnoc -> Just (s, a), ns) -> Right ((s, a), ns)
     e -> Left e
@@ -482,10 +482,13 @@ instance Resolve Relative Relative Relative where
 instance Resolve Absolute Relative Absolute where
   resolve (Absolute l) (Relative r) = Absolute (resolve l r)
 
+instance Resolve Absolute Relative Path' where
+  resolve l r = AbsolutePath' (resolve l r)
+
 instance Resolve Path' Path' Path' where
-  resolve _ a@(Path' Left {}) = a
-  resolve (Path' (Left a)) (Path' (Right r)) = Path' (Left (resolve a r))
-  resolve (Path' (Right r1)) (Path' (Right r2)) = Path' (Right (resolve r1 r2))
+  resolve _ a@(AbsolutePath' {}) = a
+  resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
+  resolve (RelativePath' r1) (RelativePath' r2) = RelativePath' (resolve r1 r2)
 
 instance Resolve Path' Split' Path' where
   resolve l r = resolve l (unsplit' r)
@@ -497,8 +500,8 @@ instance Resolve Absolute HQSplit HQSplitAbsolute where
   resolve l (r, hq) = (resolve l (Relative r), hq)
 
 instance Resolve Absolute Path' Absolute where
-  resolve _ (Path' (Left a)) = a
-  resolve a (Path' (Right r)) = resolve a r
+  resolve _ (AbsolutePath' a) = a
+  resolve a (RelativePath' r) = resolve a r
 
 instance Convert Absolute Path where convert = unabsolute
 

parser-typechecker/src/Unison/UnisonFile.hs

@@ -7,6 +7,7 @@ module Unison.UnisonFile
   ( -- * UnisonFile
     UnisonFile (..),
     pattern UnisonFile,
+    emptyUnisonFile,
     allWatches,
     dataDeclarations,
     declsToTypeLookup,
@@ -65,6 +66,16 @@ import Unison.Var (Var)
 import Unison.Var qualified as Var
 import Unison.WatchKind (WatchKind, pattern TestWatch)
 
+-- | An empty Unison file.
+emptyUnisonFile :: UnisonFile v a
+emptyUnisonFile =
+  UnisonFileId
+    { dataDeclarationsId = Map.empty,
+      effectDeclarationsId = Map.empty,
+      terms = [],
+      watches = Map.empty
+    }
+
 dataDeclarations :: UnisonFile v a -> Map v (Reference, DataDeclaration v a)
 dataDeclarations = fmap (first Reference.DerivedId) . dataDeclarationsId
 

parser-typechecker/unison-parser-typechecker.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.35.2.
 --
 -- see: https://github.com/sol/hpack
 

unison-cli/package.yaml

@@ -86,6 +86,7 @@ dependencies:
   - unison-sqlite
   - unison-syntax
   - unison-util-base32hex
+  - unison-util-nametree
   - unison-util-relation
   - unliftio
   - unordered-containers

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

@@ -6,6 +6,7 @@ module Unison.Cli.MonadUtils
 
     -- * Paths
     getCurrentPath,
+    resolvePath,
     resolvePath',
     resolveSplit',
 
@@ -30,7 +31,10 @@ module Unison.Cli.MonadUtils
     getLastSavedRootHash,
     setLastSavedRootHash,
     getMaybeBranchAt,
+    expectBranchAtPath,
     expectBranchAtPath',
+    expectBranch0AtPath,
+    expectBranch0AtPath',
     assertNoBranchAtPath',
     branchExistsAtPath',
 
@@ -139,6 +143,12 @@ getCurrentPath :: Cli Path.Absolute
 getCurrentPath = do
   use #currentPath
 
+-- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path.
+resolvePath :: Path -> Cli Path.Absolute
+resolvePath path = do
+  currentPath <- getCurrentPath
+  pure (Path.resolve currentPath (Path.Relative path))
+
 -- | Resolve a @Path'@ to a @Path.Absolute@, per the current path.
 resolvePath' :: Path' -> Cli Path.Absolute
 resolvePath' path = do
@@ -279,12 +289,27 @@ getMaybeBranchAt path = do
   rootBranch <- getRootBranch
   pure (Branch.getAt (Path.unabsolute path) rootBranch)
 
+-- | Get the branch at a relative path, or return early if there's no such branch.
+expectBranchAtPath :: Path -> Cli (Branch IO)
+expectBranchAtPath =
+  expectBranchAtPath' . Path' . Right . Path.Relative
+
 -- | Get the branch at an absolute or relative path, or return early if there's no such branch.
 expectBranchAtPath' :: Path' -> Cli (Branch IO)
 expectBranchAtPath' path0 = do
   path <- resolvePath' path0
   getMaybeBranchAt path & onNothingM (Cli.returnEarly (Output.BranchNotFound path0))
 
+-- | Get the branch0 at an absolute or relative path, or return early if there's no such branch.
+expectBranch0AtPath' :: Path' -> Cli (Branch0 IO)
+expectBranch0AtPath' =
+  fmap Branch.head . expectBranchAtPath'
+
+-- | Get the branch0 at a relative path, or return early if there's no such branch.
+expectBranch0AtPath :: Path -> Cli (Branch0 IO)
+expectBranch0AtPath =
+  expectBranch0AtPath' . Path' . Right . Path.Relative
+
 -- | Assert that there's "no branch" at an absolute or relative path, or return early if there is one, where "no branch"
 -- means either there's actually no branch, or there is a branch whose head is empty (i.e. it may have a history, but no
 -- current terms/types etc).

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

@@ -85,6 +85,7 @@ import Unison.Codebase.Editor.HandleInput.TermResolution (resolveCon, resolveMai
 import Unison.Codebase.Editor.HandleInput.UI (openUI)
 import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
 import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2)
+import Unison.Codebase.Editor.HandleInput.Upgrade (handleUpgrade)
 import Unison.Codebase.Editor.Input
 import Unison.Codebase.Editor.Input qualified as Input
 import Unison.Codebase.Editor.Output
@@ -1348,6 +1349,7 @@ loop e = do
             BranchesI name -> handleBranches name
             CloneI remoteNames localNames -> handleClone remoteNames localNames
             ReleaseDraftI semver -> handleReleaseDraft semver
+            UpgradeI old new -> handleUpgrade old new
 
 loadUnisonFile :: Text -> Text -> Cli ()
 loadUnisonFile sourceName text = do
@@ -1578,6 +1580,7 @@ inputDescription input =
       pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch])
     ClearI {} -> pure "clear"
     DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name)
+    UpgradeI old new -> pure (Text.unwords ["upgrade", NameSegment.toText old, NameSegment.toText new])
     --
     ApiI -> wat
     AuthLoginI {} -> wat

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

@@ -84,7 +84,7 @@ handleBranch sourceI projectAndBranchNames0 = do
         -- We can't make the *first* branch of a project with `branch`; the project has to already exist.
         rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
 
-  doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
+  _ <- doCreateBranch createFrom project newBranchName ("branch " <> into @Text projectAndBranchNames)
 
   Cli.respond $
     Output.CreatedProjectBranch
@@ -106,7 +106,9 @@ handleBranch sourceI projectAndBranchNames0 = do
 --
 -- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
 -- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
-doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ()
+--
+-- Returns the branch id of the newly-created branch.
+doCreateBranch :: CreateFrom -> Sqlite.Project -> ProjectBranchName -> Text -> Cli ProjectBranchId
 doCreateBranch createFrom project newBranchName description = do
   let projectId = project ^. #projectId
   newBranchId <-
@@ -143,3 +145,4 @@ doCreateBranch createFrom project newBranchName description = do
       CreateFrom'Nothingness -> pure Branch.empty
   _ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
   Cli.cd newBranchPath
+  pure newBranchId

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

@@ -21,10 +21,11 @@ handleReleaseDraft ver = do
 
   let branchName = unsafeFrom @Text ("releases/drafts/" <> into @Text ver)
 
-  doCreateBranch
-    (CreateFrom'Branch currentProjectAndBranch)
-    (currentProjectAndBranch ^. #project)
-    branchName
-    ("release.draft " <> into @Text ver)
+  _ <-
+    doCreateBranch
+      (CreateFrom'Branch currentProjectAndBranch)
+      (currentProjectAndBranch ^. #project)
+      branchName
+      ("release.draft " <> into @Text ver)
 
   Cli.respond (Output.DraftingRelease branchName ver)