Merge branch 'trunk' into cp/fzf-mkii

parser-typechecker/src/Unison/Codebase.hs

@@ -92,7 +92,6 @@ where
 
 import Control.Error (rightMay)
 import Control.Error.Util (hush)
-import Control.Monad.Except (ExceptT (ExceptT), runExceptT)
 import Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -134,6 +133,10 @@ import qualified Unison.UnisonFile as UF
 import qualified Unison.Util.Relation as Rel
 import Unison.Var (Var)
 import qualified Unison.WatchKind as WK
+import UnliftIO (MonadUnliftIO)
+import Control.Monad.Except (ExceptT(ExceptT))
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Trans.Except (throwE)
 
 -- | Get a branch from the codebase.
 getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m))
@@ -334,21 +337,21 @@ isBlank codebase = do
 -- otherwise we try to load the root branch.
 importRemoteBranch ::
   forall m v a.
-  MonadIO m =>
+  MonadUnliftIO m =>
   Codebase m v a ->
   ReadRemoteNamespace ->
   SyncMode ->
   m (Either GitError (Branch m))
-importRemoteBranch codebase ns mode = runExceptT do
-  (cleanup, branch, cacheDir) <- ExceptT $ viewRemoteBranch' codebase ns
-  withStatus "Importing downloaded files into local codebase..." $
-    time "SyncFromDirectory" $
-      lift $ syncFromDirectory codebase cacheDir mode branch
-  ExceptT
-    let h = Branch.headHash branch
-        err = Left . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns h
-     in time "load fresh local branch after sync" $
-          (getBranchForHash codebase h <&> maybe err Right) <* cleanup
+importRemoteBranch codebase ns mode = runExceptT $ do
+  branchHash <- ExceptT . viewRemoteBranch' codebase ns $ \(branch, cacheDir) -> do
+         withStatus "Importing downloaded files into local codebase..." $
+           time "SyncFromDirectory" $
+             syncFromDirectory codebase cacheDir mode branch
+         pure $ Branch.headHash branch
+  time "load fresh local branch after sync" $ do
+    lift (getBranchForHash codebase branchHash) >>= \case
+      Nothing -> throwE . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns branchHash
+      Just result -> pure $ result
 
 -- | Pull a git branch and view it from the cache, without syncing into the
 -- local codebase.
@@ -356,10 +359,10 @@ viewRemoteBranch ::
   MonadIO m =>
   Codebase m v a ->
   ReadRemoteNamespace ->
-  m (Either GitError (m (), Branch m))
-viewRemoteBranch codebase ns = runExceptT do
-  (cleanup, branch, _) <- ExceptT $ viewRemoteBranch' codebase ns
-  pure (cleanup, branch)
+  (Branch m -> m r) ->
+  m (Either GitError r)
+viewRemoteBranch codebase ns action =
+  viewRemoteBranch' codebase ns (\(b, _dir) -> action b)
 
 -- | Like 'getTerm', for when the term is known to exist in the codebase.
 unsafeGetTerm :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a)

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

@@ -12,8 +12,8 @@ module Unison.Codebase.Init
     Pretty,
     createCodebase,
     initCodebaseAndExit,
-    openOrCreateCodebase,
-    openNewUcmCodebaseOrExit,
+    withOpenOrCreateCodebase,
+    withNewUcmCodebaseOrExit,
   )
 where
 
@@ -27,16 +27,16 @@ import qualified Unison.PrettyTerminal as PT
 import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import UnliftIO.Directory (canonicalizePath)
-import Unison.Codebase.Init.CreateCodebaseError 
+import Unison.Codebase.Init.CreateCodebaseError
 
 -- CodebaseInitOptions is used to help pass around a Home directory that isn't the
 -- actual home directory of the user. Useful in tests.
-data CodebaseInitOptions 
+data CodebaseInitOptions
   = Home CodebasePath
   | Specified SpecifiedCodebase
 
-data SpecifiedCodebase 
-  = CreateWhenMissing CodebasePath 
+data SpecifiedCodebase
+  = CreateWhenMissing CodebasePath
   | DontCreateWhenMissing CodebasePath
 
 initOptionsToDir :: CodebaseInitOptions -> CodebasePath
@@ -48,67 +48,59 @@ type DebugName = String
 
 data Init m v a = Init
   { -- | open an existing codebase
-    openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)),
+    withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
     -- | create a new codebase
-    createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)),
+    withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
     -- | given a codebase root, and given that the codebase root may have other junk in it,
     -- give the path to the "actual" files; e.g. what a forked transcript should clone.
     codebasePath :: CodebasePath -> CodebasePath
   }
 
-type FinalizerAndCodebase m v a = (m (), Codebase m v a) 
-
-data InitError 
+data InitError
   = NoCodebaseFoundAtSpecifiedDir
   | FoundV1Codebase
   | CouldntCreateCodebase Pretty
 
-data InitResult m v a 
-  = OpenedCodebase CodebasePath (FinalizerAndCodebase m v a) 
-  | CreatedCodebase CodebasePath (FinalizerAndCodebase m v a) 
-  | Error CodebasePath InitError 
+data InitResult
+  = OpenedCodebase
+  | CreatedCodebase
+  deriving (Show, Eq)
 
-createCodebaseWithResult :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (InitResult m v a)
-createCodebaseWithResult cbInit debugName dir = 
-  createCodebase cbInit debugName dir >>= \case
-    Left errorMessage -> do
-      pure (Error dir (CouldntCreateCodebase errorMessage))
-    Right cb -> do
-      pure (CreatedCodebase dir cb)
+createCodebaseWithResult :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either (CodebasePath, InitError) r)
+createCodebaseWithResult cbInit debugName dir action =
+  createCodebase cbInit debugName dir action <&> mapLeft \case
+    errorMessage -> (dir, (CouldntCreateCodebase errorMessage))
 
-whenNoV1Codebase :: MonadIO m => CodebasePath -> m (InitResult m v a) -> m (InitResult m v a )
-whenNoV1Codebase dir initResult =
-  ifM (FCC.codebaseExists dir)
-    (pure (Error dir FoundV1Codebase))
-    initResult
-
-openOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseInitOptions -> m (InitResult m v a)
-openOrCreateCodebase cbInit debugName initOptions = do
+withOpenOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseInitOptions -> ((InitResult, CodebasePath, Codebase m v a) -> m r) -> m (Either (CodebasePath, InitError) r)
+withOpenOrCreateCodebase cbInit debugName initOptions action = do
   let resolvedPath = initOptionsToDir initOptions
-  openCodebase cbInit debugName resolvedPath >>= \case 
-    Right cb -> pure (OpenedCodebase resolvedPath cb)
+  result <- withOpenCodebase cbInit debugName resolvedPath $ \codebase -> do
+    action (OpenedCodebase, resolvedPath, codebase)
+  case result of
+    Right r -> pure $ Right r
     Left _ ->
       case initOptions of
         Home homeDir -> do
           ifM (FCC.codebaseExists homeDir)
-            (do pure (Error homeDir FoundV1Codebase))
+            (do pure (Left (homeDir, FoundV1Codebase)))
             (do
               -- Create V2 codebase if neither a V1 or V2 exists
-              createCodebaseWithResult cbInit debugName homeDir
+              createCodebaseWithResult cbInit debugName homeDir (\codebase -> action (CreatedCodebase, homeDir, codebase))
             )
 
         Specified specified ->
-          whenNoV1Codebase resolvedPath $ do 
+          ifM (FCC.codebaseExists resolvedPath)
+            (pure $ Left (resolvedPath, FoundV1Codebase))
             case specified of
-              DontCreateWhenMissing dir ->
-                pure (Error dir NoCodebaseFoundAtSpecifiedDir)
-              CreateWhenMissing dir ->
-                createCodebaseWithResult cbInit debugName dir
+               DontCreateWhenMissing dir ->
+                 pure (Left (dir, NoCodebaseFoundAtSpecifiedDir))
+               CreateWhenMissing dir ->
+                 createCodebaseWithResult cbInit debugName dir (\codebase -> action (CreatedCodebase, dir, codebase))
 
-createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a))
-createCodebase cbInit debugName path = do
+createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r)
+createCodebase cbInit debugName path action = do
   prettyDir <- P.string <$> canonicalizePath path
-  createCodebase' cbInit debugName path <&> mapLeft \case
+  withCreatedCodebase cbInit debugName path action <&> mapLeft \case
     CreateCodebaseAlreadyExists ->
       P.wrap $
         "It looks like there's already a codebase in: "
@@ -125,21 +117,19 @@ createCodebase cbInit debugName path = do
 
 -- previously: initCodebaseOrExit :: CodebasePath -> m (m (), Codebase m v a)
 -- previously: FileCodebase.initCodebase :: CodebasePath -> m (m (), Codebase m v a)
-openNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> m (m (), Codebase m Symbol Ann)
-openNewUcmCodebaseOrExit cbInit debugName path = do
+withNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> (Codebase m Symbol Ann -> m r) -> m r
+withNewUcmCodebaseOrExit cbInit debugName path action = do
   prettyDir <- P.string <$> canonicalizePath path
-  createCodebase cbInit debugName path >>= \case
+  let codebaseSetup codebase = do
+        liftIO $ PT.putPrettyLn' . P.wrap $ "Initializing a new codebase in: " <> prettyDir
+        Codebase.installUcmDependencies codebase
+  createCodebase cbInit debugName path (\cb -> codebaseSetup cb *> action cb) >>=
+    \case
     Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure
-    Right x@(_, codebase) -> do
-      liftIO $
-        PT.putPrettyLn'
-          . P.wrap
-          $ "Initializing a new codebase in: "
-            <> prettyDir
-      Codebase.installUcmDependencies codebase
-      pure x
+    Right result -> pure result
 
 -- | try to init a codebase where none exists and then exit regardless (i.e. `ucm --codebase dir init`)
-initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m () 
-initCodebaseAndExit i debugName mdir =
-  void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir
+initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m ()
+initCodebaseAndExit i debugName mdir = do
+  codebaseDir <- Codebase.getCodebaseDir mdir
+  withNewUcmCodebaseOrExit i debugName  codebaseDir (const $ pure ())

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

@@ -1,13 +1,19 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
-module Unison.Codebase.ShortBranchHash where
+module Unison.Codebase.ShortBranchHash
+  ( toString,
+    toHash,
+    fromHash,
+    fullFromHash,
+    fromText,
+    ShortBranchHash (..),
+  )
+where
 
-import Unison.Prelude
-import qualified Unison.Hash as Hash
-import qualified Data.Text as Text
 import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Unison.Hash as Hash
+import Unison.Prelude
 
-newtype ShortBranchHash =
-  ShortBranchHash { toText :: Text } -- base32hex characters
+newtype ShortBranchHash = ShortBranchHash {toText :: Text} -- base32hex characters
   deriving stock (Eq, Ord, Generic)
 
 toString :: ShortBranchHash -> String
@@ -26,9 +32,10 @@ fullFromHash = ShortBranchHash . Hash.base32Hex . coerce
 -- abc -> SBH abc
 -- #abc -> SBH abc
 fromText :: Text -> Maybe ShortBranchHash
-fromText (Text.dropWhile (=='#') -> t)
-  | Text.all (`Set.member` Hash.validBase32HexChars) t = Just
-  $ ShortBranchHash t
+fromText (Text.dropWhile (== '#') -> t)
+  | Text.all (`Set.member` Hash.validBase32HexChars) t =
+    Just $
+      ShortBranchHash t
 fromText _ = Nothing
 
 instance Show ShortBranchHash where

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

@@ -15,7 +15,7 @@ where
 import qualified Control.Concurrent
 import qualified Control.Exception
 import Control.Monad (filterM, unless, when, (>=>))
-import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError), runExceptT, withExceptT)
+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT, withExceptT)
 import qualified Control.Monad.Except as Except
 import Control.Monad.Extra (ifM, unlessM)
 import qualified Control.Monad.Extra as Monad
@@ -28,7 +28,7 @@ import Data.Bifunctor (Bifunctor (bimap), second)
 import qualified Data.Char as Char
 import qualified Data.Either.Combinators as Either
 import Data.Foldable (Foldable (toList), for_, traverse_)
