Merge pull request #4615 from unisonweb/travis/4423/branch-relative-path

Allow forking between projects/branches

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

@@ -12,6 +12,7 @@ module Unison.Cli.ProjectUtils
     projectBranchPath,
     projectBranchSegment,
     projectBranchPathPrism,
+    branchRelativePathToAbsolute,
 
     -- * Name hydration
     hydrateNames,
@@ -49,12 +50,34 @@ import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
 import Unison.Codebase.Editor.Output qualified as Output
 import Unison.Codebase.Path (Path')
 import Unison.Codebase.Path qualified as Path
+import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
+import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import Unison.Project.Util
 import Unison.Sqlite qualified as Sqlite
 import Witch (unsafeFrom)
 
+branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
+branchRelativePathToAbsolute = \case
+  BranchRelativePath.BranchRelative brp -> case brp of
+    These projectBranch path -> do
+      projectBranch <- getIds <$> expectProjectAndBranchByTheseNames (toThese projectBranch)
+      pure (Path.resolve (projectBranchPath projectBranch) path)
+    This projectBranch -> do
+      projectBranch <- getIds <$> expectProjectAndBranchByTheseNames (toThese projectBranch)
+      pure (projectBranchPath projectBranch)
+    That path -> do
+      projectBranch <- expectCurrentProjectIds
+      pure (Path.resolve (projectBranchPath projectBranch) path)
+  BranchRelativePath.LoosePath path -> Cli.resolvePath' path
+  where
+    toThese = \case
+      Left branchName -> That branchName
+      Right (projectName, branchName) -> These projectName branchName
+    getIds = \case
+      ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
+
 -- | Get the current project that a user is on.
 getCurrentProject :: Cli (Maybe Sqlite.Project)
 getCurrentProject = do
@@ -76,6 +99,11 @@ getCurrentProjectIds :: Cli (Maybe (ProjectAndBranch ProjectId ProjectBranchId))
 getCurrentProjectIds =
   fmap fst . preview projectBranchPathPrism <$> Cli.getCurrentPath
 
+-- | Like 'getCurrentProjectIds', but fails with a message if the user is not on a project branch.
+expectCurrentProjectIds :: Cli (ProjectAndBranch ProjectId ProjectBranchId)
+expectCurrentProjectIds =
+  getCurrentProjectIds & onNothingM (Cli.returnEarly Output.NotOnProjectBranch)
+
 -- | Get the current project+branch+branch path that a user is on.
 getCurrentProjectBranch :: Cli (Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path.Path))
 getCurrentProjectBranch = do

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

@@ -418,20 +418,21 @@ loop e = do
                 Cli.updateRoot newRoot description
                 Cli.respond Success
             ForkLocalBranchI src0 dest0 -> do
-              srcb <-
+              (srcb, branchEmpty) <-
                 case src0 of
-                  Left hash -> Cli.resolveShortCausalHash hash
-                  Right path' -> Cli.expectBranchAtPath' path'
-              Cli.assertNoBranchAtPath' dest0
+                  Left hash -> (, WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
+                  Right path' -> do
+                    absPath <- ProjectUtils.branchRelativePathToAbsolute path'
+                    let srcp = Path.convert absPath
+                    srcb <- Cli.expectBranchAtPath' srcp
+                    pure (srcb, WhichBranchEmptyPath srcp)
               description <- inputDescription input
-              dest <- Cli.resolvePath' dest0
+              dest <- ProjectUtils.branchRelativePathToAbsolute dest0
               ok <- Cli.updateAtM description dest (const $ pure srcb)
               Cli.respond
                 if ok
                   then Success
-                  else BranchEmpty case src0 of
-                    Left hash -> WhichBranchEmptyHash hash
-                    Right path -> WhichBranchEmptyPath path
+                  else BranchEmpty branchEmpty
             MergeLocalBranchI src0 dest0 mergeMode -> do
               description <- inputDescription input
               src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
@@ -1175,10 +1176,11 @@ loop e = do
 inputDescription :: Input -> Cli Text
 inputDescription input =
   case input of
-    ForkLocalBranchI src0 dest0 -> do
-      src <- hp' src0
-      dest <- p' dest0
-      pure ("fork " <> src <> " " <> dest)
+    SaveExecuteResultI _str -> pure "save-execute-result"
+    ForkLocalBranchI _src0 _dest0 -> do
+      -- src <- hp' src0
+      -- dest <- p' dest0
+      pure ("fork ") -- todo
     MergeLocalBranchI src0 dest0 mode -> do
       src <- looseCodeOrProjectToText src0
       dest <- looseCodeOrProjectToText dest0
@@ -1369,7 +1371,6 @@ inputDescription input =
     PushRemoteBranchI {} -> wat
     QuitI {} -> wat
     ReleaseDraftI {} -> wat
-    SaveExecuteResultI {} -> wat
     ShowDefinitionByPrefixI {} -> wat
     ShowDefinitionI {} -> wat
     ShowReflogI {} -> wat

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

@@ -15,6 +15,7 @@ module Unison.Codebase.Editor.Input
     AbsBranchId,
     LooseCodeOrProject,
     parseBranchId,
+    parseBranchId2,
     parseShortCausalHash,
     HashOrHQSplit',
     Insistence (..),
@@ -42,6 +43,7 @@ import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
 import Unison.Codebase.SyncMode (SyncMode)
 import Unison.Codebase.Verbosity
+import Unison.CommandLine.BranchRelativePath
 import Unison.HashQualified qualified as HQ
 import Unison.Name (Name)
 import Unison.NameSegment (NameSegment)
@@ -86,6 +88,12 @@ parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
   Just h -> pure $ Left h
 parseBranchId s = Right <$> Path.parsePath' s
 
+parseBranchId2 :: String -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath)
+parseBranchId2 ('#' : s) = case SCH.fromText (Text.pack s) of
+  Nothing -> Left "Invalid hash, expected a base32hex string."
+  Just h -> Right (Left h)
+parseBranchId2 s = Right <$> parseBranchRelativePath s
+
 parseShortCausalHash :: String -> Either String ShortCausalHash
 parseShortCausalHash ('#' : s) | Just sch <- SCH.fromText (Text.pack s) = Right sch
 parseShortCausalHash _ = Left "Invalid hash, expected a base32hex string."
