work on upgrade sad path

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

@@ -33,6 +33,7 @@ module Unison.Codebase.Branch
     -- * properties
     history,
     head,
+    head_,
     headHash,
     children,
     nonEmptyChildren,

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 = \case
-  show (Path' (Right rel)) = show rel
+    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' = \case
-unsplit' (Path' (Right (Relative p)), seg) = Path' (Right (Relative (unsplit (p, seg))))
+  (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
+unprefix (Absolute prefix) = \case
-  Left abs -> unabsolute abs
+  AbsolutePath' abs -> unabsolute abs
-  Right (unrelative -> rel) -> fromList $ dropPrefix (toList prefix) (toList rel)
+  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
+prefix (Absolute (Path prefix)) = \case
-  Left (unabsolute -> abs) -> abs
+  AbsolutePath' abs -> unabsolute abs
-  Right (unrelative -> rel) -> Path $ prefix <> toSeq rel
+  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
+fromPath' = \case
-  Left (Absolute p) -> p
+  AbsolutePath' (Absolute p) -> p
-  Right (Relative 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
+  "." -> AbsolutePath' . Absolute $ Path seq
-  _ -> Path' . Right $ Relative path
+  _ -> 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) ->
+    Just ('.', p) -> AbsolutePath' . Absolute $ fromText p
-      Path' (Left . Absolute $ fromText p)
+    Just _ -> RelativePath' . Relative $ fromText txt
-    Just _ ->
-      Path' (Right . Relative $ fromText txt)
 
 toText' :: Path' -> Text
 toText' = \case
-  Path' (Left (Absolute path)) -> Text.cons '.' (toText path)
+  AbsolutePath' (Absolute path) -> Text.cons '.' (toText path)
-  Path' (Right (Relative path)) -> 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
+  _Snoc = prism (uncurry snoc') \case
-    Path' (Left (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Left s), a)
+    AbsolutePath' (Lens.unsnoc -> Just (s, a)) -> Right (AbsolutePath' s, a)
-    Path' (Right (Lens.unsnoc -> Just (s, a))) -> Right (Path' (Right 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
+      snoc' = \case
-        Left abs -> Path' (Left . Absolute $ Lens.snoc (unabsolute abs) n)
+        AbsolutePath' abs -> AbsolutePath' . Absolute . Lens.snoc (unabsolute abs)
-        Right rel -> Path' (Right . Relative $ Lens.snoc (unrelative rel) n)
+        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 _ a@(AbsolutePath' {}) = a
-  resolve (Path' (Left a)) (Path' (Right r)) = Path' (Left (resolve a r))
+  resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r)
-  resolve (Path' (Right r1)) (Path' (Right r2)) = Path' (Right (resolve r1 r2))
+  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 _ (AbsolutePath' a) = a
-  resolve a (Path' (Right r)) = resolve a r
+  resolve a (RelativePath' r) = resolve a r
 
 instance Convert Absolute Path where convert = unabsolute
 

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/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/Upgrade.hs

@@ -3,39 +3,55 @@ module Unison.Codebase.Editor.HandleInput.Upgrade
   )
 where
 
-import Control.Lens (over)
+import Control.Lens (ix, over, (^.))
 import Control.Monad.Reader (ask)
+import Data.List qualified as List
 import Data.Map.Strict qualified as Map
+import Data.Maybe (fromJust)
+import Data.Set qualified as Set
+import Data.Text qualified as Text
 import U.Codebase.Sqlite.Operations qualified as Operations
+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.Cli.ProjectUtils qualified as Cli
+import Unison.Codebase.Branch (Branch0)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch
+import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
 import Unison.Codebase.Editor.HandleInput.Update2 (addDefinitionsToUnisonFile)
+import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
+import Unison.NameSegment qualified as NameSegment
 import Unison.Names (Names)
 import Unison.Names qualified as Names
-import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
-import Unison.Symbol (Symbol)
+import Unison.Project (ProjectAndBranch (..), ProjectBranchName)
 import Unison.UnisonFile (UnisonFile)
 import Unison.UnisonFile qualified as UnisonFile
+import Witch (unsafeFrom)
 
 handleUpgrade :: NameSegment -> NameSegment -> Cli ()
 handleUpgrade oldDepName newDepName = do
   Cli.Env {codebase} <- ask
 
-  oldDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, oldDepName])
+  (projectAndBranch, _path) <- Cli.expectCurrentProjectBranch
-  newDepBranch <- Cli.expectBranch0AtPath (Path.fromList [Name.libSegment, newDepName])
+  let projectId = projectAndBranch ^. #project . #projectId
-  currentBranch <- Cli.getCurrentBranch0
+  let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId (projectAndBranch ^. #branch . #branchId))
+  let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, oldDepName]))
+  let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, newDepName]))
 