-import Data.Functor (void, ($>), (<&>))
+import Data.Functor (void, (<&>))
 import qualified Data.List as List
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -106,7 +106,8 @@ import Unison.Type (Type)
 import qualified Unison.Type as Type
 import qualified Unison.Util.Pretty as P
 import qualified Unison.WatchKind as UF
-import UnliftIO (MonadIO, catchIO, finally, liftIO, MonadUnliftIO)
+import UnliftIO (MonadIO, catchIO, finally, liftIO, MonadUnliftIO, throwIO)
+import qualified UnliftIO
 import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import UnliftIO.STM
 import UnliftIO.Exception (bracket)
@@ -124,14 +125,19 @@ v2dir :: FilePath -> FilePath
 v2dir root = root </> ".unison" </> "v2"
 
 init :: HasCallStack => (MonadUnliftIO m) => Codebase.Init m Symbol Ann
-init = Codebase.Init getCodebaseOrError createCodebaseOrError v2dir
+init = Codebase.Init
+  { withOpenCodebase=getCodebaseOrError
+  , withCreatedCodebase=createCodebaseOrError
+  , codebasePath=v2dir
+  }
 
 createCodebaseOrError ::
   (MonadUnliftIO m) =>
   Codebase.DebugName ->
   CodebasePath ->
-  m (Either Codebase1.CreateCodebaseError (m (), Codebase m Symbol Ann))
-createCodebaseOrError debugName dir = do
+  (Codebase m Symbol Ann -> m r) ->
+  m (Either Codebase1.CreateCodebaseError r)
+createCodebaseOrError debugName dir action = do
   prettyDir <- P.string <$> canonicalizePath dir
   let convertError = \case
         CreateCodebaseAlreadyExists -> Codebase1.CreateCodebaseAlreadyExists
@@ -139,7 +145,7 @@ createCodebaseOrError debugName dir = do
       prettyError :: SchemaVersion -> Codebase1.Pretty
       prettyError v = P.wrap $
         "I don't know how to handle " <> P.shown v <> "in" <> P.backticked' prettyDir "."
-  Either.mapLeft convertError <$> createCodebaseOrError' debugName dir
+  Either.mapLeft convertError <$> createCodebaseOrError' debugName dir action
 
 data CreateCodebaseError
   = CreateCodebaseAlreadyExists
@@ -150,8 +156,9 @@ createCodebaseOrError' ::
   (MonadUnliftIO m) =>
   Codebase.DebugName ->
   CodebasePath ->
-  m (Either CreateCodebaseError (m (), Codebase m Symbol Ann))
-createCodebaseOrError' debugName path = do
+  (Codebase m Symbol Ann -> m r) ->
+  m (Either CreateCodebaseError r)
+createCodebaseOrError' debugName path action = do
   ifM
     (doesFileExist $ path </> codebasePath)
     (pure $ Left CreateCodebaseAlreadyExists)
@@ -166,7 +173,7 @@ createCodebaseOrError' debugName path = do
                 Right () -> pure ()
           )
 
-      fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path)
+      fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action)
 
 openOrCreateCodebaseConnection ::
   MonadIO m =>
@@ -181,19 +188,20 @@ openOrCreateCodebaseConnection debugName path = do
 
 -- get the codebase in dir
 getCodebaseOrError ::
-  forall m.
+  forall m r.
   (MonadUnliftIO m) =>
   Codebase.DebugName ->
   CodebasePath ->
-  m (Either Codebase1.Pretty (m (), Codebase m Symbol Ann))
-getCodebaseOrError debugName dir = do
+  (Codebase m Symbol Ann -> m r) ->
+  m (Either Codebase1.Pretty r)
+getCodebaseOrError debugName dir action = do
   prettyDir <- liftIO $ P.string <$> canonicalizePath dir
   let prettyError v = P.wrap $ "I don't know how to handle " <> P.shown v <> "in" <> P.backticked' prettyDir "."
   doesFileExist (dir </> codebasePath) >>= \case
     -- If the codebase file doesn't exist, just return any string. The string is currently ignored (see
     -- Unison.Codebase.Init.getCodebaseOrExit).
     False -> pure (Left "codebase doesn't exist")
-    True -> fmap (Either.mapLeft prettyError) (sqliteCodebase debugName dir)
+    True -> fmap (Either.mapLeft prettyError) (sqliteCodebase debugName dir action)
 
 initSchemaIfNotExist :: MonadIO m => FilePath -> m ()
 initSchemaIfNotExist path = liftIO do
@@ -207,9 +215,9 @@ codebaseExists :: MonadIO m => CodebasePath -> m Bool
 codebaseExists root = liftIO do
   Monad.when debug $ traceM $ "codebaseExists " ++ root
   Control.Exception.catch @Sqlite.SQLError