@@ -102,7 +110,7 @@ data Input
     -- directory ops
     -- `Link` must describe a repo and a source path within that repo.
     -- clone w/o merge, error if would clobber
-    ForkLocalBranchI (Either ShortCausalHash Path') Path'
+    ForkLocalBranchI (Either ShortCausalHash BranchRelativePath) BranchRelativePath
   | -- merge first causal into destination
     MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode
   | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject

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

@@ -0,0 +1,74 @@
+module Unison.CommandLine.BranchRelativePath
+  ( BranchRelativePath (..),
+    parseBranchRelativePath,
+    branchRelativePathParser,
+  )
+where
+
+import Data.Char (isSpace)
+import Data.Set qualified as Set
+import Data.Text qualified as Text
+import Data.These (These (..))
+import Text.Megaparsec qualified as Megaparsec
+import Text.Megaparsec.Char qualified as Megaparsec
+import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.Path.Parse qualified as Path
+import Unison.Prelude
+import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName)
+import Unison.Project qualified as Project
+import Unison.Util.ColorText qualified as CT
+import Unison.Util.Pretty qualified as P
+
+data BranchRelativePath
+  = BranchRelative (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative)
+  | LoosePath Path.Path'
+  deriving stock (Eq, Show)
+
+parseBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) BranchRelativePath
+parseBranchRelativePath str =
+  case Megaparsec.parse branchRelativePathParser "<none>" (Text.pack str) of
+    Left e -> Left (P.string (Megaparsec.errorBundlePretty e))
+    Right x -> Right x
+
+branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
+branchRelativePathParser =
+  asum
+    [ LoosePath <$> path',
+      BranchRelative <$> branchRelative
+    ]
+  where
+    branchRelative :: Megaparsec.Parsec Void Text (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative)
+    branchRelative = asum [fullPath, currentBranchRootPath]
+
+    path' = Megaparsec.try do
+      offset <- Megaparsec.getOffset
+      pathStr <- Megaparsec.takeWhile1P (Just "path char") (not . isSpace)
+      case Path.parsePath' (Text.unpack pathStr) of
+        Left err -> failureAt offset err
+        Right x -> pure x
+
+    relPath = do
+      offset <- Megaparsec.getOffset
+      path' >>= \(Path.Path' inner) -> case inner of
+        Left _ -> failureAt offset "Expected a relative path but found an absolute path"
+        Right x -> pure x
+
+    fullPath = do
+      projectAndBranchNames <- do
+        projectBranch <- Project.projectAndBranchNamesParser ProjectBranchSpecifier'Name
+        offset <- Megaparsec.getOffset
+        _ <- Megaparsec.char ':'
+        case projectBranch of
+          This _ -> failureAt offset "Expected a project and branch before the colon (e.g. project/branch:a.path)"
+          That pbn -> pure (Left pbn)
+          These pn pbn -> pure (Right (pn, pbn))
+      optional relPath <&> \case
+        Nothing -> This projectAndBranchNames
+        Just rp -> These projectAndBranchNames rp
+
+    currentBranchRootPath = do
+      _ <- Megaparsec.char ':'
+      That <$> relPath
+
+    failureAt :: forall a. Int -> String -> Megaparsec.Parsec Void Text a
+    failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str)))

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

@@ -19,7 +19,7 @@ import Network.URI qualified as URI
 import System.Console.Haskeline.Completion (Completion (Completion))
 import System.Console.Haskeline.Completion qualified as Haskeline
 import System.Console.Haskeline.Completion qualified as Line
-import Text.Megaparsec qualified as P
+import Text.Megaparsec qualified as Megaparsec
 import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
 import U.Codebase.Sqlite.Project qualified as Sqlite
 import U.Codebase.Sqlite.Queries qualified as Queries