-  let namesIncludingLibdeps = Branch.toNames currentBranch
+  currentV1Branch <- Cli.getBranch0At projectPath
-  let namesExcludingLibdeps = Branch.toNames (currentBranch & over Branch.children (Map.delete Name.libSegment))
+  oldDepV1Branch <- Cli.expectBranch0AtPath' oldDepPath
+  newDepV1Branch <- Cli.expectBranch0AtPath' newDepPath
+
+  let namesIncludingLibdeps = Branch.toNames currentV1Branch
+  let namesExcludingLibdeps = Branch.toNames (currentV1Branch & over Branch.children (Map.delete Name.libSegment))
   let namesExcludingOldDep = wundefined
 
   -- Compute "fake names": these are all of things in `lib.old`, with the `old` segment swapped out for `new`
@@ -51,7 +67,7 @@ handleUpgrade oldDepName newDepName = do
       dependents <-
         Operations.dependentsWithinScope
           (Names.referenceIds namesExcludingLibdeps)
-          (Branch.deepTermReferences oldDepBranch <> Branch.deepTypeReferences newDepBranch)
+          (Branch.deepTermReferences oldDepV1Branch <> Branch.deepTypeReferences newDepV1Branch)
       unisonFile <- addDefinitionsToUnisonFile codebase namesExcludingLibdeps dependents UnisonFile.emptyUnisonFile
       -- Construct a PPE to use for rendering the Unison file full of dependents.
       printPPE :: PrettyPrintEnvDecl <- wundefined (namesExcludingOldDep <> fakeNames)
@@ -69,9 +85,56 @@ handleUpgrade oldDepName newDepName = do
   wundefined
 
   -- Sad path:
-  --   1. Make a new project branch, stepped forward one causal (tossing `lib.old`).
+  --   [x] Make a new project branch, stepped forward one causal (tossing `lib.old`).
-  --   2. Put the busted dependents into scratch.u
+  --   [ ] Put the busted dependents into scratch.u
-  --   3. Output message or something.
+  --   [ ] Output message or something.
-  wundefined
+  let sadPath = False
+  when sadPath do
+    temporaryBranchName <- do
+      -- Small race condition: since picking a branch name and creating the branch happen in different
+      -- transactions, creating could fail.
+      allBranchNames <-
+        fmap (Set.fromList . map snd) do
+          Cli.runTransaction (Queries.loadAllProjectBranchesBeginningWith projectId Nothing)
 
-  pure ()
+      let -- all branch name candidates in order of preference:
+          --   upgrade-<old>-to-<new>
+          --   upgrade-<old>-to-<new>-2
+          --   upgrade-<old>-to-<new>-3
+          --   ...
+          allCandidates :: [ProjectBranchName]
+          allCandidates =
+            preferred : do
+              n <- [(2 :: Int) ..]
+              pure (unsafeFrom @Text (into @Text preferred <> "-" <> tShow n))
+            where
+              preferred :: ProjectBranchName
+              preferred =
+                unsafeFrom @Text $
+                  "upgrade-"
+                    <> NameSegment.toText oldDepName
+                    <> "-to-"
+                    <> NameSegment.toText newDepName
+
+      pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
+
+    temporaryBranchId <-
+      HandleInput.Branch.doCreateBranch
+        (HandleInput.Branch.CreateFrom'Branch projectAndBranch)
+        (projectAndBranch ^. #project)
+        temporaryBranchName
+        textualDescriptionOfUpgrade
+
+    let temporaryBranchPath :: Path
+        temporaryBranchPath =
+          Path.unabsolute (Cli.projectBranchPath (ProjectAndBranch projectId temporaryBranchId))
+
+    Cli.stepAt textualDescriptionOfUpgrade (temporaryBranchPath, deleteLibdep oldDepName)
+  where
+    textualDescriptionOfUpgrade :: Text
+    textualDescriptionOfUpgrade =
+      Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName]
+
+deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m
+deleteLibdep dep =
+  over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep)