fix a few compiler errors and make a better push type

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

@@ -1737,7 +1737,7 @@ handleDependents hq = do
 -- | Handle a @gist@ command.
 handleGist :: MonadUnliftIO m => GistInput -> Action' m v ()
 handleGist (GistInput repo) =
-  doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing
+  doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit
 
 handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v ()
 handlePullFromUnisonShare remoteRepo remotePath = undefined
@@ -1752,47 +1752,42 @@ handlePullFromUnisonShare remoteRepo remotePath = undefined
 --   Right causalHash -> do
 --     undefined
 
--- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating
--- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only
--- uploaded for remote git repos, not remote Share repos).
-data PushFlavor f
-  = NormalPush (f WriteRemotePath) PushBehavior
-  | GistyPush (f WriteGitRepo)
-
 -- | Handle a @push@ command.
 handlePushRemoteBranch ::
   forall m v.
   MonadUnliftIO m =>
   -- | The repo to push to. If missing, it is looked up in `.unisonConfig`.
-  PushFlavor Maybe ->
+  Maybe WriteRemotePath ->
   -- | The local path to push. If relative, it's resolved relative to the current path (`cd`).
   Path' ->
+  -- | The push behavior (whether the remote branch is required to be empty or non-empty).
+  PushBehavior ->
   SyncMode.SyncMode ->
   Action' m v ()
-handlePushRemoteBranch pushFlavor0 path syncMode = do
-  resolvePushFlavor path pushFlavor0 >>= \case
-    Left output -> respond output
-    Right pushFlavor -> doPushRemoteBranch pushFlavor path syncMode
+handlePushRemoteBranch mayRepo path pushBehavior syncMode =
+  case mayRepo of
+    Nothing ->
+      runExceptT (resolveConfiguredUrl Push path) >>= \case
+        Left output -> respond output
+        Right repo -> push repo
+    Just repo -> push repo
+  where
+    push repo =
+      doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode
 
-resolvePushFlavor :: Path' -> PushFlavor Maybe -> Action' m v (Either (Output v) (PushFlavor Identity))
-resolvePushFlavor localPath = \case
-  NormalPush Nothing pushBehavior ->
-    runExceptT do
-      remotePath <- resolveConfiguredUrl Push localPath
-      pure (NormalPush (Identity (WriteRemotePathGit remotePath)) pushBehavior)
-  NormalPush (Just repo) pushBehavior -> pure (Right (NormalPush (Identity repo) pushBehavior))
-  GistyPush Nothing ->
-    runExceptT do
-      WriteGitRemotePath {repo} <- resolveConfiguredUrl Push localPath
-      pure (GistyPush (Identity repo))
-  GistyPush (Just repo) -> pure (Right (GistyPush (Identity repo)))
+-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating
+-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only
+-- uploaded for remote git repos, not remote Share repos).
+data PushFlavor
+  = NormalPush WriteRemotePath PushBehavior
+  | GistyPush WriteGitRepo
 
 -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@.
 doPushRemoteBranch ::
   forall m v.
   MonadUnliftIO m =>
   -- | The repo to push to.
-  PushFlavor Identity ->
+  PushFlavor ->
   -- | The local path to push. If relative, it's resolved relative to the current path (`cd`).
   Path' ->
   SyncMode.SyncMode ->
@@ -1803,7 +1798,7 @@ doPushRemoteBranch pushFlavor localPath syncMode = do
     getAt (Path.resolve currentPath' localPath)
 
   case pushFlavor of
-    NormalPush (Identity (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior ->
+    NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior ->
       unlessError do
         let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m))
             withRemoteRoot remoteRoot = do
@@ -1817,10 +1812,10 @@ doPushRemoteBranch pushFlavor localPath syncMode = do
         withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case
           Left output -> respond output
           Right _branch -> respond Success
-    NormalPush (Identity (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath})) pushBehavior ->
+    NormalPush (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath}) pushBehavior ->
       -- let (userSegment :| pathSegments) = undefined
       error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior"
-    GistyPush (Identity repo) -> do
+    GistyPush repo -> do
       unlessError do
         let opts = PushGitBranchOpts {setRoot = False, syncMode}
         withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)))
@@ -2214,14 +2209,14 @@ manageLinks silent srcs mdValues op = do
 resolveConfiguredUrl ::
   PushPull ->
   Path' ->
-  ExceptT (Output v) (Action m i v) WriteGitRemotePath
+  ExceptT (Output v) (Action m i v) WriteRemotePath
 resolveConfiguredUrl pushPull destPath' = ExceptT do
   currentPath' <- use LoopState.currentPath
   let destPath = Path.resolve currentPath' destPath'
   let configKey = gitUrlKey destPath
   (eval . ConfigLookup) configKey >>= \case
     Just url ->
-      case P.parse UriParser.writeGitRepoPath (Text.unpack configKey) url of
+      case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of
         Left e ->
           pure . Left $
             ConfiguredGitUrlParseError pushPull destPath' url (show e)

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

@@ -191,7 +191,7 @@ data Input
 
 -- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@.
 data GistInput = GistInput