-    ( sqliteCodebase "codebaseExists" root >>= \case
+    ( sqliteCodebase "codebaseExists" root (const $ pure ()) >>= \case
         Left _ -> pure False
-        Right (close, _codebase) -> close $> True
+        Right _ -> pure True
     )
     (const $ pure False)
 
@@ -303,10 +311,11 @@ sqliteCodebase ::
   (MonadUnliftIO m) =>
   Codebase.DebugName ->
   CodebasePath ->
-  m (Either SchemaVersion (m (), Codebase m Symbol Ann))
-sqliteCodebase debugName root = do
-  Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root
-  (closeConn, conn) <- unsafeGetConnection debugName root
+  (Codebase m Symbol Ann -> m r) ->
+  m (Either SchemaVersion r)
+sqliteCodebase debugName root action = do
+ Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root
+ withConnection debugName root $ \conn -> do
   termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
   typeOfTermCache <- Cache.semispaceCache 8192
   declCache <- Cache.semispaceCache 1024
@@ -776,9 +785,46 @@ sqliteCodebase debugName root = do
                        runDB conn
                          . (fmap . fmap) Cv.causalHash2to1
                          $ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2
+      let
+       codebase = C.Codebase
+        (Cache.applyDefined termCache getTerm)
+        (Cache.applyDefined typeOfTermCache getTypeOfTermImpl)
+        (Cache.applyDefined declCache getTypeDeclaration)
+        putTerm
+        putTypeDeclaration
+        (getRootBranch rootBranchCache)
+        (putRootBranch rootBranchCache)
+        (rootBranchUpdates rootBranchCache)
+        getBranchForHash
+        putBranch
+        isCausalHash
+        getPatch
+        putPatch
+        patchExists
+        dependentsImpl
+        syncFromDirectory
+        syncToDirectory
+        viewRemoteBranch'
+        (\b r opts -> pushGitBranch conn b r opts)
+        watches
+        getWatch
+        putWatch
+        clearWatches
+        getReflog
+        appendReflog
+        termsOfTypeImpl
+        termsMentioningTypeImpl
+        hashLength
+        termReferencesByPrefix
+        declReferencesByPrefix
+        referentsByPrefix
+        branchHashLength
+        branchHashesByPrefix
+        (Just sqlLca)
+        (Just \l r -> runDB conn $ fromJust <$> before l r)
+
       let finalizer :: MonadIO m => m ()
           finalizer = do
-            liftIO $ closeConn
             decls <- readTVarIO declBuffer
             terms <- readTVarIO termBuffer
             let printBuffer header b =
@@ -788,49 +834,8 @@ sqliteCodebase debugName root = do
                       else pure ()
             printBuffer "Decls:" decls
             printBuffer "Terms:" terms
-
-      pure . Right $
-        ( finalizer,
-          let
-           code = C.Codebase
-            (Cache.applyDefined termCache getTerm)
-            (Cache.applyDefined typeOfTermCache getTypeOfTermImpl)
-            (Cache.applyDefined declCache getTypeDeclaration)
-            putTerm
-            putTypeDeclaration
-            (getRootBranch rootBranchCache)
-            (putRootBranch rootBranchCache)
-            (rootBranchUpdates rootBranchCache)
-            getBranchForHash
-            putBranch
-            isCausalHash
-            getPatch
-            putPatch
-            patchExists
-            dependentsImpl
-            syncFromDirectory
-            syncToDirectory
-            viewRemoteBranch'
-            (pushGitBranch conn)
-            watches
-            getWatch
-            putWatch
-            clearWatches
-            getReflog
-            appendReflog
-            termsOfTypeImpl
-            termsMentioningTypeImpl
-            hashLength
-            termReferencesByPrefix
-            declReferencesByPrefix
-            referentsByPrefix
-            branchHashLength
-            branchHashesByPrefix
-            (Just sqlLca)
-            (Just \l r -> runDB conn $ fromJust <$> before l r)
-          in code
-        )
-    v -> liftIO closeConn $> Left v
+      (Right <$> action codebase) `finally` finalizer
+    v -> pure $ Left v
 
 -- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide
 termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection (ExceptT Ops.Error m) Bool
@@ -1047,47 +1052,48 @@ syncProgress = Sync.Progress need done warn allDone
         v = const ()
 
 viewRemoteBranch' ::
-  forall m.
+  forall m r.
   (MonadUnliftIO m) =>
   ReadRemoteNamespace ->
-  m (Either C.GitError (m (), Branch m, CodebasePath))
-viewRemoteBranch' (repo, sbh, path) = runExceptT @C.GitError do
+  ((Branch m, CodebasePath) -> m r) ->
+  m (Either C.GitError r)
+viewRemoteBranch' (repo, sbh, path) action = UnliftIO.try $ do
   -- set up the cache dir
-  remotePath <- time "Git fetch" . withExceptT C.GitProtocolError $ pullBranch repo
-  ifM @(ExceptT C.GitError m)
-    (codebaseExists remotePath)
-    do
-      lift (sqliteCodebase "viewRemoteBranch.gitCache" remotePath) >>= \case
-        Left sv -> ExceptT . pure . Left . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath sv
-        Right (closeCodebase, codebase) -> do
-          -- try to load the requested branch from it
-          branch <- time "Git fetch (sbh)" $ case sbh of
-            -- no sub-branch was specified, so use the root.
-            Nothing ->
-              lift (time "Get remote root branch" $ Codebase1.getRootBranch codebase) >>= \case
-                -- this NoRootBranch case should probably be an error too.
-                Left Codebase1.NoRootBranch -> pure Branch.empty
-                Left (Codebase1.CouldntLoadRootBranch h) ->
-                  throwError . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h
-                Left (Codebase1.CouldntParseRootBranch s) ->
-                  throwError . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s
-                Right b -> pure b
-            -- load from a specific `ShortBranchHash`
-            Just sbh -> do
-              branchCompletions <- lift $ Codebase1.branchHashesByPrefix codebase sbh
-              case toList branchCompletions of
-                [] -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
-                [h] ->
-                  lift (Codebase1.getBranchForHash codebase h) >>= \case
-                    Just b -> pure b
-                    Nothing -> throwError . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
-                _ -> throwError . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
-          case Branch.getAt path branch of
-            Just b -> pure (closeCodebase, b, remotePath)
-            Nothing -> throwError . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
-    -- else there's no initialized codebase at this repo; we pretend there's an empty one.
+  remotePath <- (UnliftIO.fromEitherM . runExceptT . withExceptT C.GitProtocolError . time "Git fetch" $ pullBranch repo)
+  codebaseExists remotePath >>= \case
+    -- If there's no initialized codebase at this repo; we pretend there's an empty one.
     -- I'm thinking we should probably return an error value instead.
-    (pure (pure (), Branch.empty, remotePath))
+    False -> action (Branch.empty, remotePath)
+    True -> do
+      result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath $ \codebase -> do
+             -- try to load the requested branch from it
+             branch <- time "Git fetch (sbh)" $ case sbh of
+               -- no sub-branch was specified, so use the root.
+               Nothing ->
+                 (time "Get remote root branch" $ Codebase1.getRootBranch codebase) >>= \case
+                   -- this NoRootBranch case should probably be an error too.
+                   Left Codebase1.NoRootBranch -> pure Branch.empty
+                   Left (Codebase1.CouldntLoadRootBranch h) ->
+                     throwIO . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h
+                   Left (Codebase1.CouldntParseRootBranch s) ->
+                     throwIO . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s
+                   Right b -> pure b
+               -- load from a specific `ShortBranchHash`
+               Just sbh -> do
+                 branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh
+                 case toList branchCompletions of
+                   [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
+                   [h] ->
+                     (Codebase1.getBranchForHash codebase h) >>= \case
+                       Just b -> pure b
+                       Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
+                   _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
+             case Branch.getAt path branch of
+               Just b -> action (b, remotePath)
+               Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
+      case result of
+        Left schemaVersion -> throwIO . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath schemaVersion
+        Right inner -> pure inner
 
 -- Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after
 -- the existing root.

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

@@ -90,7 +90,7 @@ data Codebase m v a = Codebase
     syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
     -- | Copy a branch and all of its dependencies from this codebase into the given codebase.
     syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
-    viewRemoteBranch' :: ReadRemoteNamespace -> m (Either GitError (m (), Branch m, CodebasePath)),
+    viewRemoteBranch' :: forall r. ReadRemoteNamespace -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r),
     -- | Push the given branch to the given repo, and optionally set it as the root branch.
     pushGitBranch :: Branch m -> WriteRepo -> PushGitBranchOpts -> m (Either GitError ()),
     -- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be
@@ -166,3 +166,5 @@ data GitError
   | GitCodebaseError (GitCodebaseError Branch.Hash)
   | GitSqliteCodebaseError GitSqliteCodebaseError
   deriving (Show)
+
+instance Exception GitError

parser-typechecker/tests/Unison/Test/Codebase/Causal.hs

@@ -1,124 +1,52 @@
 {- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
 {-# LANGUAGE PartialTypeSignatures #-}
 
-module Unison.Test.Codebase.Causal where
+module Unison.Test.Codebase.Causal (test) where
 
-import EasyTest
-import Unison.Codebase.Causal ( Causal(Cons, Merge)
-                              , RawHash(..)
-                              , one
-                              , currentHash
-                              , before
-                              )
-import qualified Unison.Codebase.Causal as Causal
-import qualified Unison.Codebase.Causal.FoldHistory as Causal
-import Control.Monad.Trans.State (State, state, put)
-import Data.Int (Int64)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
 import Control.Monad (replicateM_)
-import Control.Monad.Extra (ifM)
-import Control.Applicative (liftA2)
-import Data.List (foldl1')
-import Data.Functor ((<&>))
-import Unison.Hashable (Hashable)
+import Data.Functor.Identity (Identity (runIdentity))
+import Data.Int (Int64)
 import Data.Set (Set)
-import Data.Functor.Identity
+import qualified Data.Set as Set
+import EasyTest
+import Unison.Codebase.Causal (Causal, one)
+import qualified Unison.Codebase.Causal as Causal
 import Unison.Hash (Hash)
 
-c :: M (Causal M Int64 [Int64])
-c = merge (foldr cons (one [1]) t1)
-          (foldr cons (foldr cons (one [1]) t2) t3)
-  where
-  t1, t2, t3 :: [[Int64]]
-  t1 = fmap pure [5,4..2]
-  t2 = fmap pure [100..105]
-  t3 = fmap pure [999,998]
-
-c2 :: M (Causal M Int64 [Int64])
-c2 = merge (foldr cons (one [1]) t1)
-          (foldr cons (foldr cons (one [1]) t2) t3)
-  where
-  t1, t2, t3 :: [[Int64]]
-  t1 = fmap pure [5,4..2]
-  t2 = fmap pure [10,9..2]
-  t3 = fmap pure [999,998]
-
-{-
-λ> show Unison.Test.Codebase.Causal.c
-"Identity Merge 4gP [999,5] [\"3rG\",\"58U\"]"
-λ> runIdentity Unison.Test.Codebase.Causal.result
-step a=fromList [1,10] seen=[] rest=fromList [Merge 4gP [999,5] ["3rG","58U"]]
-step a=fromList [1,10] seen=["4gP"] rest=fromList [Cons 3rG [999] 4LX,Cons 58U [5] 4vC]
-step a=fromList [1,10] seen=["3rG","4gP"] rest=fromList [Cons 58U [5] 4vC,Cons 4LX [998] 26J]
-step a=fromList [1,10] seen=["3rG","4gP","58U"] rest=fromList [Cons 4LX [998] 26J,Cons 4vC [4] yFt]
-step a=fromList [1,10] seen=["3rG","4LX","4gP","58U"] rest=fromList [Cons 4vC [4] yFt,Cons 26J [100] 4FR]
-step a=fromList [1,10] seen=["3rG","4LX","4gP","4vC","58U"] rest=fromList [Cons 26J [100] 4FR,Cons yFt [3] 3So]
-step a=fromList [1,10] seen=["26J","3rG","4LX","4gP","4vC","58U"] rest=fromList [Cons yFt [3] 3So,Cons 4FR [101] 4az]
-step a=fromList [1,10] seen=["yFt","26J","3rG","4LX","4gP","4vC","58U"] rest=fromList [Cons 4FR [101] 4az,Cons 3So [2] 5Lu]
-step a=fromList [1,10] seen=["yFt","26J","3rG","4FR","4LX","4gP","4vC","58U"] rest=fromList [Cons 3So [2] 5Lu,Cons 4az [102] 2V3]
-step a=fromList [1,10] seen=["yFt","26J","3So","3rG","4FR","4LX","4gP","4vC","58U"] rest=fromList [Cons 4az [102] 2V3,One 5Lu [1]]
-step a=fromList [1,10] seen=["yFt","26J","3So","3rG","4FR","4LX","4az","4gP","4vC","58U"] rest=fromList [One 5Lu [1],Cons 2V3 [103] 5pS]
-step a=fromList [10] seen=["yFt","26J","3So","3rG","4FR","4LX","4az","4gP","4vC","58U","5Lu"] rest=fromList [Cons 2V3 [103] 5pS]
-step a=fromList [10] seen=["yFt","26J","2V3","3So","3rG","4FR","4LX","4az","4gP","4vC","58U","5Lu"] rest=fromList [Cons 5pS [104] 2tq]
-step a=fromList [10] seen=["yFt","26J","2V3","3So","3rG","4FR","4LX","4az","4gP","4vC","58U","5Lu","5pS"] rest=fromList [Cons 2tq [105] 5Lu]
-step a=fromList [10] seen=["yFt","26J","2V3","2tq","3So","3rG","4FR","4LX","4az","4gP","4vC","58U","5Lu","5pS"] rest=fromList [One 5Lu [1]]
-step a=fromList [10] seen=["yFt","26J","2V3","2tq","3So","3rG","4FR","4LX","4az","4gP","4vC","58U","5Lu","5pS"] rest=fromList []
-Unsatisfied (fromList [10])
-
-λ> runIdentity Unison.Test.Codebase.Causal.result (with c2)
-step a=fromList [1,10] seen=[] rest=fromList [Cons 2tg [999] 3AW]
-step a=fromList [1,10] seen=["2tg"] rest=fromList [Cons 3AW [998] 33b]
-step a=fromList [1,10] seen=["2tg","3AW"] rest=fromList [Cons 33b [10] 2NF]
-step a=fromList [1] seen=["2tg","33b","3AW"] rest=fromList [Cons 2NF [9] 57i]
-step a=fromList [1] seen=["2NF","2tg","33b","3AW"] rest=fromList [Cons 57i [8] ipV]
-step a=fromList [1] seen=["2NF","2tg","33b","3AW","57i"] rest=fromList [Cons ipV [7] 3BZ]
-step a=fromList [1] seen=["ipV","2NF","2tg","33b","3AW","57i"] rest=fromList [Cons 3BZ [6] 58U]
-step a=fromList [1] seen=["ipV","2NF","2tg","33b","3AW","3BZ","57i"] rest=fromList [Cons 58U [5] 4vC]
-step a=fromList [1] seen=["ipV","2NF","2tg","33b","3AW","3BZ","57i","58U"] rest=fromList [Cons 4vC [4] yFt]
-step a=fromList [1] seen=["ipV","2NF","2tg","33b","3AW","3BZ","4vC","57i","58U"] rest=fromList [Cons yFt [3] 3So]
-step a=fromList [1] seen=["ipV","yFt","2NF","2tg","33b","3AW","3BZ","4vC","57i","58U"] rest=fromList [Cons 3So [2] 5Lu]
-step a=fromList [1] seen=["ipV","yFt","2NF","2tg","33b","3AW","3BZ","3So","4vC","57i","58U"] rest=fromList [One 5Lu [1]]
-Satisfied (fromList [])
-λ>
-
--}
-
 test :: Test ()
 test =
   scope "causal"
     . tests
     $ [ scope "threeWayMerge.ex1"
-        .  expect
-        $  Causal.head testThreeWay
-        == Set.fromList [3, 4]
-      , scope "threeWayMerge.idempotent"
-        .  expect
-        $  testIdempotent oneCausal -- == oneCausal
-        --  $  prop_mergeIdempotent
-
-      , scope "threeWayMerge.identity"
-        .  expect
-        $  testIdentity oneCausal emptyCausal
+          . expect
+          $ Causal.head testThreeWay
+            == Set.fromList [3, 4],
+        scope "threeWayMerge.idempotent"
+          . expect
+          $ testIdempotent oneCausal, -- == oneCausal
+          --  $  prop_mergeIdempotent
+        scope "threeWayMerge.identity"
+          . expect
+          $ testIdentity oneCausal emptyCausal,
         --  $  prop_mergeIdentity
-      , scope "threeWayMerge.commutative"
-        .  expect
-        $  testCommutative (Set.fromList [3,4]) oneRemoved
+        scope "threeWayMerge.commutative"
+          . expect
+          $ testCommutative (Set.fromList [3, 4]) oneRemoved,
         --  $  prop_mergeCommutative
-          {- , scope "threeWayMerge.commonAncestor"
+        {- , scope "threeWayMerge.commonAncestor"
         .  expect
         $  testCommonAncestor
         -- $  prop_mergeCommonAncestor --}
-      , scope "lca.hasLca" lcaPairTest
-      , scope "lca.noLca" noLcaPairTest
-      , scope "beforeHash" $ beforeHashTests
-    ]
+        scope "lca.hasLca" lcaPairTest,
+        scope "lca.noLca" noLcaPairTest,
+        scope "beforeHash" $ beforeHashTests
+      ]
 
 beforeHashTests :: Test ()
 beforeHashTests = do
   -- c1 and c2 have unrelated histories
-  c1  <- pure $ Causal.one (0 :: Int64)
-  c2  <- pure $ Causal.one (1 :: Int64)
+  c1 <- pure $ Causal.one (0 :: Int64)
+  c2 <- pure $ Causal.one (1 :: Int64)
   -- c1' and c2' are extension of c1 and c2, respectively
   c1' <- pure $ Causal.cons 2 c1
   c2' <- pure $ Causal.cons 3 c2
@@ -149,14 +77,14 @@ beforeHashTests = do
 int64 :: Test Int64
 int64 = random
 
-extend
-  :: Int
-  -> Causal Identity Hash Int64
-  -> Test (Causal Identity Hash Int64)
+extend ::
+  Int ->
+  Causal Identity Hash Int64 ->
+  Test (Causal Identity Hash Int64)
 extend 0 ca = pure ca
 extend n ca = do
   i <- int64
-  extend (n-1) (Causal.cons i ca)
+  extend (n -1) (Causal.cons i ca)
 
 lcaPair :: Test (Causal Identity Hash Int64, Causal Identity Hash Int64)
 lcaPair = do
@@ -168,12 +96,13 @@ lcaPair = do
 lcaPairTest :: Test ()
 lcaPairTest = replicateM_ 50 test >> ok
   where
-  test = runIdentity . uncurry Causal.lca <$> lcaPair >>= \case
-    Just _  -> pure ()
-    Nothing -> crash "expected lca"
+    test =
+      runIdentity . uncurry Causal.lca <$> lcaPair >>= \case
+        Just _ -> pure ()
+        Nothing -> crash "expected lca"
 
-noLcaPair
-  :: Test (Causal Identity Hash Int64, Causal Identity Hash Int64)
+noLcaPair ::
+  Test (Causal Identity Hash Int64, Causal Identity Hash Int64)
 noLcaPair = do
   basel <- one <$> int64
   baser <- one <$> int64
@@ -184,23 +113,29 @@ noLcaPair = do
 noLcaPairTest :: Test ()
 noLcaPairTest = replicateM_ 50 test >> ok
   where
-  test = runIdentity . uncurry Causal.lca <$> noLcaPair >>= \case
-    Nothing -> pure ()
-    Just _ -> crash "expected no lca"
+    test =
+      runIdentity . uncurry Causal.lca <$> noLcaPair >>= \case
+        Nothing -> pure ()
+        Just _ -> crash "expected no lca"
 
 oneRemoved :: Causal Identity Hash (Set Int64)
-oneRemoved = foldr Causal.cons
-                   (one (Set.singleton 1))
-                   (Set.fromList <$> [[2, 3, 4], [1, 2, 3, 4], [1, 2]])
+oneRemoved =
+  foldr
+    Causal.cons
+    (one (Set.singleton 1))
+    (Set.fromList <$> [[2, 3, 4], [1, 2, 3, 4], [1, 2]])
 
 twoRemoved :: Causal Identity Hash (Set Int64)
-twoRemoved = foldr Causal.cons
-                   (one (Set.singleton 1))
-                   (Set.fromList <$> [[1, 3, 4], [1, 2, 3], [1, 2]])
+twoRemoved =
+  foldr
+    Causal.cons
+    (one (Set.singleton 1))
+    (Set.fromList <$> [[1, 3, 4], [1, 2, 3], [1, 2]])
 
 testThreeWay :: Causal Identity Hash (Set Int64)
-testThreeWay = runIdentity
-  $ threeWayMerge' oneRemoved twoRemoved
+testThreeWay =
+  runIdentity $
+    threeWayMerge' oneRemoved twoRemoved
 
 setCombine :: Applicative m => Ord a => Set a -> Set a -> m (Set a)
 setCombine a b = pure $ a <> b
@@ -214,8 +149,8 @@ setPatch s (added, removed) = pure (added <> Set.difference s removed)
 -- merge x x == x, should not add a new head, and also the value at the head should be the same of course
 testIdempotent :: Causal Identity Hash (Set Int64) -> Bool -- Causal Identity Hash (Set Int64)
 testIdempotent causal =
-     runIdentity (threeWayMerge' causal causal)
-  == causal
+  runIdentity (threeWayMerge' causal causal)
+    == causal
 
 -- prop_mergeIdempotent :: Bool
 -- prop_mergeIdempotent = and (map testIdempotent (take 1000 generateRandomCausals))
@@ -226,94 +161,35 @@ oneCausal = Causal.one (Set.fromList [1])
 -- generateRandomCausals :: Causal Identity Hash (Set Int64)
 -- generateRandomCausals = undefined
 
-easyCombine
-  :: (Monad m, Semigroup d)
-  => (e -> e -> m e)
-  -> (e -> e -> m d)
-  -> (e -> d -> m e)
-  -> (Maybe e -> e -> e -> m e)
-easyCombine comb _    _    Nothing l r = comb l r
-easyCombine _    diff appl (Just ca) l r = do
+easyCombine ::
+  (Monad m, Semigroup d) =>
+  (e -> e -> m e) ->
+  (e -> e -> m d) ->
+  (e -> d -> m e) ->
+  (Maybe e -> e -> e -> m e)
+easyCombine comb _ _ Nothing l r = comb l r
+easyCombine _ diff appl (Just ca) l r = do
   dl <- diff ca l
   dr <- diff ca r
   appl ca (dl <> dr)
 
-threeWayMerge'
-  :: Causal Identity Hash (Set Int64)
-  -> Causal Identity Hash (Set Int64)
-  -> Identity (Causal Identity Hash (Set Int64))
+threeWayMerge' ::
+  Causal Identity Hash (Set Int64) ->
+  Causal Identity Hash (Set Int64) ->
+  Identity (Causal Identity Hash (Set Int64))
 threeWayMerge' = Causal.threeWayMerge (easyCombine setCombine setDiff setPatch)
 
 -- merge x mempty == x, merge mempty x == x
 testIdentity :: Causal Identity Hash (Set Int64) -> Causal Identity Hash (Set Int64) -> Bool
 testIdentity causal mempty =
-     (threeWayMerge' causal mempty)
-  == (threeWayMerge' mempty causal)
+  (threeWayMerge' causal mempty)
+    == (threeWayMerge' mempty causal)
 
 emptyCausal :: Causal Identity Hash (Set Int64)
 emptyCausal = one (Set.empty)
 
 -- merge (cons hd tl) tl == cons hd tl, merge tl (cons hd tl) == cons hd tl
 testCommutative :: Set Int64 -> Causal Identity Hash (Set Int64) -> Bool
-testCommutative hd tl = (threeWayMerge' (Causal.cons hd tl) tl)
-  == (threeWayMerge' tl (Causal.cons hd tl))
-
-
-{-
-testCommonAncestor ::
-testCommonAncestor =
--}
-
-
-
---  [ scope "foldHistoryUntil" . expect $ execState c mempty == Set.fromList [3,2,1]]
-
---result :: M (Causal.FoldHistoryResult (Set Int64))
---result = Causal.foldHistoryUntil f (Set.fromList [10, 1]) =<< c2 where
---  f s e = let s' = Set.difference s (Set.fromList e) in (s', Set.null s')
-
-result, result2 :: M (Causal.FoldHistoryResult (Set Int64))
-(result, result2) =
-  (Causal.foldHistoryUntil f (Set.fromList [10, 1]) =<< (do c' <- c; put mempty ; pure c')
-  ,Causal.foldHistoryUntil f (Set.fromList [10, 1]) =<< (do c' <- c2; put mempty ; pure c'))
-  where f s e = let s' = Set.difference s (Set.fromList e) in (s', Set.null s')
-
----- special cons and merge that mess with state monad for logging
-type M = State [[Int64]]
-cons :: [Int64]
-     -> Causal M h [Int64]
-     -> Causal M h [Int64]
-
-merge :: Causal M h [Int64]
-      -> Causal M h [Int64]
-      -> M (Causal M h [Int64])
-
-(cons, merge) = (cons'' pure, merge'' pure)
-  where
-  pure :: Causal m h [Int64] -> M (Causal m h [Int64])
-  pure c = state (\s -> (c, Causal.head c : s))
-
-cons'' :: Hashable e1
-       => (Causal m1 h e2 -> m2 (Causal m2 h e1))
-       -> e1 -> Causal m1 h e2 -> Causal m2 h e1
-cons'' pure e tl =
-  Cons (RawHash $ Causal.hash [Causal.hash e, unRawHash . currentHash $ tl]) e (currentHash tl, pure tl)
-
-merge'' :: (Monad m, Semigroup e)
-        => (Causal m h e -> m (Causal m h e))
-        -> Causal m h e -> Causal m h e -> m (Causal m h e)
-merge'' pure a b =
-  ifM (before a b) (pure b) . ifM (before b a) (pure a) $ case (a, b) of
-    (Merge _ _ tls, Merge _ _ tls2) -> merge0 $ Map.union tls tls2
-    (Merge _ _ tls, b) -> merge0 $ Map.insert (currentHash b) (pure b) tls
-    (b, Merge _ _ tls) -> merge0 $ Map.insert (currentHash b) (pure b) tls
-    (a, b) ->
-      merge0 $ Map.fromList [(currentHash a, pure a), (currentHash b, pure b)]
-  where
-  merge0 m =
-    let e = if Map.null m
-          then error "Causal.merge0 empty map"
-          else foldl1' (liftA2 (<>)) (fmap Causal.head <$> Map.elems m)
-        h = Causal.hash (Map.keys m) -- sorted order
-    in  e <&> \e -> Merge (RawHash h) e m
-
+testCommutative hd tl =
+  (threeWayMerge' (Causal.cons hd tl) tl)
+    == (threeWayMerge' tl (Causal.cons hd tl))

parser-typechecker/tests/Unison/Test/CodebaseInit.hs

@@ -26,51 +26,62 @@ test = scope "Codebase.Init" $ tests
     [ scope "a v2 codebase should be opened" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp))
-        case res of 
-          CI.OpenedCodebase _ _ -> expect True
-          _ -> expect False
+        r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) \case
+          (CI.OpenedCodebase, _, _) -> pure True
+          _ -> pure False
+        case r of
+          Left _ -> expect False
+          Right b -> expect b
     , scope "a v2 codebase should be created when one does not exist" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithoutCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Home tmp))
-        case res of 
-          CI.CreatedCodebase _ _ -> expect True
-          _ -> expect False
-    ] 
+        r <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Home tmp) \case
+          (CI.CreatedCodebase, _, _) -> pure True
+          _ -> pure False
+        case r of
+          Left _ -> expect False
+          Right b -> expect b
+    ]
   , scope "*with* a --codebase flag" $ tests
     [ scope "a v2 codebase should be opened" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)))
-        case res of 
-          CI.OpenedCodebase _ _ -> expect True
-          _ -> expect False
+        res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) $ \case
+          (CI.OpenedCodebase, _, _) -> pure True
+          _ -> pure False
+        case res of
+          Left _ -> expect False
+          Right b -> expect b
     , scope "a v2 codebase should be *not* created when one does not exist at the Specified dir" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithoutCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)))
-        case res of 
-          CI.Error _ CI.NoCodebaseFoundAtSpecifiedDir -> expect True
+        res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) $ \case
+          _ -> pure False
+        case res of
+          Left (_, CI.NoCodebaseFoundAtSpecifiedDir) -> expect True
           _ -> expect False
-    ] 
+    ]
   , scope "*with* a --codebase-create flag" $ tests
     [  scope "a v2 codebase should be created when one does not exist at the Specified dir" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithoutCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp))) 