@@ -45,6 +45,7 @@ import Unison.Codebase.SyncMode qualified as SyncMode
 import Unison.Codebase.Verbosity (Verbosity)
 import Unison.Codebase.Verbosity qualified as Verbosity
 import Unison.CommandLine
+import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath)
 import Unison.CommandLine.Completion
 import Unison.CommandLine.FZFResolvers qualified as Resolvers
 import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions)
@@ -1175,9 +1176,9 @@ forkLocal =
     ]
     (makeExample forkLocal ["src", "dest"] <> "creates the namespace `dest` as a copy of `src`.")
     ( \case
-        [src, dest] -> first fromString $ do
-          src <- Input.parseBranchId src
-          dest <- Path.parsePath' dest
+        [src, dest] -> do
+          src <- Input.parseBranchId2 src
+          dest <- parseBranchRelativePath dest
           pure $ Input.ForkLocalBranchI src dest
         _ -> Left (I.help forkLocal)
     )
@@ -3512,7 +3513,7 @@ projectNameArg =
 
 parsePullSource :: Text -> Maybe (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease))
 parsePullSource =
-  P.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease)
+  Megaparsec.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease)
 
 -- | Parse a 'Input.PushSource'.
 parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource
@@ -3527,7 +3528,7 @@ parsePushSource sourceStr =
 -- | Parse a push target.
 parsePushTarget :: String -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName))
 parsePushTarget target =
-  case P.parseMaybe UriParser.writeRemoteNamespace (Text.pack target) of
+  case Megaparsec.parseMaybe UriParser.writeRemoteNamespace (Text.pack target) of
     Nothing -> Left (I.help push)
     Just path -> Right path
 
@@ -3549,7 +3550,7 @@ parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitR
 parseWriteGitRepo label input = do
   first
     (fromString . show) -- turn any parsing errors into a Pretty.
-    (P.parse (UriParser.writeGitRepo <* P.eof) label (Text.pack input))
+    (Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input))
 
 collectNothings :: (a -> Maybe b) -> [a] -> [a]
 collectNothings f as = [a | (Nothing, a) <- map f as `zip` as]
@@ -3570,23 +3571,23 @@ explainRemote pushPull =
   where
     gitRepo = PushPull.fold @(P.Pretty P.ColorText) "[email protected]:" "https://github.com/" pushPull
 
-showErrorFancy :: (P.ShowErrorComponent e) => P.ErrorFancy e -> String
-showErrorFancy (P.ErrorFail msg) = msg
-showErrorFancy (P.ErrorIndentation ord ref actual) =
+showErrorFancy :: (Megaparsec.ShowErrorComponent e) => Megaparsec.ErrorFancy e -> String
+showErrorFancy (Megaparsec.ErrorFail msg) = msg
+showErrorFancy (Megaparsec.ErrorIndentation ord ref actual) =
   "incorrect indentation (got "
-    <> show (P.unPos actual)
+    <> show (Megaparsec.unPos actual)
     <> ", should be "
     <> p
-    <> show (P.unPos ref)
+    <> show (Megaparsec.unPos ref)
     <> ")"
   where
     p = case ord of
       LT -> "less than "
       EQ -> "equal to "
       GT -> "greater than "
-showErrorFancy (P.ErrorCustom a) = P.showErrorComponent a
+showErrorFancy (Megaparsec.ErrorCustom a) = Megaparsec.showErrorComponent a
 
-showErrorItem :: P.ErrorItem (P.Token Text) -> String
-showErrorItem (P.Tokens ts) = P.showTokens (Proxy @Text) ts
-showErrorItem (P.Label label) = NE.toList label
-showErrorItem P.EndOfInput = "end of input"
+showErrorItem :: Megaparsec.ErrorItem (Megaparsec.Token Text) -> String
+showErrorItem (Megaparsec.Tokens ts) = Megaparsec.showTokens (Proxy @Text) ts
+showErrorItem (Megaparsec.Label label) = NE.toList label
+showErrorItem Megaparsec.EndOfInput = "end of input"

unison-cli/unison-cli.cabal

@@ -91,6 +91,7 @@ library
       Unison.Codebase.TranscriptParser
       Unison.Codebase.Watch
       Unison.CommandLine
+      Unison.CommandLine.BranchRelativePath
       Unison.CommandLine.Completion
       Unison.CommandLine.DisplayValues
       Unison.CommandLine.FuzzySelect

unison-src/transcripts/branch-relative-path.md

@@ -0,0 +1,31 @@
+```ucm:hide
+.> builtins.merge
+.> project.create-empty p0
+.> project.create-empty p1
+```
+
+```unison
+foo = 5
+foo.bar = 1
+```
+
+```ucm
+p0/main> add
+```
+
+```unison
+bonk = 5
+donk.bonk = 1
+```
+
+```ucm
+p1/main> add
+p1/main> fork p0/main: zzz
+p1/main> find zzz
+p1/main> fork p0/main:foo yyy
+p1/main> find yyy
+p0/main> fork p1/main: p0/main:p1
+p0/main> ls p1
+p0/main> ls p1.zzz
+p0/main> ls p1.yyy
+```