-  { repo :: WriteRepo
+  { repo :: WriteGitRepo
   }
   deriving stock (Eq, Show)
 

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

@@ -1,6 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath, writeGitRepoPath) where
+module Unison.Codebase.Editor.UriParser
+  ( repoPath,
+    writeGitRepo,
+    writeRepo,
+    writeRepoPath,
+  )
+where
 
 import Data.Char (isAlphaNum, isDigit, isSpace)
 import Data.Sequence as Seq
@@ -9,7 +15,15 @@ import Data.Void
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as C
 import qualified Text.Megaparsec.Char.Lexer as L
-import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), WriteRepo (..))
+import Unison.Codebase.Editor.RemoteRepo
+  ( ReadGitRemoteNamespace (..),
+    ReadGitRepo (..),
+    ReadRemoteNamespace (..),
+    WriteGitRemotePath (..),
+    WriteGitRepo (..),
+    WriteRemotePath (..),
+    WriteRepo (..),
+  )
 import Unison.Codebase.Path (Path (..))
 import qualified Unison.Codebase.Path as Path
 import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
@@ -50,9 +64,9 @@ repoPath = P.label "generic git repo" $ do
         Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty}
         Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path}
 
+-- FIXME parse share paths too
 writeRepo :: P WriteRepo
 writeRepo =
-  -- FIXME parse share paths too
   WriteRepoGit <$> writeGitRepo
 
 writeGitRepo :: P WriteGitRepo

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

@@ -15,7 +15,7 @@ import qualified Unison.Codebase.Path as Path
 --   "release/M1j" -> "releases._M1j"
 --   "release/M1j.2" -> "releases._M1j_2"
 --   "latest-*" -> "trunk"
-defaultBaseLib :: Parsec Void Text ReadRemoteNamespace
+defaultBaseLib :: Parsec Void Text ReadGitRemoteNamespace
 defaultBaseLib = fmap makeNS $ latest <|> release
   where
     latest, release, version :: Parsec Void Text Text
@@ -23,19 +23,18 @@ defaultBaseLib = fmap makeNS $ latest <|> release
     release = fmap ("releases._" <>) $ "release/" *> version <* eof
     version = do
       Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-']))
-    makeNS :: Text -> ReadRemoteNamespace
+    makeNS :: Text -> ReadGitRemoteNamespace
     makeNS t =
-      ReadRemoteNamespaceGit
-        ReadGitRemoteNamespace
-          { repo =
-              ReadGitRepo
-                { url = "https://github.com/unisonweb/base",
-                  -- Use the 'v3' branch of base for now.
-                  -- We can revert back to the main branch once enough people have upgraded ucm and
-                  -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm
-                  -- release).
-                  ref = Just "v3"
-                },
-            sbh = Nothing,
-            path = Path.fromText t
-          }
+      ReadGitRemoteNamespace
+        { repo =
+            ReadGitRepo
+              { url = "https://github.com/unisonweb/base",
+                -- Use the 'v3' branch of base for now.
+                -- We can revert back to the main branch once enough people have upgraded ucm and
+                -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm
+                -- release).
+                ref = Just "v3"
+              },
+          sbh = Nothing,
+          path = Path.fromText t
+        }

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

@@ -21,7 +21,7 @@ import qualified Unison.Codebase.Branch.Merge as Branch
 import qualified Unison.Codebase.Branch.Names as Branch
 import Unison.Codebase.Editor.Input (Input)
 import qualified Unison.Codebase.Editor.Input as Input
-import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo)
+import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath)
 import qualified Unison.Codebase.Editor.SlurpResult as SR
 import qualified Unison.Codebase.Editor.UriParser as UriParser
 import qualified Unison.Codebase.Path as Path
@@ -1263,11 +1263,11 @@ prettyPrintParseError input = \case
           message = [expected] <> catMaybes [found]
        in P.oxfordCommasWith "." message
 
-parseWriteRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteRepo
-parseWriteRepo label input = do
+parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
+parseWriteGitRepo label input = do
   first
     (fromString . show) -- turn any parsing errors into a Pretty.
-    (P.parse UriParser.writeRepo label (Text.pack input))
+    (P.parse UriParser.writeGitRepo label (Text.pack input))
 
 parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath
 parsePushPath label input = do
@@ -2002,7 +2002,7 @@ gist =
     )
     ( \case
         [repoString] -> do
-          repo <- parseWriteRepo "repo" repoString
+          repo <- parseWriteGitRepo "repo" repoString
           pure (Input.GistI (Input.GistInput repo))
         _ -> Left (showPatternHelp gist)
     )

unison-cli/unison/Main.hs

@@ -50,7 +50,7 @@ import Text.Pretty.Simple (pHPrint)
 import Unison.Codebase (Codebase, CodebasePath)
 import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Editor.Input as Input
-import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
+import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace)
 import qualified Unison.Codebase.Editor.VersionParser as VP
 import Unison.Codebase.Execute (execute)
 import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..))
@@ -418,7 +418,7 @@ isFlag f arg = arg == f || arg == "-" ++ f || arg == "--" ++ f
 getConfigFilePath :: Maybe FilePath -> IO FilePath
 getConfigFilePath mcodepath = (FP.</> ".unisonConfig") <$> Codebase.getCodebaseDir mcodepath
 
-defaultBaseLib :: Maybe ReadRemoteNamespace
+defaultBaseLib :: Maybe ReadGitRemoteNamespace
 defaultBaseLib =
   rightMay $
     runParser VP.defaultBaseLib "version" gitRef