-        case res of 
-          CI.CreatedCodebase _ _ -> expect True
-          _ -> expect False
-      , 
+        res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) \case
+          (CI.CreatedCodebase, _, _) -> pure True
+          _ -> pure False
+        case res of
+          Left _ -> expect False
+          Right b -> expect b
+      ,
       scope "a v2 codebase should be opened when one exists" do
         tmp <- io (Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory "ucm-test")
         cbInit <- io initMockWithCodebase
-        res <- io (CI.openOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)))
-        case res of 
-          CI.OpenedCodebase _ _ -> expect True
-          _ -> expect False
-    ] 
+        res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (CreateWhenMissing tmp)) \case
+          (CI.OpenedCodebase, _, _) -> pure True
+          _ -> pure False
+        case res of
+          Left _ -> expect False
+          Right b -> expect b
+    ]
   ]
 
 -- Test helpers
@@ -79,10 +90,10 @@ initMockWithCodebase ::  IO (Init IO v a)
 initMockWithCodebase = do
   let codebase = error "did we /actually/ need a Codebase?"
   pure $ Init {
-    -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)),
-    openCodebase = \_ _ -> pure ( Right (pure (), codebase)),
-    -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)),
-    createCodebase' = \_ _ -> pure (Right (pure (), codebase)),
+    -- withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
+    withOpenCodebase = \_ _ action -> Right <$> action codebase,
+    -- withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
+    withCreatedCodebase = \_ _ action -> Right <$> action codebase,
     -- CodebasePath -> CodebasePath
     codebasePath = id
   }
@@ -91,10 +102,10 @@ initMockWithoutCodebase ::  IO (Init IO v a)
 initMockWithoutCodebase = do
   let codebase = error "did we /actually/ need a Codebase?"
   pure $ Init {
-    -- DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)),
-    openCodebase = \_ _ -> pure (Left "no codebase found"),
-    -- DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)),
-    createCodebase' = \_ _ -> pure (Right (pure (), codebase)),
+    -- withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
+    withOpenCodebase = \_ _ _ -> pure (Left "no codebase found"),
+    -- withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
+    withCreatedCodebase = \_ _ action -> Right <$> action codebase,
     -- CodebasePath -> CodebasePath
     codebasePath = id
-  }
+  }

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

