Merge pull request #4622 from unisonweb/travis/fork-improvements

Improve fork output and input description

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

@@ -3,6 +3,7 @@ module Unison.Cli.ProjectUtils
   ( -- * Project/path helpers
     getCurrentProject,
     expectCurrentProject,
+    expectCurrentProjectIds,
     getCurrentProjectIds,
     getCurrentProjectBranch,
     getProjectBranchForPath,
@@ -12,6 +13,7 @@ module Unison.Cli.ProjectUtils
     projectBranchPath,
     projectBranchSegment,
     projectBranchPathPrism,
+    resolveBranchRelativePath,
     branchRelativePathToAbsolute,
 
     -- * Name hydration
@@ -50,7 +52,7 @@ 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 (BranchRelativePath, ResolvedBranchRelativePath)
 import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
@@ -59,24 +61,37 @@ import Unison.Sqlite qualified as Sqlite
 import Witch (unsafeFrom)
 
 branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute
-branchRelativePathToAbsolute = \case
+branchRelativePathToAbsolute brp = resolveBranchRelativePath brp <&> \case
+  BranchRelativePath.ResolvedLoosePath p -> p
+  BranchRelativePath.ResolvedBranchRelative projectBranch mRel ->
+    let projectBranchIds = getIds projectBranch
+        handleRel = case mRel of
+          Nothing -> id
+          Just rel -> flip Path.resolve rel
+    in handleRel (projectBranchPath projectBranchIds)
+  where
+    getIds = \case
+      ProjectAndBranch project branch -> ProjectAndBranch (view #projectId project) (view #branchId branch)
+
+resolveBranchRelativePath :: BranchRelativePath -> Cli ResolvedBranchRelativePath
+resolveBranchRelativePath = \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)
+      projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
+      pure (BranchRelativePath.ResolvedBranchRelative projectBranch Nothing)
     That path -> do
-      projectBranch <- expectCurrentProjectIds
-      pure (Path.resolve (projectBranchPath projectBranch) path)
-  BranchRelativePath.LoosePath path -> Cli.resolvePath' path
+      (projectBranch, _) <- expectCurrentProjectBranch
+      pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
+    These projectBranch path -> do
+      projectBranch <- expectProjectAndBranchByTheseNames (toThese projectBranch)
+      pure (BranchRelativePath.ResolvedBranchRelative projectBranch (Just path))
+  BranchRelativePath.LoosePath path ->
+    BranchRelativePath.ResolvedLoosePath <$> 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)

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

@@ -10,7 +10,7 @@ where
 
 import Control.Error.Util qualified as ErrorUtil
 import Control.Exception (catch)
-import Control.Lens
+import Control.Lens hiding (from)
 import Control.Monad.Reader (ask)
 import Control.Monad.State (StateT)
 import Control.Monad.State qualified as State
@@ -122,6 +122,7 @@ import Unison.Codebase.TermEdit.Typing qualified as TermEdit
 import Unison.Codebase.TypeEdit (TypeEdit)
 import Unison.Codebase.TypeEdit qualified as TypeEdit
 import Unison.Codebase.Verbosity qualified as Verbosity
+import Unison.CommandLine.BranchRelativePath (BranchRelativePath)
 import Unison.CommandLine.Completion qualified as Completion
 import Unison.CommandLine.DisplayValues qualified as DisplayValues
 import Unison.CommandLine.InputPattern qualified as IP
@@ -422,7 +423,7 @@ loop e = do
             ForkLocalBranchI src0 dest0 -> do
               (srcb, branchEmpty) <-
                 case src0 of