@@ -67,6 +67,10 @@ import qualified Unison.Server.SearchResult' as SR'
 import qualified Unison.WatchKind as WK
 import Unison.Codebase.Type (GitError)
 import qualified Unison.CommandLine.FuzzySelect as Fuzzy
+import UnliftIO (MonadUnliftIO(..), UnliftIO)
+import qualified UnliftIO
+import Unison.Util.Free (Free)
+import qualified Unison.Util.Free as Free
 
 type AmbientAbilities v = [Type v Ann]
 type SourceName = Text
@@ -198,7 +202,7 @@ data Command
   Merge :: Branch.MergeMode -> Branch m -> Branch m -> Command m i v (Branch m)
 
   ViewRemoteBranch ::
-    ReadRemoteNamespace -> Command m i v (Either GitError (m (), Branch m))
+    ReadRemoteNamespace -> (Branch m -> (Free (Command m i v) r)) -> Command m i v (Either GitError r)
 
   -- we want to import as little as possible, so we pass the SBH/path as part
   -- of the `RemoteNamespace`.  The Branch that's returned should be fully
@@ -262,6 +266,19 @@ data Command
               -> [a] -- ^ The elements to select from
               -> Command m i v (Maybe [a]) -- ^ The selected results, or Nothing if a failure occurred.
 
+  -- | This allows us to implement MonadUnliftIO for (Free (Command m i v)).
+  -- Ideally we will eventually remove the Command type entirely and won't need
+  -- this anymore.
+  CmdUnliftIO :: Command m i v (UnliftIO (Free (Command m i v)))
+
+instance MonadIO m => MonadIO (Free (Command m i v)) where
+  liftIO io = Free.eval $ Eval (liftIO io)
+
+instance MonadIO m => MonadUnliftIO (Free (Command m i v)) where
+  withRunInIO f = do
+    UnliftIO.UnliftIO toIO <- Free.eval CmdUnliftIO
+    liftIO $ f toIO
+
 type UseCache = Bool
 
 type EvalResult v =
@@ -326,3 +343,4 @@ commandName = \case
   ClearWatchCache {} -> "ClearWatchCache"
   MakeStandalone {} -> "MakeStandalone"
   FuzzySelect {} -> "FuzzySelect"
+  CmdUnliftIO {} -> "UnliftIO"

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

@@ -5,13 +5,13 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FunctionalDependencies #-}
 
 module Unison.Codebase.Editor.HandleCommand where
 
 import Unison.Prelude
 
 import Control.Monad.Except (runExceptT)
-import qualified Control.Monad.State as State
 import qualified Crypto.Random as Random
 import qualified Data.Configurator as Config
 import Data.Configurator.Types (Config)
@@ -51,6 +51,9 @@ import Web.Browser (openBrowser)
 import System.Environment (withArgs)
 import qualified Unison.CommandLine.FuzzySelect as Fuzzy
 import qualified Unison.Codebase.Path as Path
+import Control.Monad.Reader (ReaderT (runReaderT), ask)
+import qualified Control.Concurrent.STM as STM
+import qualified UnliftIO
 
 typecheck
   :: (Monad m, Var v)
@@ -94,10 +97,11 @@ commandLine
   -> (Int -> IO gen)
   -> Free (Command IO i v) a
   -> IO a
-commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen =
- flip State.evalStateT 0 . Free.fold go
+commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen free = do
+ rndSeed <- STM.newTVarIO 0
+ flip runReaderT rndSeed . Free.fold go $ free
  where
-  go :: forall x . Command IO i v x -> State.StateT Int IO x
+  go :: forall x . Command IO i v x -> ReaderT (STM.TVar Int) IO x
   go x = case x of
     -- Wait until we get either user input or a unison file update
     Eval m        -> lift m
@@ -119,8 +123,11 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
     Typecheck ambient names sourceName source -> do
       -- todo: if guids are being shown to users,
       -- not ideal to generate new guid every time
-      i <- State.get
-      State.modify' (+1)
+      iVar <- ask
+      i <- UnliftIO.atomically $ do
+             i <- STM.readTVar iVar
+             STM.writeTVar iVar (i + 1)
+             pure i
       rng <- lift $ rngGen i
       let namegen = Parser.uniqueBase32Namegen rng
           env = Parser.ParsingEnv namegen names
@@ -135,8 +142,11 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
     SyncLocalRootBranch branch -> lift $ do
       setBranchRef branch
       Codebase.putRootBranch codebase branch
-    ViewRemoteBranch ns ->
-      lift $ Codebase.viewRemoteBranch codebase ns
+    ViewRemoteBranch ns action -> do
+      -- TODO: We probably won'd need to unlift anything once we remove the Command
+      -- abstraction.
+      toIO <- UnliftIO.askRunInIO
+      lift $ Codebase.viewRemoteBranch codebase ns (toIO . Free.fold go . action)
     ImportRemoteBranch ns syncMode ->
       lift $ Codebase.importRemoteBranch codebase ns syncMode
     SyncRemoteBranch branch repo opts ->
@@ -199,6 +209,17 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
       Runtime.compileTo rt (() <$ cl) ppe ref (out <> ".uc")
     ClearWatchCache -> lift $ Codebase.clearWatches codebase
     FuzzySelect opts display choices -> liftIO $ Fuzzy.fuzzySelect opts display choices
+    CmdUnliftIO -> do
+      -- Get the unlifter for the ReaderT we're currently working in.
+      unlifted <- UnliftIO.askUnliftIO
+      -- Built an unliftIO for the Free monad
+      let runF :: UnliftIO.UnliftIO (Free (Command IO i v))
+          runF = UnliftIO.UnliftIO $ case unlifted of
+                   -- We need to case-match on the UnliftIO within this function
+                   -- because `toIO` is existential and we need the right types
+                   -- in-scope.
+                   UnliftIO.UnliftIO toIO -> toIO . Free.fold go
+      pure runF
 
   watchCache :: Reference.Id -> IO (Maybe (Term v ()))
   watchCache h = do
@@ -295,3 +316,4 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
 --   else if q `isSuffixOf` n               then Just 2-- matching suffix is p.good
 --   else if q `isPrefixOf` n               then Just 3-- matching prefix
 --   else Nothing
+

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

@@ -11,7 +11,7 @@ where
 
 import qualified Control.Error.Util as ErrorUtil
 import Control.Lens
-import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT)
+import Control.Monad.Except (ExceptT (..), runExceptT, withExceptT)
 import Control.Monad.State (StateT)
 import qualified Control.Monad.State as State
 import Data.Bifunctor (first, second)
@@ -43,7 +43,7 @@ import qualified Unison.Codebase.Causal as Causal
 import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
 import Unison.Codebase.Editor.Command as Command
 import Unison.Codebase.Editor.DisplayObject
-import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', eval)
+import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action')
 import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
 import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
 import Unison.Codebase.Editor.Input
@@ -143,13 +143,16 @@ import Unison.Util.TransitiveClosure (transitiveClosure)
 import Unison.Var (Var)
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as WK
+import Unison.Codebase.Editor.HandleInput.LoopState (eval, MonadCommand(..))
+import Unison.Util.Free (Free)
+import UnliftIO (MonadUnliftIO)
 import qualified Data.Set.NonEmpty as NESet
 import Data.Set.NonEmpty (NESet)
 
 defaultPatchNameSegment :: NameSegment
 defaultPatchNameSegment = "patch"
 
-prettyPrintEnvDecl :: NamesWithHistory -> Action' m v PPE.PrettyPrintEnvDecl
+prettyPrintEnvDecl :: MonadCommand n m i v => NamesWithHistory -> n PPE.PrettyPrintEnvDecl
 prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns)
 
 -- | Get a pretty print env decl for the current names at the current path.
@@ -159,7 +162,7 @@ currentPrettyPrintEnvDecl = do
   currentPath' <- Path.unabsolute <$> use LoopState.currentPath
   prettyPrintEnvDecl (Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root')
 
-loop :: forall m v. (Monad m, Var v) => Action m (Either Event Input) v ()
+loop :: forall m v. (MonadUnliftIO m, Var v) => Action m (Either Event Input) v ()
 loop = do
   uf <- use LoopState.latestTypecheckedFile
   root' <- use LoopState.root
@@ -547,8 +550,8 @@ loop = do
                       else
                         respondNumbered $
                           ShowDiffNamespace
-                            Path.absoluteEmpty
-                            Path.absoluteEmpty
+                            (Right Path.absoluteEmpty)
+                            (Right Path.absoluteEmpty)
                             ppe
                             outputDiff
             where
@@ -691,28 +694,31 @@ loop = do
                     else
                       diffHelper (Branch.head destb) (Branch.head merged)
                         >>= respondNumbered . uncurry (ShowDiffAfterMergePreview dest0 dest)
-            DiffNamespaceI before0 after0 -> do
-              let [beforep, afterp] =
-                    resolveToAbsolute <$> [before0, after0]
-              before <- Branch.head <$> getAt beforep
-              after <- Branch.head <$> getAt afterp
-              case (Branch.isEmpty0 before, Branch.isEmpty0 after) of
-                (True, True) -> respond . NamespaceEmpty $ Right (beforep, afterp)
-                (True, False) -> respond . NamespaceEmpty $ Left beforep
-                (False, True) -> respond . NamespaceEmpty $ Left afterp
+            DiffNamespaceI before after -> unlessError do
+              let (absBefore, absAfter) = (resolveToAbsolute <$> before, resolveToAbsolute <$> after)
+              beforeBranch0 <- Branch.head <$> branchForBranchId absBefore
+              afterBranch0 <- Branch.head <$> branchForBranchId absAfter
+              lift $ case (Branch.isEmpty0 beforeBranch0, Branch.isEmpty0 afterBranch0) of
+                (True, True) -> respond . NamespaceEmpty $ (absBefore Nel.:| [absAfter])
+                (True, False) -> respond . NamespaceEmpty $ (absBefore Nel.:| [])
+                (False, True) -> respond . NamespaceEmpty $ (absAfter Nel.:| [])
                 _ -> do
-                  (ppe, outputDiff) <- diffHelper before after
-                  respondNumbered $ ShowDiffNamespace beforep afterp ppe outputDiff
-            CreatePullRequestI baseRepo headRepo -> unlessGitError do
-              (cleanupBase, baseBranch) <- viewRemoteBranch baseRepo
-              (cleanupHead, headBranch) <- viewRemoteBranch headRepo
-              lift do
-                merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch
-                (ppe, diff) <- diffHelper (Branch.head baseBranch) (Branch.head merged)
-                respondNumbered $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff
-                eval . Eval $ do
-                  cleanupBase
-                  cleanupHead
+                  (ppe, outputDiff) <- diffHelper beforeBranch0 afterBranch0
+                  respondNumbered $
+                    ShowDiffNamespace
+                      (resolveToAbsolute <$> before)
+                      (resolveToAbsolute <$> after)
+                      ppe
+                      outputDiff
+            CreatePullRequestI baseRepo headRepo -> do
+              result <- join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do
+                 viewRemoteBranch headRepo \headBranch -> do
+                   merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch
+                   (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged)
+                   pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff
+              case result of
+                Left gitErr -> respond (Output.GitError gitErr)
+                Right diff -> respondNumbered diff
             LoadPullRequestI baseRepo headRepo dest0 -> do
               let desta = resolveToAbsolute dest0
               let dest = Path.unabsolute desta
@@ -1825,14 +1831,14 @@ handleDependents hq = do
         respond (ListDependents hqLength ld results)
 
 -- | Handle a @gist@ command.
-handleGist :: Applicative m => GistInput -> Action' m v ()
+handleGist :: MonadUnliftIO m => GistInput -> Action' m v ()
 handleGist (GistInput repo) =
   doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing
 
 -- | Handle a @push@ command.
 handlePushRemoteBranch ::
   forall m v.
-  Applicative m =>
+  MonadUnliftIO m =>
   -- | The repo to push to. If missing, it is looked up in `.unisonConfig`.
   Maybe WriteRemotePath ->
   -- | The local path to push. If relative, it's resolved relative to the current path (`cd`).
@@ -1849,7 +1855,7 @@ handlePushRemoteBranch mayRepo path pushBehavior syncMode = do
 -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@.
 doPushRemoteBranch ::
   forall m v.
-  Applicative m =>
+  MonadUnliftIO m =>
   -- | The repo to push to.
   WriteRepo ->
   -- | The local path to push. If relative, it's resolved relative to the current path (`cd`).
@@ -1865,23 +1871,25 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do
     getAt (Path.resolve currentPath' localPath)
 
   unlessError do
-    (cleanup, remoteRoot) <- viewRemoteBranch (writeToRead repo, Nothing, Path.empty) & withExceptT Output.GitError
-    (`finallyE` lift (eval (Eval cleanup))) do
+    withExceptT Output.GitError $ do
       case remoteTarget of
         Nothing -> do
           let opts = PushGitBranchOpts {setRoot = False, syncMode}
-          syncRemoteBranch sourceBranch repo opts & withExceptT Output.GitError
-          sbhLength <- lift (eval BranchHashLength)
-          lift (respond (GistCreated sbhLength repo (Branch.headHash sourceBranch)))
+          syncRemoteBranch sourceBranch repo opts
+          sbhLength <- (eval BranchHashLength)
+          respond (GistCreated sbhLength repo (Branch.headHash sourceBranch))
         Just (remotePath, pushBehavior) -> do
-          let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
-              -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
-              f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
-          newRemoteRoot <-
-            Branch.modifyAtM remotePath f remoteRoot & onNothing (throwError (RefusedToPush (pushBehavior)))
-          let opts = PushGitBranchOpts {setRoot = True, syncMode}
-          syncRemoteBranch newRemoteRoot repo opts & withExceptT Output.GitError
-          lift (respond Success)
+          ExceptT . viewRemoteBranch (writeToRead repo, Nothing, Path.empty) $ \remoteRoot -> do
+            let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
+                -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
+                f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
+            Branch.modifyAtM remotePath f remoteRoot & \case
+              Nothing -> respond (RefusedToPush pushBehavior)
+              Just newRemoteRoot -> do
+                let opts = PushGitBranchOpts {setRoot = True, syncMode}
+                runExceptT (syncRemoteBranch newRemoteRoot repo opts) >>= \case
+                  Left gitErr -> respond (Output.GitError gitErr)
+                  Right () -> respond Success
   where
     -- Per `pushBehavior`, we are either:
     --
@@ -1893,15 +1901,6 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do
         PushBehavior.RequireEmpty -> Branch.isEmpty remoteBranch
         PushBehavior.RequireNonEmpty -> not (Branch.isEmpty remoteBranch)
 
--- This is defined in transformers-0.6
-finallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a
-finallyE (ExceptT action) cleanup =
-  ExceptT do
-    result <- action
-    runExceptT cleanup <&> \case
-      Left err -> Left err
-      Right () -> result
-
 -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
 handleShowDefinition ::
   forall m v.
@@ -1974,7 +1973,7 @@ handleShowDefinition outputLoc inputQuery = do
 resolveConfiguredGitUrl ::
   PushPull ->
   Path' ->
-  ExceptT (Output v) (Action' m v) WriteRemotePath
+  ExceptT (Output v) (Action m i v) WriteRemotePath
 resolveConfiguredGitUrl pushPull destPath' = ExceptT do
   currentPath' <- use LoopState.currentPath
   let destPath = Path.resolve currentPath' destPath'
@@ -2001,10 +2000,11 @@ configKey k p =
         NameSegment.toText
         (Path.toSeq $ Path.unabsolute p)
 
-viewRemoteBranch :: ReadRemoteNamespace -> ExceptT GitError (Action' m v) (m (), Branch m)
-viewRemoteBranch ns = ExceptT . eval $ ViewRemoteBranch ns
+viewRemoteBranch :: (MonadCommand n m i v, MonadUnliftIO m) => ReadRemoteNamespace -> (Branch m -> Free (Command m i v) r) -> n (Either GitError r)
+viewRemoteBranch ns action = do
+  eval $ ViewRemoteBranch ns action
 
-syncRemoteBranch :: Branch m -> WriteRepo -> PushGitBranchOpts -> ExceptT GitError (Action' m v) ()
+syncRemoteBranch :: MonadCommand n m i v => Branch m -> WriteRepo -> PushGitBranchOpts -> ExceptT GitError n ()
 syncRemoteBranch b repo opts =
   ExceptT . eval $ SyncRemoteBranch b repo opts
 
@@ -2357,7 +2357,7 @@ handleBackendError = \case
   Backend.MissingSignatureForTerm r ->
     respond $ TermMissingType r
 
-respond :: Output v -> Action m i v ()
+respond :: MonadCommand n m i v => Output v -> n ()
 respond output = eval $ Notify output
 
 respondNumbered :: NumberedOutput v -> Action m i v ()
@@ -3231,7 +3231,7 @@ currentPathNames = do
   pure $ Branch.toNames (Branch.head currentBranch')
 
 -- implementation detail of basicParseNames and basicPrettyPrintNames
-basicNames' :: Functor m => Action' m v (Names, Names)
+basicNames' :: (Functor m) => Action m i v (Names, Names)
 basicNames' = do
   root' <- use LoopState.root
   currentPath' <- use LoopState.currentPath
@@ -3335,15 +3335,28 @@ displayNames unisonFile =
     (UF.typecheckedToNames unisonFile)
 
 diffHelper ::
-  Monad m =>
+  (Monad m) =>
   Branch0 m ->
   Branch0 m ->
   Action' m v (PPE.PrettyPrintEnv, OBranchDiff.BranchDiffOutput v Ann)
 diffHelper before after = do
+  currentRoot <- use LoopState.root
+  currentPath <- use LoopState.currentPath
+  diffHelperCmd currentRoot currentPath before after
+
+-- | A version of diffHelper that only requires a MonadCommand constraint
+diffHelperCmd ::
+  (Monad m, MonadCommand n m i v) =>
+  Branch m ->
+  Path.Absolute ->
+  Branch0 m ->
+  Branch0 m ->
+  n (PPE.PrettyPrintEnv, OBranchDiff.BranchDiffOutput v Ann)
+diffHelperCmd currentRoot currentPath before after = do
   hqLength <- eval CodebaseHashLength
   diff <- eval . Eval $ BranchDiff.diff0 before after
-  names0 <- basicPrettyPrintNamesA
-  ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory names0 mempty)
+  let (_parseNames, prettyNames0) = Backend.basicNames' currentRoot (Backend.AllNames $ Path.unabsolute currentPath)
+  ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty)
   (ppe,)
     <$> OBranchDiff.toOutput
       loadTypeOfTerm
@@ -3354,7 +3367,8 @@ diffHelper before after = do
       ppe
       diff
 
-loadTypeOfTerm :: Referent -> Action m i v (Maybe (Type v Ann))
+
+loadTypeOfTerm :: MonadCommand n m i v => Referent -> n (Maybe (Type v Ann))
 loadTypeOfTerm (Referent.Ref r) = eval $ LoadTypeOfTerm r
 loadTypeOfTerm (Referent.Con (ConstructorReference (Reference.DerivedId r) cid) _) = do
   decl <- eval $ LoadType r
@@ -3365,7 +3379,7 @@ loadTypeOfTerm Referent.Con {} =
   error $
     reportBug "924628772" "Attempt to load a type declaration which is a builtin!"
 
-declOrBuiltin :: Reference -> Action m i v (Maybe (DD.DeclOrBuiltin v Ann))
+declOrBuiltin :: MonadCommand n m i v => Reference -> n (Maybe (DD.DeclOrBuiltin v Ann))
 declOrBuiltin r = case r of
   Reference.Builtin {} ->
     pure . fmap DD.Builtin $ Map.lookup r Builtin.builtinConstructorType
@@ -3406,3 +3420,12 @@ fuzzySelectNamespace pos searchBranch0 = do
         tShow
         inputs
     )
+
+-- | Get a branch from a BranchId, returning an empty one if missing, or failing with an
+-- appropriate error message if a hash cannot be found.
+branchForBranchId :: Functor m => AbsBranchId -> ExceptT (Output v) (Action' m v) (Branch m)
+branchForBranchId = \case
+  Left hash -> do
+    resolveShortBranchHash hash
+  Right path -> do
+    lift $ getAt path

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

@@ -1,5 +1,7 @@
 {- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Unison.Codebase.Editor.HandleInput.LoopState where
 
 import Control.Lens
@@ -18,12 +20,28 @@ import Unison.Util.Free (Free)
 import Unison.Codebase.Editor.Command
 import qualified Data.List.NonEmpty as Nel
 import qualified Unison.Util.Free as Free
+import Control.Monad.Except (ExceptT)
 
 type F m i v = Free (Command m i v)
 
--- type (Action m i v) a
 type Action m i v = MaybeT (StateT (LoopState m v) (F m i v))
 
+-- | A typeclass representing monads which can evaluate 'Command's.
+class Monad n => MonadCommand n m v i | n -> m v i where
+  eval :: Command m v i a -> n a
+
+instance MonadCommand (Free (Command m i v)) m i v where
+  eval = Free.eval
+
+instance MonadCommand n m i v => MonadCommand (StateT s n) m i v where
+  eval = lift . eval
+
+instance MonadCommand n m i v => MonadCommand (MaybeT n) m i v where
+  eval = lift . eval
+
+instance MonadCommand n m i v => MonadCommand (ExceptT e n) m i v where
+  eval = lift . eval
+
 type NumberedArgs = [String]
 
 data LoopState m v = LoopState
@@ -62,6 +80,3 @@ currentPath = currentPathStack . to Nel.head
 
 loopState0 :: Branch m -> Path.Absolute -> LoopState m v
 loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing []
-
-eval :: Command m i v a -> Action m i v a
-eval = lift . lift . Free.eval

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

@@ -5,7 +5,7 @@ module Unison.Codebase.Editor.Input
   , Event(..)
   , OutputLocation(..)
   , PatchPath
-  , BranchId, parseBranchId
+  , BranchId, AbsBranchId, parseBranchId
   , HashOrHQSplit'
   , Insistence(..)
   ) where
@@ -40,6 +40,7 @@ type Source = Text -- "id x = x\nconst a b = a"
 type SourceName = Text -- "foo.u" or "buffer 7"
 type PatchPath = Path.Split'
 type BranchId = Either ShortBranchHash Path'
+type AbsBranchId = Either ShortBranchHash Path.Absolute
 type HashOrHQSplit' = Either ShortHash Path.HQSplit'
 
 -- | Should we force the operation or not?
@@ -61,7 +62,7 @@ data Input
     -- merge first causal into destination
     | MergeLocalBranchI Path' Path' Branch.MergeMode
     | PreviewMergeLocalBranchI Path' Path'
-    | DiffNamespaceI Path' Path' -- old new
+    | DiffNamespaceI BranchId BranchId -- old new
     | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode Verbosity
     | PushRemoteBranchI (Maybe WriteRemotePath) Path' PushBehavior SyncMode
     | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace

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

@@ -63,6 +63,7 @@ import Unison.Util.Relation (Relation)
 import qualified Unison.WatchKind as WK
 import Data.Set.NonEmpty (NESet)
 import qualified Unison.CommandLine.InputPattern as Input
+import Data.List.NonEmpty (NonEmpty)
 
 type ListDetailed = Bool
 
@@ -78,7 +79,7 @@ pushPull push pull p = case p of
   Pull -> pull
 
 data NumberedOutput v
-  = ShowDiffNamespace Path.Absolute Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
+  = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
   | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
   | ShowDiffAfterDeleteDefinitions PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
   | ShowDiffAfterDeleteBranch Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput v Ann)
@@ -231,8 +232,8 @@ data Output v
   | DefaultMetadataNotification
   | BadRootBranch GetRootBranchError
   | CouldntLoadBranch Branch.Hash
-  | NamespaceEmpty (Either Path.Absolute (Path.Absolute, Path.Absolute))
   | HelpMessage Input.InputPattern
+  | NamespaceEmpty (NonEmpty AbsBranchId)
   | NoOp
   | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
     RefusedToPush PushBehavior

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

@@ -1237,12 +1237,12 @@ diffNamespace =
     )
     ( \case
         [before, after] -> first fromString $ do
-          before <- Path.parsePath' before
-          after <- Path.parsePath' after
+          before <- Input.parseBranchId before
+          after <- Input.parseBranchId after
           pure $ Input.DiffNamespaceI before after
         [before] -> first fromString $ do
-          before <- Path.parsePath' before
-          pure $ Input.DiffNamespaceI before Path.currentPath
+          before <- Input.parseBranchId before
+          pure $ Input.DiffNamespaceI before (Right Path.currentPath)
         _ -> Left $ I.help diffNamespace
     )
 

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

@@ -124,6 +124,7 @@ import Unison.Var (Var)
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as WK
 import Prelude hiding (readFile, writeFile)
+import qualified Data.List.NonEmpty as NEList
 
 type Pretty = P.Pretty P.ColorText
 
@@ -150,7 +151,7 @@ notifyNumbered o = case o of
               undoTip
             ]
       )