-                  Left hash -> (, WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
+                  Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
                   Right path' -> do
                     absPath <- ProjectUtils.branchRelativePathToAbsolute path'
                     let srcp = Path.convert absPath
@@ -1175,10 +1176,10 @@ inputDescription :: Input -> Cli Text
 inputDescription input =
   case input of
     SaveExecuteResultI _str -> pure "save-execute-result"
-    ForkLocalBranchI _src0 _dest0 -> do
-      -- src <- hp' src0
-      -- dest <- p' dest0
-      pure ("fork ") -- todo
+    ForkLocalBranchI src0 dest0 -> do
+      src <- either (pure . Text.pack . show) brp src0
+      dest <- brp dest0
+      pure ("fork " <> src <> " " <> dest)
     MergeLocalBranchI src0 dest0 mode -> do
       src <- looseCodeOrProjectToText src0
       dest <- looseCodeOrProjectToText dest0
@@ -1383,6 +1384,8 @@ inputDescription input =
     hp' = either (pure . Text.pack . show) p'
     p' :: Path' -> Cli Text
     p' = fmap tShow . Cli.resolvePath'
+    brp :: BranchRelativePath -> Cli Text
+    brp = fmap from . ProjectUtils.resolveBranchRelativePath
     ops' :: Maybe Path.Split' -> Cli Text
     ops' = maybe (pure ".") ps'
     opatch :: Maybe Path.Split' -> Cli Text

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

@@ -2,15 +2,20 @@ module Unison.CommandLine.BranchRelativePath
   ( BranchRelativePath (..),
     parseBranchRelativePath,
     branchRelativePathParser,
+    ResolvedBranchRelativePath (..),
   )
 where
 
+import Control.Lens (view)
 import Data.Char (isSpace)
 import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Data.These (These (..))
+import Text.Builder qualified
 import Text.Megaparsec qualified as Megaparsec
 import Text.Megaparsec.Char qualified as Megaparsec
+import U.Codebase.Sqlite.Project qualified as Sqlite
+import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Path.Parse qualified as Path
 import Unison.Prelude
@@ -24,12 +29,68 @@ data BranchRelativePath
   | LoosePath Path.Path'
   deriving stock (Eq, Show)
 
+-- | Strings without colons are parsed as loose code paths. A path with a colon may specify:
+-- 1. A project and branch
+-- 2. Only a branch, in which case the project is assumed to be the current project
+-- 3. Only a path, in which case the path is rooted at the branch root
+--
+-- Specifying only a project is not allowed.
+--
+-- >>> parseBranchRelativePath "foo"
+-- Right (LoosePath foo)
+-- >>> parseBranchRelativePath "foo/bar:"
+-- Right (BranchRelative (This (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar"))))
+-- >>> parseBranchRelativePath "foo/bar:some.path"
+-- Right (BranchRelative (These (Right (UnsafeProjectName "foo",UnsafeProjectBranchName "bar")) some.path))
+-- >>> parseBranchRelativePath "/bar:some.path"
+-- Right (BranchRelative (These (Left (UnsafeProjectBranchName "bar")) some.path))
+-- >>> parseBranchRelativePath ":some.path"
+-- Right (BranchRelative (That some.path))
 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
 
+instance From BranchRelativePath Text where
+  from = \case
+    BranchRelative brArg -> case brArg of
+      This eitherProj ->
+        Text.Builder.run
+          ( Text.Builder.text (eitherProjToText eitherProj)
+              <> Text.Builder.char ':'
+          )
+      That path ->
+        Text.Builder.run
+          ( Text.Builder.char ':'
+              <> Text.Builder.text (Path.convert path)
+          )
+      These eitherProj path ->
+        Text.Builder.run
+          ( Text.Builder.text (eitherProjToText eitherProj)
+              <> Text.Builder.char ':'
+              <> Text.Builder.text (Path.convert path)
+          )
+    LoosePath path -> Path.toText' path
+    where
+      eitherProjToText = \case
+        Left branchName -> from @(These ProjectName ProjectBranchName) @Text (That branchName)
+        Right (projName, branchName) -> into @Text (These projName branchName)
+
+data ResolvedBranchRelativePath
+  = ResolvedBranchRelative (Project.ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative)
+  | ResolvedLoosePath Path.Absolute
+
+instance From ResolvedBranchRelativePath BranchRelativePath where
+  from = \case
+    ResolvedBranchRelative (Project.ProjectAndBranch proj branch) mRel -> case mRel of
+      Nothing -> BranchRelative (This (Right (view #name proj, view #name branch)))
+      Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel)
+    ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p)
+
+instance From ResolvedBranchRelativePath Text where
+  from = from . into @BranchRelativePath
+
 branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
 branchRelativePathParser =
   asum

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

@@ -1174,7 +1174,18 @@ forkLocal =
     [ ("namespace", Required, namespaceArg),
       ("new location", Required, newNameArg)
     ]
-    (makeExample forkLocal ["src", "dest"] <> "creates the namespace `dest` as a copy of `src`.")
+    ( P.wrapColumn2
+        [ ( makeExample forkLocal ["src", "dest"],
+            "creates the namespace `dest` as a copy of `src`."
+          ),
+          ( makeExample forkLocal ["project0/branch0:a.path", "project1/branch1:foo"],
+            "creates the namespace `foo` in `branch1` of `project1` as a copy of `a.path` in `project0/branch0`."
+          ),
+          ( makeExample forkLocal ["srcproject/srcbranch", "dest"],
+            "creates the namespace `dest` as a copy of the branch `srcbranch` of `srcproject`."
+          )
+        ]
+    )
     ( \case
         [src, dest] -> do
           src <- Input.parseBranchId2 src