-      (showDiffNamespace ShowNumbers ppe e e diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
   ShowDiffAfterDeleteBranch bAbs ppe diff ->
     first
       ( \p ->
@@ -160,7 +161,7 @@ notifyNumbered o = case o of
               undoTip
             ]
       )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
   ShowDiffAfterModifyBranch b' _ _ (OBD.isEmpty -> True) ->
     (P.wrap $ "Nothing changed in" <> prettyPath' b' <> ".", mempty)
   ShowDiffAfterModifyBranch b' bAbs ppe diff ->
@@ -174,7 +175,7 @@ notifyNumbered o = case o of
               undoTip
             ]
       )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
   ShowDiffAfterMerge _ _ _ (OBD.isEmpty -> True) ->
     (P.wrap $ "Nothing changed as a result of the merge.", mempty)
   ShowDiffAfterMerge dest' destAbs ppe diffOutput ->
@@ -198,7 +199,7 @@ notifyNumbered o = case o of
                   <> " to undo the results of this merge."
             ]
       )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
   ShowDiffAfterMergePropagate dest' destAbs patchPath' ppe diffOutput ->
     first
       ( \p ->
@@ -224,7 +225,7 @@ notifyNumbered o = case o of
                   <> " to undo the results of this merge."
             ]
       )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
   ShowDiffAfterMergePreview dest' destAbs ppe diffOutput ->
     first
       ( \p ->
@@ -234,11 +235,11 @@ notifyNumbered o = case o of
               p
             ]
       )
-      (showDiffNamespace ShowNumbers ppe destAbs destAbs diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diffOutput)
   ShowDiffAfterUndo ppe diffOutput ->
     first
       (\p -> P.lines ["Here are the changes I undid", "", p])
-      (showDiffNamespace ShowNumbers ppe e e diffOutput)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diffOutput)
   ShowDiffAfterPull dest' destAbs ppe diff ->
     if OBD.isEmpty diff
       then ("✅  Looks like " <> prettyPath' dest' <> " is up to date.", mempty)
@@ -253,7 +254,7 @@ notifyNumbered o = case o of
                   undoTip
                 ]
           )
-          (showDiffNamespace ShowNumbers ppe destAbs destAbs diff)
+          (showDiffNamespace ShowNumbers ppe (absPathToBranchId destAbs) (absPathToBranchId destAbs) diff)
   ShowDiffAfterCreatePR baseRepo headRepo ppe diff ->
     if OBD.isEmpty diff
       then
@@ -284,7 +285,7 @@ notifyNumbered o = case o of
                   ]
               )
           )
-          (showDiffNamespace HideNumbers ppe e e diff)
+          (showDiffNamespace HideNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
   -- todo: these numbers aren't going to work,
   --  since the content isn't necessarily here.
   -- Should we have a mode with no numbers? :P
@@ -302,7 +303,7 @@ notifyNumbered o = case o of
                   <> P.group (prettyPath' authorPath' <> ".")
             ]
       )
-      (showDiffNamespace ShowNumbers ppe bAbs bAbs diff)
+      (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
   CantDeleteDefinitions ppeDecl endangerments ->
     (P.warnCallout $
       P.lines
@@ -331,7 +332,7 @@ notifyNumbered o = case o of
         ]
     , numberedArgsForEndangerments ppeDecl endangerments)
   where
-    e = Path.absoluteEmpty
+    absPathToBranchId = Right
     undoTip =
       tip $
         "You can use" <> IP.makeExample' IP.undo
@@ -371,20 +372,18 @@ notifyUser dir o = case o of
         <> "when I tried to load it."
   NamespaceEmpty p ->
     case p of
-      Right (p0, p1) ->
-        pure
-          . P.warnCallout
-          $ "The namespaces "
-            <> P.string (show p0)
-            <> " and "
-            <> P.string (show p1)
-            <> " are empty. Was there a typo?"
-      Left p0 ->
+      (p0 NEList.:| []) ->
         pure
           . P.warnCallout
           $ "The namespace "
-            <> P.string (show p0)
+            <> prettyBranchId p0
             <> " is empty. Was there a typo?"
+      ps ->
+        pure
+          . P.warnCallout
+          $ "The namespaces "
+            <> P.commas (prettyBranchId <$> ps)
+            <> " are empty. Was there a typo?"
   WarnIncomingRootBranch current hashes ->
     pure $
       if null hashes
@@ -1458,6 +1457,11 @@ prettyPath' p' =
     then "the current namespace"
     else P.blue (P.shown p')
 
+prettyBranchId :: Input.AbsBranchId -> Pretty
+prettyBranchId = \case
+  Left sbh -> prettySBH sbh
+  Right absPath -> prettyAbsolute $ absPath
+
 prettyRelative :: Path.Relative -> Pretty
 prettyRelative = P.blue . P.shown
 
@@ -1923,8 +1927,8 @@ showDiffNamespace ::
   Var v =>
   ShowNumbers ->
   PPE.PrettyPrintEnv ->
-  Path.Absolute ->
-  Path.Absolute ->
+  Input.AbsBranchId ->
+  Input.AbsBranchId ->
   OBD.BranchDiffOutput v Ann ->
   (Pretty, NumberedArgs)
 showDiffNamespace _ _ _ _ diffOutput
@@ -2174,7 +2178,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
               0 -> mempty
               c -> " (+" <> P.shown c <> " metadata)"
 
-    prettySummarizePatch, prettyNamePatch :: Path.Absolute -> OBD.PatchDisplay -> Numbered Pretty
+    prettySummarizePatch, prettyNamePatch :: Input.AbsBranchId -> OBD.PatchDisplay -> Numbered Pretty
     --  12. patch p (added 3 updates, deleted 1)
     prettySummarizePatch prefix (name, patchDiff) = do
       n <- numPatch prefix name
@@ -2238,7 +2242,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
           pure (n, phq' hq, mempty)
 
     downArrow = P.bold "↓"
-    mdTypeLine :: Path.Absolute -> OBD.TypeDisplay v a -> Numbered (Pretty, Pretty)
+    mdTypeLine :: Input.AbsBranchId -> OBD.TypeDisplay v a -> Numbered (Pretty, Pretty)
     mdTypeLine p (hq, r, odecl, mddiff) = do
       n <- numHQ' p hq (Referent.Ref r)
       fmap ((n,) . P.linesNonEmpty) . sequence $
@@ -2249,7 +2253,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
     -- + 2. MIT               : License
     -- - 3. AllRightsReserved : License
     mdTermLine ::
-      Path.Absolute ->
+      Input.AbsBranchId ->
       P.Width ->
       OBD.TermDisplay v a ->
       Numbered (Pretty, Pretty)
@@ -2303,21 +2307,27 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
         (P.syntaxToColor . DeclPrinter.prettyDeclOrBuiltinHeader (HQ'.toHQ hq))
     phq' :: _ -> Pretty = P.syntaxToColor . prettyHashQualified'
     phq :: _ -> Pretty = P.syntaxToColor . prettyHashQualified
-    --
+
     -- DeclPrinter.prettyDeclHeader : HQ -> Either
-    numPatch :: Path.Absolute -> Name -> Numbered Pretty
+    numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty
     numPatch prefix name =
-      addNumberedArg . Name.toString . Name.makeAbsolute $ Path.prefixName prefix name
+      addNumberedArg $ prefixBranchId prefix name
 
-    numHQ :: Path.Absolute -> HQ.HashQualified Name -> Referent -> Numbered Pretty
-    numHQ prefix hq r = addNumberedArg (HQ.toString hq')
-      where
-        hq' = HQ.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
+    numHQ :: Input.AbsBranchId -> HQ.HashQualified Name -> Referent -> Numbered Pretty
+    numHQ prefix hq r =
+      addNumberedArg . HQ.toStringWith (prefixBranchId prefix) . HQ.requalify hq $ r
 
-    numHQ' :: Path.Absolute -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
-    numHQ' prefix hq r = addNumberedArg (HQ'.toString hq')
-      where
-        hq' = HQ'.requalify (fmap (Name.makeAbsolute . Path.prefixName prefix) hq) r
+    numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty
+    numHQ' prefix hq r =
+      addNumberedArg . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r
+
+    -- E.g.
+    -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map"
+    -- prefixBranchId ".base" "List.map" -> ".base.List.map"
+    prefixBranchId :: Input.AbsBranchId -> Name -> String
+    prefixBranchId branchId name = case branchId of
+      Left sbh -> "#" <> SBH.toString sbh <> ":" <> Name.toString (Name.makeAbsolute  name)
+      Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name)
 
     addNumberedArg :: String -> Numbered Pretty
     addNumberedArg s = case sn of

unison-cli/tests/Unison/Test/Ucm.hs

@@ -31,6 +31,7 @@ import qualified Unison.PrettyTerminal as PT
 import qualified Unison.Util.Pretty as P
 import Unison.Parser.Ann (Ann)
 import Unison.Symbol (Symbol)
+import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError(..))
 
 data CodebaseFormat = CodebaseFormat2 deriving (Show, Enum, Bounded)
 
@@ -53,10 +54,11 @@ initCodebase fmt = do
   tmp <-
     Temp.getCanonicalTemporaryDirectory
       >>= flip Temp.createTempDirectory "ucm-test"
-  Codebase.Init.createCodebase cbInit "ucm-test" tmp >>= \case
-    Left e -> fail $ P.toANSI 80 e
-    Right (close, _cb) -> close
-  pure $ Codebase tmp fmt
+  result <- Codebase.Init.withCreatedCodebase cbInit "ucm-test" tmp (const $ pure ())
+  case result of
+    Left CreateCodebaseAlreadyExists -> fail $ P.toANSI 80 "Codebase already exists"
+    Left (CreateCodebaseOther p) -> fail $ P.toANSI 80 p
+    Right _ -> pure $ Codebase tmp fmt
 
 deleteCodebase :: Codebase -> IO ()
 deleteCodebase (Codebase path _) = removeDirectoryRecursive path
@@ -71,27 +73,27 @@ runTranscript (Codebase codebasePath fmt) transcript = do
     pure $ tmpDir </> ".unisonConfig"
   let err err = fail $ "Parse error: \n" <> show err
       cbInit = case fmt of CodebaseFormat2 -> SC.init
-  (closeCodebase, codebase) <-
-    Codebase.Init.openCodebase cbInit "transcript" codebasePath >>= \case
-      Left e -> fail $ P.toANSI 80 e
-      Right x -> pure x
-  Codebase.installUcmDependencies codebase
-  -- parse and run the transcript
-  output <-
-    flip (either err) (TR.parse "transcript" (Text.pack . stripMargin $ unTranscript transcript)) $ \stanzas ->
-      fmap Text.unpack $
-        TR.run "Unison.Test.Ucm.runTranscript Invalid Version String"
-          codebasePath
-          configFile
-          stanzas
-          codebase
-  closeCodebase
-  when debugTranscriptOutput $ traceM output
-  pure output
+  result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath \codebase -> do
+    Codebase.installUcmDependencies codebase
+    -- parse and run the transcript
+    output <-
+      flip (either err) (TR.parse "transcript" (Text.pack . stripMargin $ unTranscript transcript)) $ \stanzas ->
+        fmap Text.unpack $
+          TR.run "Unison.Test.Ucm.runTranscript Invalid Version String"
+            codebasePath
+            configFile
+            stanzas
+            codebase
+    when debugTranscriptOutput $ traceM output
+    pure output
+  case result of
+    Left e -> fail $ P.toANSI 80 e
+    Right x -> pure x
 
 lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a
-lowLevel (Codebase root fmt) f = do
+lowLevel (Codebase root fmt) action = do
   let cbInit = case fmt of CodebaseFormat2 -> SC.init
-  Codebase.Init.openCodebase cbInit "lowLevel" root >>= \case
+  result <- Codebase.Init.withOpenCodebase cbInit "lowLevel" root action
+  case result of
     Left p -> PT.putPrettyLn p *> pure (error "This really should have loaded")
-    Right (close, cb) -> f cb <* close
+    Right a -> pure a

unison-cli/unison/Main.hs

@@ -25,6 +25,7 @@ import qualified System.IO.Temp as Temp
 import qualified System.Path as Path
 import Text.Megaparsec (runParser)
 import qualified Unison.Codebase as Codebase
+import Unison.Codebase (Codebase, CodebasePath)
 import Unison.Codebase.Init (InitResult(..), InitError(..), CodebaseInitOptions(..), SpecifiedCodebase(..))
 import qualified Unison.Codebase.Init as CodebaseInit
 import qualified Unison.Codebase.Editor.Input as Input
@@ -96,10 +97,9 @@ main = do
                   ])
 
      Run (RunFromSymbol mainName) args -> do
-      ((closeCodebase, theCodebase),_) <- getCodebaseOrExit mCodePathOption
-      runtime <- RTI.startRuntime Version.gitDescribeWithDate
-      withArgs args $ execute theCodebase runtime mainName
-      closeCodebase
+      getCodebaseOrExit mCodePathOption \(_, _, theCodebase) -> do
+        runtime <- RTI.startRuntime Version.gitDescribeWithDate
+        withArgs args $ execute theCodebase runtime mainName
      Run (RunFromFile file mainName) args
        | not (isDotU file) -> PT.putPrettyLn $ P.callout "⚠️" "Files must have a .u extension."
        | otherwise -> do
@@ -107,26 +107,24 @@ main = do
             case e of
               Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
               Right contents -> do
-                ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption
-                rt <- RTI.startRuntime Version.gitDescribeWithDate
-                let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
-                launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes
-                closeCodebase
+                getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
+                  rt <- RTI.startRuntime Version.gitDescribeWithDate
+                  let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
+                  launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes
      Run (RunFromPipe mainName) args -> do
       e <- safeReadUtf8StdIn
       case e of
         Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
         Right contents -> do
-          ((closeCodebase, theCodebase), initRes) <- getCodebaseOrExit mCodePathOption
-          rt <- RTI.startRuntime Version.gitDescribeWithDate
-          let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
-          launch
-            currentDir config rt theCodebase
-            [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
-            Nothing
-            ShouldNotDownloadBase
-            initRes
-          closeCodebase
+          getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
+            rt <- RTI.startRuntime Version.gitDescribeWithDate
+            let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
+            launch
+              currentDir config rt theCodebase
+              [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
+              Nothing
+              ShouldNotDownloadBase
+              initRes
      Run (RunCompiled file) args ->
        BL.readFile file >>= \bs ->
        try (evaluate $ RTI.decodeStandalone bs) >>= \case
@@ -185,30 +183,29 @@ main = do
      Transcript shouldFork shouldSaveCodebase transcriptFiles ->
        runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
      Launch isHeadless codebaseServerOpts downloadBase -> do
-       ((closeCodebase, theCodebase),initRes)  <- getCodebaseOrExit mCodePathOption
-       runtime <- RTI.startRuntime Version.gitDescribeWithDate
-       Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do
-         case isHeadless of
-             Headless -> do
-                 PT.putPrettyLn $
-                   P.lines
-                     [ "I've started the Codebase API server at",
-                       P.string $ Server.urlFor Server.Api baseUrl,
-                       "and the Codebase UI at",
-                       P.string $ Server.urlFor Server.UI baseUrl
-                     ]
+       getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
+         runtime <- RTI.startRuntime Version.gitDescribeWithDate
+         Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do
+           case isHeadless of
+               Headless -> do
+                   PT.putPrettyLn $
+                     P.lines
+                       [ "I've started the Codebase API server at",
+                         P.string $ Server.urlFor Server.Api baseUrl,
+                         "and the Codebase UI at",
+                         P.string $ Server.urlFor Server.UI baseUrl
+                       ]
 
-                 PT.putPrettyLn $ P.string "Running the codebase manager headless with "
-                     <> P.shown GHC.Conc.numCapabilities
-                     <> " "
-                     <> plural' GHC.Conc.numCapabilities "cpu" "cpus"
-                     <> "."
-                 mvar <- newEmptyMVar
-                 takeMVar mvar
-             WithCLI -> do
-                 PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
-                 launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes
-                 closeCodebase
+                   PT.putPrettyLn $ P.string "Running the codebase manager headless with "
+                       <> P.shown GHC.Conc.numCapabilities
+                       <> " "
+                       <> plural' GHC.Conc.numCapabilities "cpu" "cpus"
+                       <> "."
+                   mvar <- newEmptyMVar
+                   takeMVar mvar
+               WithCLI -> do
+                   PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
+                   launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes
 
 prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath
 prepareTranscriptDir shouldFork mCodePathOption = do
@@ -217,7 +214,7 @@ prepareTranscriptDir shouldFork mCodePathOption = do
   case shouldFork of
     UseFork -> do
       -- A forked codebase does not need to Create a codebase, because it already exists
-      getCodebaseOrExit mCodePathOption
+      getCodebaseOrExit mCodePathOption $ const (pure ())
       path <- Codebase.getCodebaseDir (fmap codebasePathOptionToPath mCodePathOption)
       PT.putPrettyLn $ P.lines [
         P.wrap "Transcript will be run on a copy of the codebase at: ", "",
@@ -226,7 +223,7 @@ prepareTranscriptDir shouldFork mCodePathOption = do
       Path.copyDir (CodebaseInit.codebasePath cbInit path) (CodebaseInit.codebasePath cbInit tmp)
     DontFork -> do
       PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase."
-      void $ CodebaseInit.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp
+      CodebaseInit.withNewUcmCodebaseOrExit cbInit "main.transcript" tmp (const $ pure ())
   pure tmp
 
 runTranscripts'
@@ -248,9 +245,8 @@ runTranscripts' mcodepath transcriptDir args = do
       Right stanzas -> do
         configFilePath <- getConfigFilePath mcodepath
         -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
-        ((closeCodebase, theCodebase),_) <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir))
-        mdOut <- TR.run Version.gitDescribeWithDate transcriptDir configFilePath stanzas theCodebase
-        closeCodebase
+        mdOut <- getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) \(_, _, theCodebase) -> do
+          TR.run Version.gitDescribeWithDate transcriptDir configFilePath stanzas theCodebase
         let out = currentDir FP.</>
                    FP.addExtension (FP.dropExtension fileName ++ ".output")
                                    (FP.takeExtension fileName)
@@ -307,7 +303,7 @@ launch
   -> [Either Input.Event Input.Input]
   -> Maybe Server.BaseUrl
   -> ShouldDownloadBase
-  -> InitResult IO Symbol Ann
+  -> InitResult
   -> IO ()
 launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initResult =
   let
@@ -354,17 +350,28 @@ defaultBaseLib = rightMay $
   where
     (gitRef, _date) = Version.gitDescribe
 -- (Unison.Codebase.Init.FinalizerAndCodebase IO Symbol Ann, InitResult IO Symbol Ann)
-getCodebaseOrExit :: Maybe CodebasePathOption -> IO ((IO (), Codebase.Codebase IO Symbol Ann), InitResult IO Symbol Ann)
-getCodebaseOrExit codebasePathOption = do
+getCodebaseOrExit :: Maybe CodebasePathOption -> ((InitResult, CodebasePath, Codebase IO Symbol Ann) -> IO r) -> IO r
+getCodebaseOrExit codebasePathOption action = do
   initOptions <- argsToCodebaseInitOptions codebasePathOption
-  CodebaseInit.openOrCreateCodebase SC.init "main" initOptions >>= \case
-    Error dir error ->
+  result <- CodebaseInit.withOpenOrCreateCodebase SC.init "main" initOptions \case
+    cbInit@(CreatedCodebase, dir, _) -> do
+      pDir <- prettyDir dir
+      PT.putPrettyLn' ""
+      PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue pDir
+      action cbInit
+
+    cbInit@(OpenedCodebase, _, _) ->
+      action cbInit
+
+  case result of
+    Right r -> pure r
+    Left (dir, err) ->
       let
         message = do
           pDir <- prettyDir dir
           executableName <- P.text . Text.pack <$> getProgName
 
-          case error of
+          case err of
             NoCodebaseFoundAtSpecifiedDir ->
               pure (P.lines
                 [ "No codebase exists in " <> pDir <> ".",
@@ -383,16 +390,6 @@ getCodebaseOrExit codebasePathOption = do
         msg <- message
         PT.putPrettyLn' msg
         Exit.exitFailure
-
-    c@(CreatedCodebase dir cb) -> do
-      pDir <- prettyDir dir
-      PT.putPrettyLn' ""
-      PT.putPrettyLn' . P.indentN 2 . P.wrap $ "I created a new codebase for you at" <> P.blue pDir
-      pure (cb, c)
-
-    o@(OpenedCodebase _ cb) ->
-      pure (cb, o)
-
   where
     prettyDir dir = P.string <$> canonicalizePath dir
 

unison-core/src/Unison/HashQualified'.hs

@@ -68,6 +68,9 @@ toHash = \case
 toString :: Show n => HashQualified n -> String
 toString = Text.unpack . toText
 
+toStringWith :: (n -> String) -> HashQualified n -> String
+toStringWith f = Text.unpack . toTextWith (Text.pack . f)
+
 -- Parses possibly-hash-qualified into structured type.
 fromText :: Text -> Maybe (HashQualified Name)
 fromText t = case Text.breakOn "#" t of

unison-core/src/Unison/HashQualified.hs

@@ -85,6 +85,9 @@ take i = \case
 toString :: Show n => HashQualified n -> String
 toString = Text.unpack . toText
 
+toStringWith :: (n -> String) -> HashQualified n -> String
+toStringWith f = Text.unpack . toTextWith (Text.pack . f)
+
 fromString :: String -> Maybe (HashQualified Name)
 fromString = fromText . Text.pack
 

unison-src/transcripts/diff-namespace.md

@@ -152,6 +152,26 @@ a = 777
 .nsw> view a b
 ```
 
+## Should be able to diff a namespace hash from history.
+
+```unison
+x = 1
+```
+
+```ucm
+.hashdiff> add
+```
+
+```unison
+y = 2
+```
+
+```ucm
+.hashdiff> add
+.hashdiff> history
+.hashdiff> diff.namespace #hkrqt3tm05 #is7tu6katt
+```
+
 ##
 
 Updates:  -- 1 to 1

unison-src/transcripts/diff-namespace.output.md

@@ -686,6 +686,75 @@ a = 777
     use Nat +
     a#5f8uodgrtf + 1
 
+```
+## Should be able to diff a namespace hash from history.
+
+```unison
+x = 1
+```
+
+```ucm
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      x : Nat
+
+```
+```ucm
+  ☝️  The namespace .hashdiff is empty.
+
+.hashdiff> add
+
+  ⍟ I've added these definitions:
+  
+    x : Nat
+
+```
+```unison
+y = 2
+```
+
+```ucm
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      y : Nat
+
+```
+```ucm
+.hashdiff> add
+
+  ⍟ I've added these definitions:
+  
+    y : Nat
+
+.hashdiff> history
+
+  Note: The most recent namespace hash is immediately below this
+        message.
+  
+  ⊙ #is7tu6katt
+  
+    + Adds / updates:
+    
+      y
+  
+  □ #hkrqt3tm05 (start of history)
+
+.hashdiff> diff.namespace #hkrqt3tm05 #is7tu6katt
+
+  Added definitions:
+  
+    1. y : Nat
+
 ```
 ##