Merge branch 'trunk' into feature/improves-uri-parser-error-printing

.github/workflows/release.yaml

@@ -6,23 +6,6 @@ on:
       - "release/*"
 
 jobs:
-  release:
-    name: "release"
-    runs-on: "ubuntu-latest"
-
-    strategy:
-      # Run each build to completion, regardless of if any have failed
-      fail-fast: false
-    steps:
-      - name: create-release
-        uses: actions/create-release@v1
-        env:
-          GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}"
-        with:
-          if-no-files-found: error
-          name: build-linux
-          path: ucm-linux.tar.gz
-  
   release:
     name: "create_release"
     runs-on: "ubuntu-latest"

lib/unison-sqlite/src/Unison/Sqlite.hs

@@ -81,6 +81,8 @@ module Unison.Sqlite
     withStatement,
 
     -- * Exceptions
+    SomeSqliteException (..),
+    SqliteConnectException (..),
     SqliteQueryException (..),
     SqliteExceptionReason,
     SomeSqliteExceptionReason (..),
@@ -98,7 +100,13 @@ import Unison.Sqlite.Connection
   )
 import Unison.Sqlite.DB
 import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion)
-import Unison.Sqlite.Exception (SomeSqliteExceptionReason (..), SqliteExceptionReason, SqliteQueryException (..))
+import Unison.Sqlite.Exception
+  ( SomeSqliteException (..),
+    SomeSqliteExceptionReason (..),
+    SqliteConnectException (..),
+    SqliteExceptionReason,
+    SqliteQueryException (..),
+  )
 import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode)
 import Unison.Sqlite.Sql (Sql (..))
 

lib/unison-sqlite/src/Unison/Sqlite/Connection.hs

@@ -93,26 +93,29 @@ withConnection ::
   (Connection -> m a) ->
   m a
 withConnection name file =
-  bracket (openConnection name file) closeConnection
+  bracket (liftIO (openConnection name file)) (liftIO . closeConnection)
 
 -- Open a connection to a SQLite database.
 openConnection ::
-  MonadIO m =>
   -- Connection name, for debugging.
   String ->
   -- Path to SQLite database file.
   FilePath ->
-  m Connection
+  IO Connection
 openConnection name file = do
-  conn0 <- liftIO (Sqlite.open file)
+  conn0 <- Sqlite.open file `catch` rethrowAsSqliteConnectException name file
   let conn = Connection {conn = conn0, file, name}
-  liftIO (execute_ conn "PRAGMA foreign_keys = ON")
+  execute_ conn "PRAGMA foreign_keys = ON"
   pure conn
 
 -- Close a connection opened with 'openConnection'.
-closeConnection :: MonadIO m => Connection -> m ()
+closeConnection :: Connection -> IO ()
 closeConnection (Connection _ _ conn) =
-  liftIO (Sqlite.close conn)
+  -- FIXME if this throws an exception, it won't be under `SomeSqliteException`
+  -- Possible fixes:
+  --   1. Add close exception to the hierarchy, e.g. `SqliteCloseException`
+  --   2. Always ignore exceptions thrown by `close` (Mitchell prefers this one)
+  Sqlite.close conn
 
 -- Without results, with parameters
 

lib/unison-sqlite/src/Unison/Sqlite/Exception.hs

@@ -1,12 +1,20 @@
--- | Sqlite exception utils
+-- | Sqlite exception utils.
 module Unison.Sqlite.Exception
-  ( SqliteQueryException (..),
+  ( -- * @SomeSqliteException@
+    SomeSqliteException (..),
+
+    -- ** @SqliteConnectException@
+    SqliteConnectException (..),
+    rethrowAsSqliteConnectException,
+
+    -- ** @SqliteQueryException@
+    SqliteQueryException (..),
     pattern SqliteBusyException,
     isSqliteBusyException,
-    SqliteExceptionReason,
-    SomeSqliteExceptionReason (..),
     SqliteQueryExceptionInfo (..),
     throwSqliteQueryException,
+    SomeSqliteExceptionReason (..),
+    SqliteExceptionReason,
   )
 where
 
@@ -18,11 +26,97 @@ import Unison.Prelude
 import Unison.Sqlite.Sql
 import UnliftIO.Exception
 
+------------------------------------------------------------------------------------------------------------------------
+-- SomeSqliteException
+
+-- | The root exception for all exceptions thrown by this library.
+--
+-- @
+-- SomeException (from base)
+--   └── SomeSqliteException
+--         └── SqliteConnectException
+--         └── SqliteQueryException
+-- @
+--
+-- A @SomeSqliteException@ should not be inspected or used for control flow when run in a trusted environment, where the
+-- database can be assumed to be uncorrupt. Rather, wherever possible, the user of this library should write code that
+-- is guaranteed not to throw exceptions, by checking the necessary preconditions first. If that is not possible, it
+-- should be considered a bug in this library.
+--
+-- When actions are run on an untrusted codebase, e.g. one downloaded from a remote server, it is sufficient to catch
+-- just one exception type, @SomeSqliteException@.
+data SomeSqliteException
+  = forall e. Exception e => SomeSqliteException e
+  deriving anyclass (Exception)
+
+instance Show SomeSqliteException where
+  show (SomeSqliteException e) = show e
+
+------------------------------------------------------------------------------------------------------------------------
+-- SomeSqliteException
+--   └── SqliteConnectException
+
+-- | An exception thrown during establishing a connection.
+data SqliteConnectException = SqliteConnectException
+  { threadId :: ThreadId,
+    name :: String,
+    file :: FilePath,
+    exception :: Sqlite.SQLError
+  }
+  deriving stock (Show)
+
+instance Exception SqliteConnectException where
+  toException = toException . SomeSqliteException
+  fromException = fromException >=> \(SomeSqliteException e) -> cast e
+
+rethrowAsSqliteConnectException :: String -> FilePath -> Sqlite.SQLError -> IO a
+rethrowAsSqliteConnectException name file exception = do
+  threadId <- myThreadId
+  throwIO SqliteConnectException {exception, file, name, threadId}
+
+------------------------------------------------------------------------------------------------------------------------
+-- SomeSqliteException
+--   └── SqliteQueryException
+
+-- | A @SqliteQueryException@ represents an exception thrown during processing a query, paired with some context that
+-- resulted in the exception.
+--
+-- A @SqliteQueryException@ may result from a number of different conditions:
+--
+-- * The underlying sqlite library threw an exception.
+-- * A postcondition violation of a function like 'Unison.Sqlite.queryMaybeRow', which asserts that the resulting
+--   relation will have certain number of rows,
+-- * A postcondition violation of a function like 'Unison.Sqlite.queryListRowCheck', which takes a user-defined check as
+--   an argument.
+data SqliteQueryException = SqliteQueryException
+  { threadId :: ThreadId,
+    connection :: String,
+    sql :: Sql,
+    params :: String,
+    -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally
+    -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
+    exception :: SomeSqliteExceptionReason
+  }
+  deriving stock (Show)
+
+instance Exception SqliteQueryException where
+  toException = toException . SomeSqliteException
+  fromException = fromException >=> \(SomeSqliteException e) -> cast e
+
+pattern SqliteBusyException :: SqliteQueryException
+pattern SqliteBusyException <- (isSqliteBusyException -> True)
+
+isSqliteBusyException :: SqliteQueryException -> Bool
+isSqliteBusyException SqliteQueryException {exception = SomeSqliteExceptionReason reason} =
+  case cast reason of
+    Just (Sqlite.SQLError Sqlite.ErrorBusy _ _) -> True
+    _ -> False
+
 data SqliteQueryExceptionInfo params connection = SqliteQueryExceptionInfo
-  { sql :: Sql,
+  { connection :: connection,
+    sql :: Sql,
     params :: Maybe params,
-    exception :: SomeSqliteExceptionReason,
-    connection :: connection
+    exception :: SomeSqliteExceptionReason
   }
 
 throwSqliteQueryException :: Show connection => SqliteQueryExceptionInfo params connection -> IO a
@@ -37,11 +131,6 @@ throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, param
         threadId
       }
 
--- | A type that is intended to be used as additional context for a sqlite-related exception.
-class (Show e, Typeable e) => SqliteExceptionReason e
-
-instance SqliteExceptionReason Sqlite.SQLError
-
 data SomeSqliteExceptionReason
   = forall e. SqliteExceptionReason e => SomeSqliteExceptionReason e
   deriving anyclass (SqliteExceptionReason)
@@ -49,41 +138,7 @@ data SomeSqliteExceptionReason
 instance Show SomeSqliteExceptionReason where
   show (SomeSqliteExceptionReason x) = show x
 
--- | A @SqliteQueryException@ represents an exception thrown during processing a query, paired with some context that
--- resulted in the exception.
---
--- A @SqliteQueryException@ may result from a number of different conditions:
---
--- * The underlying sqlite library threw an exception.
--- * A postcondition violation of a function like 'Unison.Sqlite.queryMaybeRow', which asserts that the resulting
---   relation will have certain number of rows,
--- * A postcondition violation of a function like 'Unison.Sqlite.queryListRowCheck', which takes a user-defined check as
---   an argument.
---
--- A @SqliteQueryException@ should not be inspected or used for control flow when run in a trusted environment, where
--- the database can be assumed to be uncorrupt. Rather, wherever possible, the user of this library should write code
--- that is guaranteed not to throw exceptions, by checking the necessary preconditions first. If that is not possible,
--- it should be considered a bug in this library.
---
--- When actions are run on an untrusted codebase, e.g. one downloaded from a remote server, it is sufficient to catch
--- just one exception type, @SqliteQueryException@.
-data SqliteQueryException = SqliteQueryException
-  { sql :: Sql,
-    params :: String,
-    -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally
-    -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
-    exception :: SomeSqliteExceptionReason,
-    connection :: String,
-    threadId :: ThreadId
-  }
-  deriving stock (Show)
-  deriving anyclass (Exception)
+-- | A type that is intended to be used as additional context for a sqlite-related exception.
+class (Show e, Typeable e) => SqliteExceptionReason e
 
-pattern SqliteBusyException :: SqliteQueryException
-pattern SqliteBusyException <- (isSqliteBusyException -> True)
-
-isSqliteBusyException :: SqliteQueryException -> Bool
-isSqliteBusyException SqliteQueryException {exception = SomeSqliteExceptionReason reason} =
-  case cast reason of
-    Just (Sqlite.SQLError Sqlite.ErrorBusy _ _) -> True
-    _ -> False
+instance SqliteExceptionReason Sqlite.SQLError

parser-typechecker/src/Unison/Builtin.hs

@@ -40,7 +40,6 @@ import qualified Unison.Reference              as R
 import qualified Unison.Referent               as Referent
 import           Unison.Symbol                  ( Symbol )
 import qualified Unison.Type                   as Type
-import           Unison.Var                     ( Var )
 import qualified Unison.Var                    as Var
 import           Unison.Name                    ( Name )
 import qualified Unison.Name                   as Name
@@ -50,9 +49,9 @@ import qualified Unison.Typechecker.TypeLookup as TL
 import qualified Unison.Util.Relation          as Rel
 import qualified Unison.Hashing.V2.Convert as H
 
-type DataDeclaration v = DD.DataDeclaration v Ann
-type EffectDeclaration v = DD.EffectDeclaration v Ann
-type Type v = Type.Type v ()
+type DataDeclaration = DD.DataDeclaration Symbol Ann
+type EffectDeclaration = DD.EffectDeclaration Symbol Ann
+type Type = Type.Type Symbol ()
 
 names :: NamesWithHistory
 names = NamesWithHistory names0 mempty
@@ -61,23 +60,23 @@ names0 :: Names
 names0 = Names terms types where
   terms = Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs) <>
     Rel.fromList [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
-                 | (ct, (_,(r,decl))) <- ((CT.Data,) <$> builtinDataDecls @Symbol) <>
+                 | (ct, (_,(r,decl))) <- ((CT.Data,) <$> builtinDataDecls) <>
                     ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls)
                  , ((_,vc,_), cid) <- DD.constructors' decl `zip` [0..]] <>
     Rel.fromList [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i))
-                 | (v,i) <- Map.toList $ TD.builtinTermsRef @Symbol Intrinsic]
+                 | (v,i) <- Map.toList $ TD.builtinTermsRef Intrinsic]
   types = Rel.fromList builtinTypes <>
     Rel.fromList [ (Name.unsafeFromVar v, R.DerivedId r)
-                 | (v,(r,_)) <- builtinDataDecls @Symbol ] <>
+                 | (v,(r,_)) <- builtinDataDecls ] <>
     Rel.fromList [ (Name.unsafeFromVar v, R.DerivedId r)
-                 | (v,(r,_)) <- builtinEffectDecls @Symbol ]
+                 | (v,(r,_)) <- builtinEffectDecls ]
 
 -- note: this function is really for deciding whether `r` is a term or type,
 -- but it can only answer correctly for Builtins.
 isBuiltinType :: R.Reference -> Bool
 isBuiltinType r = elem r . fmap snd $ builtinTypes
 
-typeLookup :: Var v => TL.TypeLookup v Ann
+typeLookup :: TL.TypeLookup Symbol Ann
 typeLookup =
   TL.TypeLookup
     (fmap (const Intrinsic) <$> termRefTypes)
@@ -85,17 +84,17 @@ typeLookup =
     (Map.fromList . map (first R.DerivedId) $ map snd builtinEffectDecls)
 
 constructorType :: R.Reference -> Maybe CT.ConstructorType
-constructorType r = TL.constructorType (typeLookup @Symbol) r
+constructorType r = TL.constructorType typeLookup r
                 <|> Map.lookup r builtinConstructorType
 
-builtinDataDecls :: Var v => [(v, (R.Id, DataDeclaration v))]
+builtinDataDecls :: [(Symbol, (R.Id, DataDeclaration))]
 builtinDataDecls =
   [ (v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinDataDecls ]
 
-builtinEffectDecls :: Var v => [(v, (R.Id, EffectDeclaration v))]
+builtinEffectDecls :: [(Symbol, (R.Id, EffectDeclaration))]
 builtinEffectDecls = [ (v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinEffectDecls ]
 
-codeLookup :: (Applicative m, Var v) => CodeLookup v m Ann
+codeLookup :: Applicative m => CodeLookup Symbol m Ann
 codeLookup = CodeLookup (const $ pure Nothing) $ \r ->
   pure
     $ lookup r [ (r, Right x) | (r, x) <- snd <$> builtinDataDecls ]
@@ -104,19 +103,19 @@ codeLookup = CodeLookup (const $ pure Nothing) $ \r ->
 -- Relation predicate: Domain depends on range.
 builtinDependencies :: Rel.Relation R.Reference R.Reference
 builtinDependencies =
-  Rel.fromMultimap (Type.dependencies <$> termRefTypes @Symbol)
+  Rel.fromMultimap (Type.dependencies <$> termRefTypes)
 
 -- a relation whose domain is types and whose range is builtin terms with that type
 builtinTermsByType :: Rel.Relation R.Reference Referent.Referent
 builtinTermsByType =
   Rel.fromList [ (H.typeToReference ty, Referent.Ref r)
-               | (r, ty) <- Map.toList (termRefTypes @Symbol) ]
+               | (r, ty) <- Map.toList termRefTypes ]
 
 -- a relation whose domain is types and whose range is builtin terms that mention that type
 -- example: Nat.+ mentions the type `Nat`
 builtinTermsByTypeMention :: Rel.Relation R.Reference Referent.Referent
 builtinTermsByTypeMention =
-  Rel.fromList [ (m, Referent.Ref r) | (r, ty) <- Map.toList (termRefTypes @Symbol)
+  Rel.fromList [ (m, Referent.Ref r) | (r, ty) <- Map.toList termRefTypes
                                      , m <- toList $ H.typeToReferenceMentions ty ]
 
 -- The dependents of a builtin type is the set of builtin terms which
@@ -196,7 +195,7 @@ intrinsicTypeReferences = foldl' go mempty builtinTypesSrc where
     _ -> acc
 
 intrinsicTermReferences :: Set R.Reference
-intrinsicTermReferences = Map.keysSet (termRefTypes @Symbol)
+intrinsicTermReferences = Map.keysSet termRefTypes
 
 builtinConstructorType :: Map R.Reference CT.ConstructorType
 builtinConstructorType = Map.fromList [ (R.Builtin r, ct) | B' r ct <- builtinTypesSrc ]
@@ -204,11 +203,11 @@ builtinConstructorType = Map.fromList [ (R.Builtin r, ct) | B' r ct <- builtinTy
 data BuiltinTypeDSL = B' Text CT.ConstructorType | D' Text | Rename' Text Text | Alias' Text Text
 
 
-data BuiltinDSL v
+data BuiltinDSL
   -- simple builtin: name=ref, type
-  = B Text (Type v)
+  = B Text Type
   -- deprecated builtin: name=ref, type (TBD)
-  | D Text (Type v)
+  | D Text Type
   -- rename builtin: refname, newname
   -- must not appear before corresponding B/D
   -- will overwrite newname
@@ -219,13 +218,13 @@ data BuiltinDSL v
   | Alias Text Text
 
 
-instance Show (BuiltinDSL v) where
+instance Show BuiltinDSL where
   show (B t _) = Text.unpack $ "B" <> t
   show (Rename from to) = Text.unpack $ "Rename " <> from <> " to " <> to
   show _ = ""
 
 termNameRefs :: Map Name R.Reference
-termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion $ builtinsSrc @Symbol) where
+termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc) where
   go m = \case
     B r _tp -> Map.insert r (R.Builtin r) m
     D r _tp -> Map.insert r (R.Builtin r) m
@@ -246,17 +245,17 @@ termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion
                   "tried to alias `" <> r <> "` before it was declared."
         Just t -> Map.insert name t m
 
-termRefTypes :: Var v => Map R.Reference (Type v)
+termRefTypes :: Map R.Reference Type
 termRefTypes = foldl' go mempty builtinsSrc where
   go m = \case
     B r t -> Map.insert (R.Builtin r) t m
     D r t -> Map.insert (R.Builtin r) t m
     _ -> m
 
-typeOf :: Var v => a -> (Type v -> a) -> R.Reference -> a
+typeOf :: a -> (Type -> a) -> R.Reference -> a
 typeOf a f r = maybe a f (Map.lookup r termRefTypes)
 
-builtinsSrc :: Var v => [BuiltinDSL v]
+builtinsSrc :: [BuiltinDSL]
 builtinsSrc =
   [ B "Any.unsafeExtract" $ forall1 "a" (\a -> anyt --> a)
   , B "Int.+" $ int --> int --> int
@@ -503,22 +502,22 @@ builtinsSrc =
     ++ hashBuiltins
     ++ fmap (uncurry B) codeBuiltins
 
-moveUnder :: Text -> [(Text, Type v)] -> [BuiltinDSL v]
+moveUnder :: Text -> [(Text, Type)] -> [BuiltinDSL]
 moveUnder prefix bs = bs >>= \(n,ty) -> [B n ty, Rename n (prefix <> "." <> n)]
 
 -- builtins which have a version appended to their name (like the .v2 in IO.putBytes.v2)
 -- Should be renamed to not have the version suffix
-stripVersion :: [BuiltinDSL v] -> [BuiltinDSL v]
+stripVersion :: [BuiltinDSL] -> [BuiltinDSL]
 stripVersion bs =
   bs >>= rename where
-    rename :: BuiltinDSL v -> [BuiltinDSL v]
+    rename :: BuiltinDSL -> [BuiltinDSL]
     rename o@(B n _) = renameB o $ RE.matchOnceText regex n
     rename o@(Rename _ _) = [renameRename o]
     rename o = [o]
 
     -- When we see a B declaraiton, we add an additional Rename in the
     -- stream to rename it if it ahs a version string
-    renameB :: BuiltinDSL v -> Maybe (Text, RE.MatchText Text, Text) -> [BuiltinDSL v]
+    renameB :: BuiltinDSL -> Maybe (Text, RE.MatchText Text, Text) -> [BuiltinDSL]
     renameB o@(B n _) (Just (before, _, _)) = [o, Rename n before]
     renameB (Rename n _) (Just (before, _, _)) = [Rename n before]
     renameB x _ = [x]
@@ -529,7 +528,7 @@ stripVersion bs =
     -- [ B IO.putBytes.v2 _, Rename IO.putBytes.v2 io2.IO.putBytes.v2]
     -- and would be become:
     -- [ B IO.putBytes.v2 _, Rename IO.putBytes.v2 IO.putBytes, Rename IO.putBytes io2.IO.putBytes ]
-    renameRename :: BuiltinDSL v -> BuiltinDSL v
+    renameRename :: BuiltinDSL -> BuiltinDSL
     renameRename (Rename before1 before2) = let after1 = renamed before1 (RE.matchOnceText regex before1)
                                                 after2 = renamed before2 (RE.matchOnceText regex before2) in
                                                 Rename after1 after2
@@ -544,7 +543,7 @@ stripVersion bs =
     regex :: RE.Regex
     regex = RE.makeRegexOpts (RE.defaultCompOpt { RE.caseSensitive = False }) RE.defaultExecOpt r
 
-hashBuiltins :: Var v => [BuiltinDSL v]
+hashBuiltins :: [BuiltinDSL]
 hashBuiltins =
   [ B "crypto.hash" $ forall1 "a" (\a -> hashAlgo --> a --> bytes)
   , B "crypto.hashBytes" $ hashAlgo --> bytes --> bytes
@@ -556,7 +555,7 @@ hashBuiltins =
   hashAlgo = Type.ref() Type.hashAlgorithmRef
   h name = B ("crypto.HashAlgorithm."<>name) hashAlgo
 
-ioBuiltins :: Var v => [(Text, Type v)]
+ioBuiltins :: [(Text, Type)]
 ioBuiltins =
   [ ("IO.openFile.impl.v3", text --> fmode --> iof handle)
   , ("IO.closeFile.impl.v3", handle --> iof unit)
@@ -624,7 +623,7 @@ ioBuiltins =
 
   ]
 
-mvarBuiltins :: forall v. Var v => [(Text, Type v)]
+mvarBuiltins :: [(Text, Type)]
 mvarBuiltins =
   [ ("MVar.new", forall1 "a" $ \a -> a --> io (mvar a))
   , ("MVar.newEmpty.v2", forall1 "a" $ \a -> unit --> io (mvar a))
@@ -638,10 +637,10 @@ mvarBuiltins =
   , ("MVar.tryRead.impl.v3", forall1 "a" $ \a -> mvar a --> iof (optionalt a))
   ]
   where
-  mvar :: Type v -> Type v
+  mvar :: Type -> Type
   mvar a = Type.ref () Type.mvarRef `app` a
 
-codeBuiltins :: forall v. Var v => [(Text, Type v)]
+codeBuiltins :: [(Text, Type)]
 codeBuiltins =
   [ ("Code.dependencies", code --> list termLink)
   , ("Code.isMissing", termLink --> io boolean)
@@ -660,7 +659,7 @@ codeBuiltins =
   , ("Link.Term.toText", termLink --> text)
   ]
 
-stmBuiltins :: forall v. Var v => [(Text, Type v)]
+stmBuiltins :: [(Text, Type)]
 stmBuiltins =
   [ ("TVar.new", forall1 "a" $ \a -> a --> stm (tvar a))
   , ("TVar.newIO", forall1 "a" $ \a -> a --> io (tvar a))
@@ -672,14 +671,14 @@ stmBuiltins =
   , ("STM.atomically", forall1 "a" $ \a -> (unit --> stm a) --> io a)
   ]
 
-forall1 :: Var v => Text -> (Type v -> Type v) -> Type v
+forall1 :: Text -> (Type -> Type) -> Type
 forall1 name body =
   let
     a = Var.named name
   in Type.forall () a (body $ Type.var () a)
 
 forall2
-  :: Var v => Text -> Text -> (Type v -> Type v -> Type v) -> Type v
+  :: Text -> Text -> (Type -> Type -> Type) -> Type
 forall2 na nb body = Type.foralls () [a,b] (body ta tb)
   where
   a = Var.named na
@@ -688,10 +687,9 @@ forall2 na nb body = Type.foralls () [a,b] (body ta tb)
   tb = Type.var () b
 
 forall4
-  :: Var v
-  => Text -> Text -> Text -> Text
-  -> (Type v -> Type v -> Type v -> Type v -> Type v)
-  -> Type v
+  :: Text -> Text -> Text -> Text
+  -> (Type -> Type -> Type -> Type -> Type)
+  -> Type
 forall4 na nb nc nd body = Type.foralls () [a,b,c,d] (body ta tb tc td)
   where
   a = Var.named na
@@ -703,49 +701,49 @@ forall4 na nb nc nd body = Type.foralls () [a,b,c,d] (body ta tb tc td)
   tc = Type.var () c
   td = Type.var () d
 
-app :: Ord v => Type v -> Type v -> Type v
+app :: Type -> Type -> Type
 app = Type.app ()
 
-list :: Ord v => Type v -> Type v
+list :: Type -> Type
 list arg = Type.list () `app` arg
 
-optionalt :: Ord v => Type v -> Type v
+optionalt :: Type -> Type
 optionalt arg = DD.optionalType () `app` arg
 
-tuple :: Ord v => [Type v] -> Type v
+tuple :: [Type] -> Type
 tuple [t] = t
 tuple ts = foldr pair (DD.unitType ()) ts
 
-pair :: Ord v => Type v -> Type v -> Type v
+pair :: Type -> Type -> Type
 pair l r = DD.pairType () `app` l `app` r
 
-(-->) :: Ord v => Type v -> Type v -> Type v
+(-->) :: Type -> Type -> Type
 a --> b = Type.arrow () a b
 infixr -->
 
-io, iof :: Var v => Type v -> Type v
+io, iof :: Type -> Type
 io = Type.effect1 () (Type.builtinIO ())
 iof = io . eithert failure
 
-failure :: Var v => Type v
+failure :: Type
 failure = DD.failureType ()
 
-eithert :: Var v => Type v -> Type v -> Type v
+eithert :: Type -> Type -> Type
 eithert l r = DD.eitherType () `app` l `app` r
 
-scopet :: Var v => Type v -> Type v
+scopet :: Type -> Type
 scopet s = Type.scopeType () `app` s
 
-reft :: Var v => Type v -> Type v -> Type v
+reft :: Type -> Type -> Type
 reft s a = Type.refType () `app` s `app` a
 
-socket, threadId, handle, unit :: Var v => Type v
+socket, threadId, handle, unit :: Type
 socket = Type.socket ()
 threadId = Type.threadId ()
 handle = Type.fileHandle ()
 unit = DD.unitType ()
 
-tls, tlsClientConfig, tlsServerConfig, tlsSignedCert, tlsPrivateKey, tlsVersion, tlsCipher :: Var v => Type v
+tls, tlsClientConfig, tlsServerConfig, tlsSignedCert, tlsPrivateKey, tlsVersion, tlsCipher :: Type
 tls = Type.ref () Type.tlsRef
 tlsClientConfig = Type.ref () Type.tlsClientConfigRef
 tlsServerConfig = Type.ref () Type.tlsServerConfigRef
@@ -754,13 +752,13 @@ tlsPrivateKey = Type.ref () Type.tlsPrivateKeyRef
 tlsVersion = Type.ref () Type.tlsVersionRef
 tlsCipher = Type.ref () Type.tlsCipherRef
 
-fmode, bmode, smode, stdhandle :: Var v => Type v
+fmode, bmode, smode, stdhandle :: Type
 fmode = DD.fileModeType ()
 bmode = DD.bufferModeType ()
 smode = DD.seekModeType ()
 stdhandle = DD.stdHandleType ()
 
-int, nat, bytes, text, boolean, float, char :: Var v => Type v
+int, nat, bytes, text, boolean, float, char :: Type
 int = Type.int ()
 nat = Type.nat ()
 bytes = Type.bytes ()
@@ -769,12 +767,12 @@ boolean = Type.boolean ()
 float = Type.float ()
 char = Type.char ()
 
-anyt, code, value, termLink :: Var v => Type v
+anyt, code, value, termLink :: Type
 anyt = Type.ref() Type.anyRef
 code = Type.code ()
 value = Type.value ()
 termLink = Type.termLink ()
 
-stm, tvar :: Var v => Type v -> Type v
+stm, tvar :: Type -> Type
 stm = Type.effect1 () (Type.ref () Type.stmRef)
 tvar a = Type.ref () Type.tvarRef `app` a

parser-typechecker/src/Unison/Builtin/Decls.hs

@@ -36,14 +36,14 @@ lookupDeclRef str
   | [(_, d)] <- filter (\(v, _) -> v == Var.named str) decls = Reference.DerivedId d
   | otherwise = error $ "lookupDeclRef: missing \"" ++ unpack str ++ "\""
   where
-    decls = [ (a,b) | (a,b,_) <- builtinDataDecls @Symbol ]
+    decls = [ (a,b) | (a,b,_) <- builtinDataDecls ]
 
 lookupEffectRef :: Text -> Reference
 lookupEffectRef str
   | [(_, d)] <- filter (\(v, _) -> v == Var.named str) decls = Reference.DerivedId d
   | otherwise = error $ "lookupEffectRef: missing \"" ++ unpack str ++ "\""
   where
-    decls = [ (a,b) | (a,b,_) <- builtinEffectDecls @Symbol ]
+    decls = [ (a,b) | (a,b,_) <- builtinEffectDecls ]
 
 unitRef, pairRef, optionalRef, eitherRef :: Reference
 unitRef = lookupDeclRef "Unit"
@@ -83,7 +83,7 @@ unitCtorRef = Referent.Con (ConstructorReference unitRef 0) CT.Data
 
 constructorId :: Reference -> Text -> Maybe Int
 constructorId ref name = do
-  (_,_,dd) <- find (\(_,r,_) -> Reference.DerivedId r == ref) (builtinDataDecls @Symbol)
+  (_,_,dd) <- find (\(_,r,_) -> Reference.DerivedId r == ref) builtinDataDecls
   elemIndex name $ DD.constructorNames dd
 
 noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId
@@ -119,7 +119,7 @@ failConstructorReferent = Referent.Con (ConstructorReference testResultRef failC
 
 -- | parse some builtin data types, and resolve their free variables using
 -- | builtinTypes' and those types defined herein
-builtinDataDecls :: Var v => [(v, Reference.Id, DataDeclaration v ())]
+builtinDataDecls :: [(Symbol, Reference.Id, DataDeclaration Symbol ())]
 builtinDataDecls = rs1 ++ rs
  where
   rs1 = case hashDecls $ Map.fromList
@@ -309,7 +309,7 @@ builtinDataDecls = rs1 ++ rs
     , ((), v "Link.Type", Type.typeLink () `arr` var "Link")
     ]
 
-builtinEffectDecls :: Var v => [(v, Reference.Id, DD.EffectDeclaration v ())]
+builtinEffectDecls :: [(Symbol, Reference.Id, DD.EffectDeclaration Symbol ())]
 builtinEffectDecls =
   case hashDecls $ Map.fromList [ (v "Exception", exception) ] of
     Right a -> over _3 DD.EffectDeclaration <$> a

parser-typechecker/src/Unison/Builtin/Terms.hs

@@ -17,8 +17,9 @@ import Unison.Type (Type)
 import qualified Unison.Type as Type
 import Unison.Var (Var)
 import qualified Unison.Var as Var
+import Unison.Symbol (Symbol)
 
-builtinTermsSrc :: Var v => a -> [(v, Term v a, Type v a)]
+builtinTermsSrc :: a -> [(Symbol, Term Symbol a, Type Symbol a)]
 builtinTermsSrc a =
   [ ( v "metadata.isPropagated",
       Term.constructor a (ConstructorReference Decls.isPropagatedRef Decls.isPropagatedConstructorId),
@@ -33,7 +34,7 @@ builtinTermsSrc a =
 v :: Var v => Text -> v
 v = Var.named
 
-builtinTermsRef :: Var v => a -> Map v Reference.Id
+builtinTermsRef :: a -> Map Symbol Reference.Id
 builtinTermsRef a =
   fmap fst
     . H.hashTermComponents

parser-typechecker/src/Unison/Codebase.hs

@@ -233,10 +233,10 @@ lookupWatchCache codebase h = do
   maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
 
 typeLookupForDependencies ::
-  (Monad m, Var v, BuiltinAnnotation a) =>
-  Codebase m v a ->
+  (Monad m, BuiltinAnnotation a) =>
+  Codebase m Symbol a ->
   Set Reference ->
-  m (TL.TypeLookup v a)
+  m (TL.TypeLookup Symbol a)
 typeLookupForDependencies codebase s = do
   when debug $ traceM $ "typeLookupForDependencies " ++ show s
   foldM go mempty s
@@ -262,10 +262,10 @@ toCodeLookup c = CL.CodeLookup (getTerm c) (getTypeDeclaration c)
 -- Note that it is possible to call 'putTerm', then 'getTypeOfTerm', and receive @Nothing@, per the semantics of
 -- 'putTerm'.
 getTypeOfTerm ::
-  (Applicative m, Var v, BuiltinAnnotation a) =>
-  Codebase m v a ->
+  (Applicative m, BuiltinAnnotation a) =>
+  Codebase m Symbol a ->
   Reference ->
-  m (Maybe (Type v a))
+  m (Maybe (Type Symbol a))
 getTypeOfTerm _c r | debug && trace ("Codebase.getTypeOfTerm " ++ show r) False = undefined
 getTypeOfTerm c r = case r of
   Reference.DerivedId h -> getTypeOfTermImpl c h
@@ -276,10 +276,10 @@ getTypeOfTerm c r = case r of
 
 -- | Get the type of a referent.
 getTypeOfReferent ::
-  (BuiltinAnnotation a, Var v, Monad m) =>
-  Codebase m v a ->
+  (BuiltinAnnotation a, Monad m) =>
+  Codebase m Symbol a ->
   Referent.Referent ->
-  m (Maybe (Type v a))
+  m (Maybe (Type Symbol a))
 getTypeOfReferent c = \case
   Referent.Ref r -> getTypeOfTerm c r
   Referent.Con r _ -> getTypeOfConstructor c r
@@ -314,8 +314,8 @@ termsMentioningType c ty =
 
 -- | Check whether a reference is a term.
 isTerm ::
-  (Applicative m, Var v, BuiltinAnnotation a) =>
-  Codebase m v a ->
+  (Applicative m, BuiltinAnnotation a) =>
+  Codebase m Symbol a ->
   Reference ->
   m Bool
 isTerm code = fmap isJust . getTypeOfTerm code

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

@@ -48,6 +48,7 @@ module Unison.Codebase.Branch
   , stepEverywhere
   , batchUpdates
   , batchUpdatesM
+  , UpdateStrategy(..)
   -- *
   , addTermName
   , addTypeName
@@ -546,23 +547,55 @@ uncons (Branch b) = go <$> Causal.uncons b where
   go = over (_Just . _2) Branch
 
 -- | Run a series of updates at specific locations, aggregating all changes into a single causal step.
+-- History is managed according to 'UpdateStrategy'.
 stepManyAt ::
   forall m f.
   (Monad m, Foldable f) =>
+  UpdateStrategy ->
   f (Path, Branch0 m -> Branch0 m) ->
   Branch m ->
   Branch m
-stepManyAt actions startBranch =
-  runIdentity $ stepManyAtM actionsIdentity startBranch
+stepManyAt strat actions startBranch =
+  runIdentity $ stepManyAtM strat actionsIdentity startBranch
   where
     actionsIdentity :: [(Path, Branch0 m -> Identity (Branch0 m))]
     actionsIdentity = coerce (toList actions)
 
--- | Run a series of updates at specific locations, aggregating all changes into a single causal step.
+data UpdateStrategy
+  -- | Compress all changes into a single causal cons.
+  -- The resulting branch will have at most one new causal cons at each branch.
+  --
+  -- Note that this does NOT allow updates to add histories at children.
+  -- E.g. if the root.editme branch has history: A -> B -> C
+  -- and you use 'makeSetBranch' to update it to a new branch with history X -> Y -> Z,
+  -- CompressHistory will result in a history for root.editme of: A -> B -> C -> Z.
+  -- A 'snapshot' of the most recent state of the updated branch is appended to the existing history,
+  -- if the new state is equal to the existing state, no new history nodes are appended.
+  = CompressHistory
+
+  -- | Preserves any history changes made within the update.
+  --
+  -- Note that this allows you to clobber the history child branches if you want.
+  -- E.g. if the root.editme branch has history: A -> B -> C
+  -- and you use 'makeSetBranch' to update it to a new branch with history X -> Y -> Z,
+  -- AllowRewritingHistory will result in a history for root.editme of: X -> Y -> Z.
+  -- The history of the updated branch is replaced entirely.
+  | AllowRewritingHistory
+
+-- | Run a series of updates at specific locations.
+-- History is managed according to the 'UpdateStrategy'
 stepManyAtM :: (Monad m, Monad n, Foldable f)
-            => f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m)
-stepManyAtM actions startBranch =
-  (\changes -> changes `consBranchSnapshot` startBranch) <$> (startBranch & head_ %%~ batchUpdatesM actions)
+            => UpdateStrategy -> f (Path, Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m)
+stepManyAtM strat actions startBranch =
+  case strat of
+    AllowRewritingHistory -> steppedUpdates
+    CompressHistory -> squashedUpdates
+  where
+    steppedUpdates = do
+      stepM (batchUpdatesM actions) startBranch
+    squashedUpdates = do
+      updatedBranch <- startBranch & head_ %%~ batchUpdatesM actions
+      pure $ updatedBranch `consBranchSnapshot` startBranch
 
 -- starting at the leaves, apply `f` to every level of the branch.
 stepEverywhere
@@ -607,7 +640,7 @@ replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p))
 deletePatch :: NameSegment -> Branch0 m -> Branch0 m
 deletePatch n = over edits (Map.delete n)
 
-updateChildren ::NameSegment
+updateChildren :: NameSegment
                -> Branch m
                -> Map NameSegment (Branch m)
                -> Map NameSegment (Branch m)

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

@@ -16,6 +16,7 @@ module Unison.Codebase.BranchUtil
   -- * Branch modifications
   , makeSetBranch
   , makeDeleteBranch
+  , makeObliterateBranch
   , makeAddTypeName
   , makeDeleteTypeName
   , makeAddTermName
@@ -49,9 +50,11 @@ import qualified Unison.Codebase.Metadata as Metadata
 import qualified Unison.Util.List as List
 import Unison.Codebase.Patch (Patch)
 import Unison.NameSegment (NameSegment)
+import Control.Lens
 
+-- | Creates a branch containing all of the given names, with a single history node.
 fromNames :: Monad m => Names -> Branch m
-fromNames names0 = Branch.stepManyAt (typeActions <> termActions) Branch.empty
+fromNames names0 = Branch.stepManyAt Branch.CompressHistory (typeActions <> termActions) Branch.empty
   where
   typeActions = map doType . R.toList $ Names.types names0
   termActions = map doTerm . R.toList $ Names.terms names0
@@ -141,6 +144,16 @@ makeSetBranch ::
   Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)
 makeSetBranch (p, name) b = (p, Branch.setChildBranch name b)
 
+-- | "delete"s a branch by cons'ing an empty Branch0 onto the history at that location.
+-- See also 'makeObliterateBranch'.
 makeDeleteBranch ::
+  Applicative m =>
   Path.Split -> (Path, Branch0 m -> Branch0 m)
-makeDeleteBranch p = makeSetBranch p Branch.empty
+makeDeleteBranch (p, name) = (p, Branch.children . ix name %~ Branch.cons Branch.empty0)
+
+-- | Erase a branch and its history
+-- See also 'makeDeleteBranch'.
+-- Note that this requires a AllowRewritingHistory update strategy to behave correctly.
+makeObliterateBranch ::
+  Path.Split -> (Path, Branch0 m -> Branch0 m)
+makeObliterateBranch p = makeSetBranch p Branch.empty

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

@@ -19,18 +19,17 @@ import qualified Unison.Codebase               as Codebase
 import Unison.Parser.Ann (Ann)
 import qualified Unison.Codebase.Runtime       as Runtime
 import           Unison.Codebase.Runtime       ( Runtime )
-import           Unison.Var                    ( Var )
 import qualified Unison.PrettyPrintEnv         as PPE
 import qualified Unison.Codebase.Branch        as Branch
 import qualified Unison.Codebase.Branch.Names as Branch
 import           System.Exit (die)
 import           Control.Exception (finally)
 import qualified Unison.Names as Names
+import Unison.Symbol (Symbol)
 
 execute
-  :: Var v
-  => Codebase.Codebase IO v Ann
-  -> Runtime v
+  :: Codebase.Codebase IO Symbol Ann
+  -> Runtime Symbol
   -> String
   -> IO ()
 execute codebase runtime mainName =

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

@@ -28,6 +28,7 @@ import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import UnliftIO.Directory (canonicalizePath)
 import Unison.Codebase.Init.CreateCodebaseError
+import Unison.Codebase.Init.OpenCodebaseError
 
 -- CodebaseInitOptions is used to help pass around a Home directory that isn't the
 -- actual home directory of the user. Useful in tests.
@@ -48,7 +49,7 @@ type DebugName = String
 
 data Init m v a = Init
   { -- | open an existing codebase
-    withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
+    withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either OpenCodebaseError r),
     -- | create a new codebase
     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,
@@ -56,9 +57,10 @@ data Init m v a = Init
     codebasePath :: CodebasePath -> CodebasePath
   }
 
+-- | An error that occurred while initializing a codebase.
 data InitError
-  = NoCodebaseFoundAtSpecifiedDir
-  | FoundV1Codebase
+  = FoundV1Codebase
+  | InitErrorOpen OpenCodebaseError
   | CouldntCreateCodebase Pretty
 
 data InitResult
@@ -66,36 +68,51 @@ data InitResult
   | CreatedCodebase
   deriving (Show, Eq)
 
-createCodebaseWithResult :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either (CodebasePath, InitError) r)
+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))
 
-withOpenOrCreateCodebase :: MonadIO m => Init m v a -> DebugName -> CodebaseInitOptions -> ((InitResult, CodebasePath, Codebase m v a) -> m r) -> m (Either (CodebasePath, InitError) r)
+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
-  result <- withOpenCodebase cbInit debugName resolvedPath $ \codebase -> do
+  result <- withOpenCodebase cbInit debugName resolvedPath \codebase -> do
     action (OpenedCodebase, resolvedPath, codebase)
   case result of
     Right r -> pure $ Right r
-    Left _ ->
+    Left OpenCodebaseDoesntExist ->
       case initOptions of
         Home homeDir -> do
-          ifM (FCC.codebaseExists homeDir)
+          ifM
+            (FCC.codebaseExists homeDir)
             (do pure (Left (homeDir, FoundV1Codebase)))
-            (do
-              -- Create V2 codebase if neither a V1 or V2 exists
-              createCodebaseWithResult cbInit debugName homeDir (\codebase -> action (CreatedCodebase, homeDir, codebase))
+            ( do
+                -- Create V2 codebase if neither a V1 or V2 exists
+                createCodebaseWithResult cbInit debugName homeDir (\codebase -> action (CreatedCodebase, homeDir, codebase))
             )
-
         Specified specified ->
-          ifM (FCC.codebaseExists resolvedPath)
+          ifM
+            (FCC.codebaseExists resolvedPath)
             (pure $ Left (resolvedPath, FoundV1Codebase))
             case specified of
-               DontCreateWhenMissing dir ->
-                 pure (Left (dir, NoCodebaseFoundAtSpecifiedDir))
-               CreateWhenMissing dir ->
-                 createCodebaseWithResult cbInit debugName dir (\codebase -> action (CreatedCodebase, dir, codebase))
+              DontCreateWhenMissing dir ->
+                pure (Left (dir, (InitErrorOpen OpenCodebaseDoesntExist)))
+              CreateWhenMissing dir ->
+                createCodebaseWithResult cbInit debugName dir (\codebase -> action (CreatedCodebase, dir, codebase))
+    Left err@OpenCodebaseUnknownSchemaVersion{} -> pure (Left (resolvedPath, InitErrorOpen err))
+    Left err@OpenCodebaseOther{} -> pure (Left (resolvedPath, InitErrorOpen err))
 
 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

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

@@ -1,8 +1,8 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError(..), Pretty) where
+module Unison.Codebase.Init.CreateCodebaseError
+  ( CreateCodebaseError (..),
+    Pretty,
+  )
+where
 
 import qualified Unison.Util.Pretty as P
 

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

@@ -0,0 +1,17 @@
+-- | Open codebase error type.
+module Unison.Codebase.Init.OpenCodebaseError
+  ( OpenCodebaseError (..),
+  )
+where
+
+import Unison.Prelude
+import Unison.Util.Pretty (ColorText, Pretty)
+
+-- | An error that can occur when attempting to open a codebase.
+data OpenCodebaseError
+  = -- | The codebase doesn't exist.
+    OpenCodebaseDoesntExist
+    -- | The codebase exists, but its schema version is unknown to this application.
+  | OpenCodebaseUnknownSchemaVersion Word64
+  | OpenCodebaseOther (Pretty ColorText)
+  deriving stock (Show)

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

@@ -13,34 +13,22 @@ module Unison.Codebase.SqliteCodebase
 where
 
 import qualified Control.Concurrent
-import Control.Monad (filterM, unless, when, (>=>))
 import Control.Monad.Except (ExceptT (ExceptT), runExceptT, withExceptT)
 import qualified Control.Monad.Except as Except
-import Control.Monad.Extra (ifM, unlessM)
 import qualified Control.Monad.Extra as Monad
 import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.State (MonadState)
 import qualified Control.Monad.State as State
-import Control.Monad.Trans (MonadTrans (lift))
-import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
 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 qualified Data.List as List
-import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromJust)
-import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.IO as TextIO
-import Data.Traversable (for)
-import Data.Word (Word64)
 import qualified Database.SQLite.Simple as Sqlite
-import GHC.Stack (HasCallStack)
 import qualified System.Console.ANSI as ANSI
 import System.FilePath ((</>))
 import qualified System.FilePath as FilePath
@@ -49,7 +37,7 @@ import qualified U.Codebase.Reference as C.Reference
 import qualified U.Codebase.Referent as C.Referent
 import U.Codebase.Sqlite.Connection (Connection (Connection))
 import qualified U.Codebase.Sqlite.Connection as Connection
-import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion), ObjectId)
+import U.Codebase.Sqlite.DbId (ObjectId, SchemaVersion (SchemaVersion))
 import qualified U.Codebase.Sqlite.JournalMode as JournalMode
 import qualified U.Codebase.Sqlite.ObjectType as OT
 import U.Codebase.Sqlite.Operations (EDB)
@@ -60,9 +48,7 @@ import qualified U.Codebase.Sync as Sync
 import qualified U.Codebase.WatchKind as WK
 import qualified U.Util.Cache as Cache
 import qualified U.Util.Hash as H2
-import qualified Unison.Hashing.V2.Convert as Hashing
 import qualified U.Util.Monoid as Monoid
-import qualified Unison.Util.Set as Set
 import U.Util.Timing (time)
 import qualified Unison.Builtin as Builtins
 import Unison.Codebase (Codebase, CodebasePath)
@@ -75,6 +61,7 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRepo (WriteG
 import qualified Unison.Codebase.GitError as GitError
 import qualified Unison.Codebase.Init as Codebase
 import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1
+import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1
 import Unison.Codebase.Patch (Patch)
 import qualified Unison.Codebase.Reflog as Reflog
 import Unison.Codebase.ShortBranchHash (ShortBranchHash)
@@ -83,15 +70,16 @@ import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
 import qualified Unison.Codebase.SqliteCodebase.GitError as GitError
 import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral
 import Unison.Codebase.SyncMode (SyncMode)
-import Unison.Codebase.Type (PushGitBranchOpts(..))
+import Unison.Codebase.Type (PushGitBranchOpts (..))
 import qualified Unison.Codebase.Type as C
-import Unison.ConstructorReference (GConstructorReference(..))
+import Unison.ConstructorReference (GConstructorReference (..))
 import qualified Unison.ConstructorType as CT
 import Unison.DataDeclaration (Decl)
 import qualified Unison.DataDeclaration as Decl
 import Unison.Hash (Hash)
+import qualified Unison.Hashing.V2.Convert as Hashing
 import Unison.Parser.Ann (Ann)
-import Unison.Prelude (MaybeT (runMaybeT), fromMaybe, isJust, trace, traceM)
+import Unison.Prelude
 import Unison.Reference (Reference)
 import qualified Unison.Reference as Reference
 import qualified Unison.Referent as Referent
@@ -103,13 +91,13 @@ import Unison.Term (Term)
 import qualified Unison.Term as Term
 import Unison.Type (Type)
 import qualified Unison.Type as Type
-import qualified Unison.Util.Pretty as P
+import qualified Unison.Util.Set as Set
 import qualified Unison.WatchKind as UF
-import UnliftIO (MonadIO, catchIO, finally, liftIO, MonadUnliftIO, throwIO)
+import UnliftIO (MonadUnliftIO, catchIO, finally, throwIO)
 import qualified UnliftIO
-import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
+import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
+import UnliftIO.Exception (bracket, catch)
 import UnliftIO.STM
-import UnliftIO.Exception (catch, bracket)
 
 debug, debugProcessBranches, debugCommitFailedTransaction :: Bool
 debug = False
@@ -135,43 +123,22 @@ createCodebaseOrError ::
   CodebasePath ->
   (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
-        CreateCodebaseUnknownSchemaVersion v -> Codebase1.CreateCodebaseOther $ prettyError v
-      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 action
-
-data CreateCodebaseError
-  = CreateCodebaseAlreadyExists
-  | CreateCodebaseUnknownSchemaVersion SchemaVersion
-  deriving (Show)
-
-createCodebaseOrError' ::
-  (MonadUnliftIO m) =>
-  Codebase.DebugName ->
-  CodebasePath ->
-  (Codebase m Symbol Ann -> m r) ->
-  m (Either CreateCodebaseError r)
-createCodebaseOrError' debugName path action = do
+createCodebaseOrError debugName path action = do
   ifM
     (doesFileExist $ path </> codebasePath)
-    (pure $ Left CreateCodebaseAlreadyExists)
+    (pure $ Left Codebase1.CreateCodebaseAlreadyExists)
     do
       createDirectoryIfMissing True (path </> FilePath.takeDirectory codebasePath)
-      liftIO $
-        withConnection (debugName ++ ".createSchema") path $
-          ( runReaderT do
-              Q.createSchema
-              runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case
-                Left e -> error $ show e
-                Right () -> pure ()
-          )
+      withConnection (debugName ++ ".createSchema") path $
+        runReaderT do
+          Q.createSchema
+          runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case
+            Left e -> error $ show e
+            Right () -> pure ()
 
-      fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action)
+      sqliteCodebase debugName path action >>= \case
+        Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.")
+        Right result -> pure (Right result)
 
 withOpenOrCreateCodebaseConnection ::
   (MonadUnliftIO m) =>
@@ -192,15 +159,12 @@ getCodebaseOrError ::
   Codebase.DebugName ->
   CodebasePath ->
   (Codebase m Symbol Ann -> m r) ->
-  m (Either Codebase1.Pretty r)
+  m (Either Codebase1.OpenCodebaseError 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 action)
+    False -> pure (Left Codebase1.OpenCodebaseDoesntExist)
+    True ->
+      sqliteCodebase debugName dir action <&> mapLeft \(SchemaVersion n) -> Codebase1.OpenCodebaseUnknownSchemaVersion n
 
 initSchemaIfNotExist :: MonadIO m => FilePath -> m ()
 initSchemaIfNotExist path = liftIO do

parser-typechecker/src/Unison/Runtime/Builtin.hs

@@ -519,7 +519,7 @@ viewrs = unop0 3 $ \[s,u,i,l]
        , (1, ([BX,BX], TAbss [i,l] $ seqViewElem i l))
        ]
 
-eqt, neqt, leqt, geqt, lesst, great :: Var v => SuperNormal v
+eqt, neqt, leqt, geqt, lesst, great :: SuperNormal Symbol
 eqt = binop0 1 $ \[x,y,b]
    -> TLetD b UN (TPrm EQLT [x,y])
     $ boolift b
@@ -539,11 +539,11 @@ great = binop0 1 $ \[x,y,b]
      -> TLetD b UN (TPrm LEQT [x,y])
       $ notlift b
 
-packt, unpackt :: Var v => SuperNormal v
+packt, unpackt :: SuperNormal Symbol
 packt = unop0 0 $ \[s] -> TPrm PAKT [s]
 unpackt = unop0 0 $ \[t] -> TPrm UPKT [t]
 
-packb, unpackb, emptyb, appendb :: Var v => SuperNormal v
+packb, unpackb, emptyb, appendb :: SuperNormal Symbol
 packb = unop0 0 $ \[s] -> TPrm PAKB [s]
 unpackb = unop0 0 $ \[b] -> TPrm UPKB [b]
 emptyb
@@ -554,7 +554,7 @@ emptyb
   es = fresh1
 appendb = binop0 0 $ \[x,y] -> TPrm CATB [x,y]
 
-takeb, dropb, atb, sizeb, flattenb :: Var v => SuperNormal v
+takeb, dropb, atb, sizeb, flattenb :: SuperNormal Symbol
 takeb = binop0 1 $ \[n0,b,n]
      -> unbox n0 Ty.natRef n
       $ TPrm TAKB [n,b]
@@ -579,7 +579,7 @@ sizeb = unop0 1 $ \[b,n]
 
 flattenb = unop0 0 $ \[b] -> TPrm FLTB [b]
 
-i2t, n2t, f2t :: Var v => SuperNormal v
+i2t, n2t, f2t :: SuperNormal Symbol
 i2t = unop0 1 $ \[n0,n]
    -> unbox n0 Ty.intRef n
     $ TPrm ITOT [n]
@@ -590,7 +590,7 @@ f2t = unop0 1 $ \[f0,f]
    -> unbox f0 Ty.floatRef f
     $ TPrm FTOT [f]
 
-t2i, t2n, t2f :: Var v => SuperNormal v
+t2i, t2n, t2f :: SuperNormal Symbol
 t2i = unop0 3 $ \[x,t,n0,n]
    -> TLetD t UN (TPrm TTOI [x])
     . TMatch t . MatchSum $ mapFromList
@@ -616,18 +616,18 @@ t2f = unop0 3 $ \[x,t,f0,f]
                $ some f))
     ]
 
-equ :: Var v => SuperNormal v
+equ :: SuperNormal Symbol
 equ = binop0 1 $ \[x,y,b]
    -> TLetD b UN (TPrm EQLU [x,y])
     $ boolift b
 
-cmpu :: Var v => SuperNormal v
+cmpu :: SuperNormal Symbol
 cmpu = binop0 2 $ \[x,y,c,i]
     -> TLetD c UN (TPrm CMPU [x,y])
      . TLetD i UN (TPrm DECI [c])
      $ TCon Ty.intRef 0 [i]
 
-ltu :: Var v => SuperNormal v
+ltu :: SuperNormal Symbol
 ltu = binop0 1 $ \[x,y,c]
    -> TLetD c UN (TPrm CMPU [x,y])
     . TMatch c
@@ -635,7 +635,7 @@ ltu = binop0 1 $ \[x,y,c]
         (mapFromList [ (0, TCon Ty.booleanRef 1 []) ])
         (Just $ TCon Ty.booleanRef 0 [])
 
-gtu :: Var v => SuperNormal v
+gtu :: SuperNormal Symbol
 gtu = binop0 1 $ \[x,y,c]
    -> TLetD c UN (TPrm CMPU [x,y])
     . TMatch c
@@ -643,7 +643,7 @@ gtu = binop0 1 $ \[x,y,c]
         (mapFromList [ (2, TCon Ty.booleanRef 1 []) ])
         (Just $ TCon Ty.booleanRef 0 [])
 
-geu :: Var v => SuperNormal v
+geu :: SuperNormal Symbol
 geu = binop0 1 $ \[x,y,c]
    -> TLetD c UN (TPrm CMPU [x,y])
     . TMatch c
@@ -651,7 +651,7 @@ geu = binop0 1 $ \[x,y,c]
         (mapFromList [ (0, TCon Ty.booleanRef 0 []) ])
         (Just $ TCon Ty.booleanRef 1 [])
 
-leu :: Var v => SuperNormal v
+leu :: SuperNormal Symbol
 leu = binop0 1 $ \[x,y,c]
    -> TLetD c UN (TPrm CMPU [x,y])
     . TMatch c
@@ -659,17 +659,17 @@ leu = binop0 1 $ \[x,y,c]
         (mapFromList [ (2, TCon Ty.booleanRef 0 []) ])
         (Just $ TCon Ty.booleanRef 1 [])
 
-notb :: Var v => SuperNormal v
+notb :: SuperNormal Symbol
 notb = unop0 0 $ \[b]
     -> TMatch b . flip (MatchData Ty.booleanRef) Nothing
      $ mapFromList [ (0, ([], tru)), (1, ([], fls)) ]
 
-orb :: Var v => SuperNormal v
+orb :: SuperNormal Symbol
 orb = binop0 0 $ \[p,q]
    -> TMatch p . flip (MatchData Ty.booleanRef) Nothing
     $ mapFromList [ (1, ([], tru)), (0, ([], TVar q)) ]
 
-andb :: Var v => SuperNormal v
+andb :: SuperNormal Symbol
 andb = binop0 0 $ \[p,q]
     -> TMatch p . flip (MatchData Ty.booleanRef) Nothing
      $ mapFromList [ (0, ([], fls)), (1, ([], TVar q)) ]
@@ -677,7 +677,7 @@ andb = binop0 0 $ \[p,q]
 -- unsafeCoerce, used for numeric types where conversion is a
 -- no-op on the representation. Ideally this will be inlined and
 -- eliminated so that no instruction is necessary.
-cast :: Var v => Reference -> Reference -> SuperNormal v
+cast :: Reference -> Reference -> SuperNormal Symbol
 cast ri ro
   = unop0 1 $ \[x0,x]
  -> unbox x0 ri x
@@ -688,19 +688,19 @@ cast ri ro
 -- because it keeps the same representation. It is not capable of
 -- e.g. correctly translating between two types with compatible bit
 -- representations, because tagging information will be retained.
-poly'coerce :: Var v => SuperNormal v
+poly'coerce :: SuperNormal Symbol
 poly'coerce = unop0 0 $ \[x] -> TVar x
 
-jumpk :: Var v => SuperNormal v
+jumpk :: SuperNormal Symbol
 jumpk = binop0 0 $ \[k,a] -> TKon k [a]
 
-scope'run :: Var v => SuperNormal v
+scope'run :: SuperNormal Symbol
 scope'run
   = unop0 1 $ \[e, un]
  -> TLetD un BX (TCon Ty.unitRef 0 [])
   $ TApp (FVar e) [un]
 
-fork'comp :: Var v => SuperNormal v
+fork'comp :: SuperNormal Symbol
 fork'comp
   = Lambda [BX]
   . TAbs act
@@ -710,19 +710,19 @@ fork'comp
   where
   (act,unit,lz) = fresh3
 
-bug :: Var v => Util.Text.Text -> SuperNormal v
+bug :: Util.Text.Text -> SuperNormal Symbol
 bug name
   = unop0 1 $ \[x, n]
  -> TLetD n BX (TLit $ T name)
   $ TPrm EROR [n, x]
 
-watch :: Var v => SuperNormal v
+watch :: SuperNormal Symbol
 watch
   = binop0 0 $ \[t,v]
  -> TLets Direct [] [] (TPrm PRNT [t])
   $ TVar v
 
-raise :: Var v => SuperNormal v
+raise :: SuperNormal Symbol
 raise
   = unop0 4 $ \[r,f,n,j,k]
  -> TMatch r . flip (MatchData Ty.exceptionRef) Nothing $ mapFromList
@@ -736,22 +736,22 @@ raise
   where
   i = fromIntegral $ builtinTypeNumbering Map.! Ty.exceptionRef
 
-gen'trace :: Var v => SuperNormal v
+gen'trace :: SuperNormal Symbol
 gen'trace
   = binop0 0 $ \[t,v]
  -> TLets Direct [] [] (TPrm TRCE [t,v])
   $ TCon Ty.unitRef 0 []
 
-code'missing :: Var v => SuperNormal v
+code'missing :: SuperNormal Symbol
 code'missing
   = unop0 1 $ \[link,b]
  -> TLetD b UN (TPrm MISS [link])
   $ boolift b
 
-code'cache :: Var v => SuperNormal v
+code'cache :: SuperNormal Symbol
 code'cache = unop0 0 $ \[new] -> TPrm CACH [new]
 
-code'lookup :: Var v => SuperNormal v
+code'lookup :: SuperNormal Symbol
 code'lookup
   = unop0 2 $ \[link,t,r]
  -> TLetD t UN (TPrm LKUP [link])
@@ -760,7 +760,7 @@ code'lookup
   , (1, ([BX], TAbs r $ some r))
   ]
 
-code'validate :: Var v => SuperNormal v
+code'validate :: SuperNormal Symbol
 code'validate
   = unop0 5 $ \[item, t, ref, msg, extra, fail]
  -> TLetD t UN (TPrm CVLD [item])
@@ -774,11 +774,11 @@ code'validate
       $ none)
   ]
 
-term'link'to'text :: Var v => SuperNormal v
+term'link'to'text :: SuperNormal Symbol
 term'link'to'text
   = unop0 0 $ \[link] -> TPrm TLTT [link]
 
-value'load :: Var v => SuperNormal v
+value'load :: SuperNormal Symbol
 value'load
   = unop0 2 $ \[vlu,t,r]
  -> TLetD t UN (TPrm LOAD [vlu])
@@ -787,10 +787,10 @@ value'load
   , (1, ([BX], TAbs r $ right r))
   ]
 
-value'create :: Var v => SuperNormal v
+value'create :: SuperNormal Symbol
 value'create = unop0 0 $ \[x] -> TPrm VALU [x]
 
-stm'atomic :: Var v => SuperNormal v
+stm'atomic :: SuperNormal Symbol
 stm'atomic
   = Lambda [BX]
   . TAbs act
@@ -800,7 +800,7 @@ stm'atomic
   where
   (act,unit,lz) = fresh3
 
-type ForeignOp = forall v. Var v => FOp -> ([Mem], ANormal v)
+type ForeignOp = FOp -> ([Mem], ANormal Symbol)
 
 standard'handle :: ForeignOp
 standard'handle instr
@@ -811,12 +811,12 @@ standard'handle instr
   where
   (h0,h) = fresh2
 
-any'construct :: Var v => SuperNormal v
+any'construct :: SuperNormal Symbol
 any'construct
   = unop0 0 $ \[v]
  -> TCon Ty.anyRef 0 [v]
 
-any'extract :: Var v => SuperNormal v
+any'extract :: SuperNormal Symbol
 any'extract
   = unop0 1
   $ \[v,v1] -> TMatch v
@@ -1327,7 +1327,7 @@ boxToEBoxBox instr
   where
   (e,b,ev) = fresh3
 
-builtinLookup :: Var v => Map.Map Reference (SuperNormal v)
+builtinLookup :: Map.Map Reference (SuperNormal Symbol)
 builtinLookup
   = Map.fromList
   . map (\(t, f) -> (Builtin t, f)) $
@@ -1522,7 +1522,7 @@ type FDecl v
   = State (Word64, [(Data.Text.Text, SuperNormal v)], EnumMap Word64 ForeignFunc)
 
 declareForeign
-  :: Var v => Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl v ()
+  :: Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol ()
 declareForeign name op func
   = modify $ \(w, cs, fs)
       -> (w+1, (name, uncurry Lambda (op w)) : cs, mapInsert w func fs)
@@ -1555,7 +1555,7 @@ mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a)))
   flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) (unitValue))
   flatten (Right (Right a)) = Right a
 
-declareForeigns :: Var v => FDecl v ()
+declareForeigns :: FDecl Symbol ()
 declareForeigns = do
   declareForeign "IO.openFile.impl.v3" boxIomrToEFBox $
     mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) ->
@@ -1585,7 +1585,7 @@ declareForeigns = do
   declareForeign "IO.setBuffering.impl.v3" set'buffering
     . mkForeignIOF $ uncurry hSetBuffering
 
-  declareForeign "IO.getLine.impl.v1" boxToEFBox $ mkForeignIOF $ 
+  declareForeign "IO.getLine.impl.v1" boxToEFBox $ mkForeignIOF $
     fmap Util.Text.fromText . Text.IO.hGetLine
 
   declareForeign "IO.getBytes.impl.v3" boxNatToEFBox .  mkForeignIOF
@@ -1877,7 +1877,7 @@ declareForeigns = do
   declareForeign "Value.deserialize" boxToEBoxBox
     . mkForeign $ pure . deserializeValue . Bytes.toArray
   -- Hashing functions
-  let declareHashAlgorithm :: forall v alg . Var v => Hash.HashAlgorithm alg => Data.Text.Text -> alg -> FDecl v ()
+  let declareHashAlgorithm :: forall alg . Hash.HashAlgorithm alg => Data.Text.Text -> alg -> FDecl Symbol ()
       declareHashAlgorithm txt alg = do
         let algoRef = Builtin ("crypto.HashAlgorithm." <> txt)
         declareForeign ("crypto.HashAlgorithm." <> txt) direct . mkForeign $ \() ->
@@ -1943,13 +1943,13 @@ declareForeigns = do
   declareForeign "Bytes.toBase64" boxDirect . mkForeign $ pure . Bytes.toBase64
   declareForeign "Bytes.toBase64UrlUnpadded" boxDirect . mkForeign $ pure . Bytes.toBase64UrlUnpadded
 
-  declareForeign "Bytes.fromBase16" boxToEBoxBox . mkForeign $ 
+  declareForeign "Bytes.fromBase16" boxToEBoxBox . mkForeign $
     pure . mapLeft Util.Text.fromText . Bytes.fromBase16
-  declareForeign "Bytes.fromBase32" boxToEBoxBox . mkForeign $ 
+  declareForeign "Bytes.fromBase32" boxToEBoxBox . mkForeign $
     pure . mapLeft Util.Text.fromText . Bytes.fromBase32
-  declareForeign "Bytes.fromBase64" boxToEBoxBox . mkForeign $ 
+  declareForeign "Bytes.fromBase64" boxToEBoxBox . mkForeign $
     pure . mapLeft Util.Text.fromText . Bytes.fromBase64
-  declareForeign "Bytes.fromBase64UrlUnpadded" boxDirect . mkForeign $ 
+  declareForeign "Bytes.fromBase64UrlUnpadded" boxDirect . mkForeign $
     pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded
 
   declareForeign "Bytes.decodeNat64be" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat64be
@@ -1974,28 +1974,27 @@ typeReferences :: [(Reference, Word64)]
 typeReferences = zip rs [1..]
   where
   rs = [ r | (_,r) <- Ty.builtinTypes ]
-    ++ [ DerivedId i | (_,i,_) <- Ty.builtinDataDecls @Symbol ]
-    ++ [ DerivedId i | (_,i,_) <- Ty.builtinEffectDecls @Symbol ]
+    ++ [ DerivedId i | (_,i,_) <- Ty.builtinDataDecls ]
+    ++ [ DerivedId i | (_,i,_) <- Ty.builtinEffectDecls ]
 
 foreignDeclResults
-  :: Var v
-  => (Word64, [(Data.Text.Text, SuperNormal v)], EnumMap Word64 ForeignFunc)
+  :: (Word64, [(Data.Text.Text, SuperNormal Symbol)], EnumMap Word64 ForeignFunc)
 foreignDeclResults = execState declareForeigns (0, [], mempty)
 
-foreignWrappers :: Var v => [(Data.Text.Text, SuperNormal v)]
+foreignWrappers :: [(Data.Text.Text, SuperNormal Symbol)]
 foreignWrappers | (_, l, _) <- foreignDeclResults = reverse l
 
-numberedTermLookup :: Var v => EnumMap Word64 (SuperNormal v)
+numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol)
 numberedTermLookup
   = mapFromList . zip [1..] . Map.elems $ builtinLookup
 
 builtinTermNumbering :: Map Reference Word64
 builtinTermNumbering
-  = Map.fromList (zip (Map.keys $ builtinLookup @Symbol) [1..])
+  = Map.fromList (zip (Map.keys $ builtinLookup) [1..])
 
 builtinTermBackref :: EnumMap Word64 Reference
 builtinTermBackref
-  = mapFromList . zip [1..] . Map.keys $ builtinLookup @Symbol
+  = mapFromList . zip [1..] . Map.keys $ builtinLookup
 
 builtinTypeNumbering :: Map Reference Word64
 builtinTypeNumbering = Map.fromList typeReferences
@@ -2005,7 +2004,7 @@ builtinTypeBackref = mapFromList $ swap <$> typeReferences
   where swap (x, y) = (y, x)
 
 builtinForeigns :: EnumMap Word64 ForeignFunc
-builtinForeigns | (_, _, m) <- foreignDeclResults @Symbol = m
+builtinForeigns | (_, _, m) <- foreignDeclResults = m
 
 unsafeSTMToIO :: STM.STM a -> IO a
 unsafeSTMToIO (STM.STM m) = IO m

parser-typechecker/src/Unison/Runtime/IOSource.hs

@@ -39,9 +39,9 @@ typecheckedFile :: UF.TypecheckedUnisonFile Symbol Ann
 typecheckedFile = let x = typecheckedFile' in
   if debug then trace ("IOSource.typecheckedFile = " ++ show x) x else x
 
-typecheckedFile' :: forall v. Var.Var v => UF.TypecheckedUnisonFile v Ann
+typecheckedFile' :: UF.TypecheckedUnisonFile Symbol Ann
 typecheckedFile' = let
-  tl :: a -> Identity (TL.TypeLookup v Ann)
+  tl :: a -> Identity (TL.TypeLookup Symbol Ann)
   tl = const $ pure (External <$ Builtin.typeLookup)
   env = Parser.ParsingEnv mempty (Names.NamesWithHistory Builtin.names0 mempty)
   r = parseAndSynthesizeFile [] tl env "<IO.u builtin>" source

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -14,6 +14,7 @@ module Unison.Runtime.Interface
   , runStandalone
   , StoredCache
   , decodeStandalone
+  , RuntimeHost(..)
   ) where
 
 import GHC.Stack (HasCallStack)
@@ -35,6 +36,7 @@ import Data.IORef
 import Data.Foldable
 import Data.Set as Set
   (Set, (\\), singleton, map, notMember, filter, fromList)
+import qualified Data.Set as Set
 import Data.Map.Strict (Map)
 import Data.Traversable (for)
 import Data.Text (Text, isPrefixOf, pack)
@@ -76,6 +78,7 @@ import Unison.Runtime.Machine
   ( apply0, eval0
   , CCache(..), cacheAdd, cacheAdd0, baseCCache
   , refNumTm, refNumsTm, refNumsTy, refLookup
+  , ActiveThreads
   )
 import Unison.Runtime.MCode
   ( Combs, combDeps, combTypes, Args(..), Section(..), Instr(..)
@@ -86,6 +89,8 @@ import Unison.Runtime.Serialize as SER
 import Unison.Runtime.Stack
 import qualified Unison.Hashing.V2.Convert as Hashing
 import qualified Unison.ConstructorReference as RF
+import qualified UnliftIO.Concurrent as UnliftIO
+import qualified UnliftIO
 
 type Term v = Tm.Term v ()
 
@@ -326,9 +331,10 @@ backReferenceTm ws rs c i = do
 evalInContext
   :: PrettyPrintEnv
   -> EvalCtx
+  -> ActiveThreads
   -> Word64
   -> IO (Either Error (Term Symbol))
-evalInContext ppe ctx w = do
+evalInContext ppe ctx activeThreads w = do
   r <- newIORef BlackHole
   crs <- readTVarIO (combRefs $ ccache ctx)
   let hook = watchHook r
@@ -348,7 +354,7 @@ evalInContext ppe ctx w = do
 
   result <- traverse (const $ readIORef r)
           . first prettyError
-        <=< try $ apply0 (Just hook) ((ccache ctx) { tracer = tr }) w
+        <=< try $ apply0 (Just hook) ((ccache ctx) { tracer = tr }) activeThreads w
   pure $ decom =<< result
 
 executeMainComb
@@ -356,7 +362,7 @@ executeMainComb
   -> CCache
   -> IO ()
 executeMainComb init cc
-  = eval0 cc
+  = eval0 cc Nothing
   . Ins (Pack RF.unitRef 0 ZArgs)
   $ Call True init (BArg1 0)
 
@@ -421,9 +427,26 @@ decodeStandalone b = bimap thd thd $ runGetOrFail g b
     <*> getNat
     <*> getStoredCache
 
-startRuntime :: String -> IO (Runtime Symbol)
-startRuntime version = do
+-- | Whether the runtime is hosted within a UCM session or as a standalone process.
+data RuntimeHost
+  = Standalone
+  | UCM
+
+startRuntime :: RuntimeHost -> String -> IO (Runtime Symbol)
+startRuntime runtimeHost version = do
   ctxVar <- newIORef =<< baseContext
+  (activeThreads, cleanupThreads) <- case runtimeHost of
+        -- Don't bother tracking open threads when running standalone, they'll all be cleaned up
+        -- when the process itself exits.
+         Standalone -> pure (Nothing, pure ())
+        -- Track all forked threads so that they can be killed when the main process returns,
+        -- otherwise they'll be orphaned and left running.
+         UCM -> do
+           activeThreads <- newIORef Set.empty
+           let cleanupThreads = do
+                 threads <- readIORef activeThreads
+                 foldMap UnliftIO.killThread threads
+           pure (Just activeThreads, cleanupThreads)
   pure $ Runtime
        { terminate = pure ()
        , evaluate = \cl ppe tm -> catchInternalErrors $ do
@@ -432,7 +455,7 @@ startRuntime version = do
            ctx <- loadDeps cl ppe ctx tyrs tmrs
            (ctx, init) <- prepareEvaluation ppe tm ctx
            writeIORef ctxVar ctx
-           evalInContext ppe ctx init
+           evalInContext ppe ctx activeThreads init `UnliftIO.finally` cleanupThreads
        , compileTo = \cl ppe rf path -> tryM $ do
            ctx <- readIORef ctxVar
            (tyrs, tmrs) <- collectRefDeps cl rf
@@ -519,7 +542,7 @@ traceNeeded
   -> EnumMap Word64 Combs
   -> IO (EnumMap Word64 Combs)
 traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init where
-  ks = keysSet (numberedTermLookup @Symbol)
+  ks = keysSet numberedTermLookup
   go acc w
     | hasKey w acc = pure acc
     | Just co <- EC.lookup w src

parser-typechecker/src/Unison/Runtime/Machine.hs

@@ -13,13 +13,10 @@ import GHC.Stack
 import Control.Concurrent.STM as STM
 import GHC.Conc as STM (unsafeIOToSTM)
 
-import Data.Maybe (fromMaybe)
 
 import Data.Bits
-import Data.Foldable (toList, traverse_, fold)
 import Data.Ord (comparing)
 import Data.Traversable
-import Data.Word (Word64)
 
 import qualified Data.Text as DTx
 import qualified Unison.Util.Text as Util.Text
@@ -29,12 +26,10 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 
 import Control.Exception
-import Control.Lens ((<&>))
-import Control.Concurrent (forkIO, ThreadId)
+import Control.Concurrent (ThreadId)
 
 import qualified Data.Primitive.PrimArray as PA
 
-import Text.Read (readMaybe)
 
 import Unison.Builtin.Decls (exceptionRef, ioFailureRef)
 import Unison.Reference (Reference(Builtin), toShortHash)
@@ -67,7 +62,18 @@ import qualified Unison.Builtin.Decls as Rf
 import qualified Unison.Util.Bytes as By
 import Unison.Util.Pretty (toPlainUnbroken)
 import Unison.Util.EnumContainers as EC
+import UnliftIO (IORef)
+import qualified UnliftIO
+import qualified UnliftIO.Concurrent as UnliftIO
+import Unison.Prelude hiding (Text)
+import qualified Data.Set as Set
 
+-- | A ref storing every currently active thread.
+-- This is helpful for cleaning up orphaned threads when the main process
+-- completes. We track threads when running in a host process like UCM,
+-- otherwise we don't bother since forked threads are cleaned up automatically on
+-- termination.
+type ActiveThreads = Maybe (IORef (Set ThreadId))
 type Tag = Word64
 
 -- dynamic environment
@@ -77,7 +83,7 @@ type DEnv = EnumMap Word64 Closure
 data CCache
   = CCache
   { foreignFuncs :: EnumMap Word64 ForeignFunc
-  , tracer :: Text -> Closure -> IO ()
+  , tracer :: Unison.Util.Text.Text -> Closure -> IO ()
   , combs :: TVar (EnumMap Word64 Combs)
   , combRefs :: TVar (EnumMap Word64 Reference)
   , tagRefs :: TVar (EnumMap Word64 Reference)
@@ -136,11 +142,11 @@ infos :: String -> String -> IO ()
 infos ctx s = putStrLn $ ctx ++ ": " ++ s
 
 -- Entry point for evaluating a section
-eval0 :: CCache -> Section -> IO ()
-eval0 !env !co = do
+eval0 :: CCache -> ActiveThreads -> Section -> IO ()
+eval0 !env !activeThreads !co = do
   ustk <- alloc
   bstk <- alloc
-  eval env mempty ustk bstk KE co
+  eval env mempty activeThreads ustk bstk KE co
 
 topDEnv
   :: M.Map Reference Word64
@@ -162,8 +168,8 @@ topDEnv _ _ = (mempty, id)
 -- environment currently.
 apply0
   :: Maybe (Stack 'UN -> Stack 'BX -> IO ())
-  -> CCache -> Word64 -> IO ()
-apply0 !callback !env !i = do
+  -> CCache -> ActiveThreads -> Word64 -> IO ()
+apply0 !callback !env !threadTracker !i = do
     ustk <- alloc
     bstk <- alloc
     cmbrs <- readTVarIO $ combRefs env
@@ -172,7 +178,7 @@ apply0 !callback !env !i = do
     r <- case EC.lookup i cmbrs of
            Just r -> pure r
            Nothing -> die "apply0: missing reference to entry point"
-    apply env denv ustk bstk (kf k0) True ZArgs
+    apply env denv threadTracker ustk bstk (kf k0) True ZArgs
       $ PAp (CIx r i 0) unull bnull
   where
   k0 = maybe KE (CB . Hook) callback
@@ -181,11 +187,11 @@ apply0 !callback !env !i = do
 -- necessary to evaluate a closure with the provided information.
 apply1
   :: (Stack 'UN -> Stack 'BX -> IO ())
-  -> CCache -> Closure -> IO ()
-apply1 callback env clo = do
+  -> CCache -> ActiveThreads -> Closure -> IO ()
+apply1 callback env threadTracker clo = do
   ustk <- alloc
   bstk <- alloc
-  apply env mempty ustk bstk k0 True ZArgs clo
+  apply env mempty threadTracker ustk bstk k0 True ZArgs clo
   where
   k0 = CB $ Hook callback
 
@@ -195,15 +201,15 @@ apply1 callback env clo = do
 -- unit value.
 jump0
   :: (Stack 'UN -> Stack 'BX -> IO ())
-  -> CCache -> Closure -> IO ()
-jump0 !callback !env !clo = do
+  -> CCache -> ActiveThreads -> Closure -> IO ()
+jump0 !callback !env !activeThreads !clo = do
   ustk <- alloc
   bstk <- alloc
   (denv, kf) <-
     topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env)
   bstk <- bump bstk
   poke bstk (Enum Rf.unitRef unitTag)
-  jump env denv ustk bstk (kf k0) (BArg1 0) clo
+  jump env denv activeThreads ustk bstk (kf k0) (BArg1 0) clo
   where
   k0 = CB (Hook callback)
 
@@ -211,40 +217,40 @@ lookupDenv :: Word64 -> DEnv -> Closure
 lookupDenv p denv = fromMaybe BlackHole $ EC.lookup p denv
 
 exec
-  :: CCache -> DEnv
+  :: CCache -> DEnv -> ActiveThreads
   -> Stack 'UN -> Stack 'BX -> K
   -> Instr
   -> IO (DEnv, Stack 'UN, Stack 'BX, K)
-exec !_   !denv !ustk !bstk !k (Info tx) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Info tx) = do
   info tx ustk
   info tx bstk
   info tx k
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (Name r args) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (Name r args) = do
   bstk <- name ustk bstk args =<< resolve env denv bstk r
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (SetDyn p i) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (SetDyn p i) = do
   clo <- peekOff bstk i
   pure (EC.mapInsert p clo denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Capture p) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Capture p) = do
   (sk,denv,ustk,bstk,useg,bseg,k) <- splitCont denv ustk bstk k p
   bstk <- bump bstk
   poke bstk $ Captured sk useg bseg
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (UPrim1 op i) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (UPrim1 op i) = do
   ustk <- uprim1 ustk op i
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (UPrim2 op i j) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (UPrim2 op i j) = do
   ustk <- uprim2 ustk op i j
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim1 MISS i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i) = do
   clink <- peekOff bstk i
   let Ref link = unwrapForeign $ marshalToForeign clink
   m <- readTVarIO (intermed env)
   ustk <- bump ustk
   if (link `M.member` m) then poke ustk 1 else poke ustk 0
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i) = do
   arg <- peekOffS bstk i
   news <- decodeCacheArgument arg
   unknown <- cacheAdd news env
@@ -252,7 +258,7 @@ exec !env !denv !ustk !bstk !k (BPrim1 CACH i) = do
   pokeS bstk
     (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown)
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim1 CVLD i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i) = do
   arg <- peekOffS bstk i
   news <- decodeCacheArgument arg
   codeValidate news env >>= \case
@@ -269,7 +275,7 @@ exec !env !denv !ustk !bstk !k (BPrim1 CVLD i) = do
       pokeOff bstk 2 clo
       pure (denv, ustk, bstk, k)
 
-exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i) = do
   clink <- peekOff bstk i
   let Ref link = unwrapForeign $ marshalToForeign clink
   m <- readTVarIO (intermed env)
@@ -281,14 +287,14 @@ exec !env !denv !ustk !bstk !k (BPrim1 LKUP i) = do
       bstk <- bump bstk
       bstk <$ pokeBi bstk sg
   pure (denv, ustk, bstk, k)
-exec !_ !denv !ustk !bstk !k (BPrim1 TLTT i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 TLTT i) = do
   clink <- peekOff bstk i
   let Ref link = unwrapForeign $ marshalToForeign clink
   let sh = Util.Text.fromText . SH.toText $ toShortHash link
   bstk <- bump bstk
   pokeBi bstk sh
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim1 LOAD i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i) = do
   v <- peekOffBi bstk i
   ustk <- bump ustk
   bstk <- bump bstk
@@ -301,139 +307,158 @@ exec !env !denv !ustk !bstk !k (BPrim1 LOAD i) = do
       poke ustk 1
       poke bstk x
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim1 VALU i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) = do
   m <- readTVarIO (tagRefs env)
   c <- peekOff bstk i
   bstk <- bump bstk
   pokeBi bstk =<< reflectValue m c
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (BPrim1 op i) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (BPrim1 op i) = do
   (ustk,bstk) <- bprim1 ustk bstk op i
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (BPrim2 EQLU i j) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (BPrim2 EQLU i j) = do
   x <- peekOff bstk i
   y <- peekOff bstk j
   ustk <- bump ustk
   poke ustk $ if universalEq (==) x y then 1 else 0
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (BPrim2 CMPU i j) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (BPrim2 CMPU i j) = do
   x <- peekOff bstk i
   y <- peekOff bstk j
   ustk <- bump ustk
   poke ustk . fromEnum $ universalCompare compare x y
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (BPrim2 TRCE i j) = do
+exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j) = do
   tx <- peekOffBi bstk i
   clo <- peekOff bstk j
   tracer env tx clo
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (BPrim2 op i j) = do
+exec !_   !denv !_trackThreads !ustk !bstk !k (BPrim2 op i j) = do
   (ustk,bstk) <- bprim2 ustk bstk op i j
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Pack r t args) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Pack r t args) = do
   clo <- buildData ustk bstk r t args
   bstk <- bump bstk
   poke bstk clo
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Unpack r i) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Unpack r i) = do
   (ustk, bstk) <- dumpData r ustk bstk =<< peekOff bstk i
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Print i) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Print i) = do
   t <- peekOffBi bstk i
   Tx.putStrLn (Util.Text.toText t)
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Lit (MI n)) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Lit (MI n)) = do
   ustk <- bump ustk
   poke ustk n
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Lit (MD d)) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Lit (MD d)) = do
   ustk <- bump ustk
   pokeD ustk d
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Lit (MT t)) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Lit (MT t)) = do
   bstk <- bump bstk
   poke bstk (Foreign (Wrap Rf.textRef t))
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Lit (MM r)) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Lit (MM r)) = do
   bstk <- bump bstk
   poke bstk (Foreign (Wrap Rf.termLinkRef r))
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Lit (MY r)) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Lit (MY r)) = do
   bstk <- bump bstk
   poke bstk (Foreign (Wrap Rf.typeLinkRef r))
   pure (denv, ustk, bstk, k)
-exec !_   !denv !ustk !bstk !k (Reset ps) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Reset ps) = do
   pure (denv, ustk, bstk, Mark ps clos k)
  where clos = EC.restrictKeys denv ps
-exec !_   !denv !ustk !bstk !k (Seq as) = do
+exec !_   !denv !_activeThreads !ustk !bstk !k (Seq as) = do
   l <- closureArgs bstk as
   bstk <- bump bstk
   pokeS bstk $ Sq.fromList l
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (ForeignCall _ w args)
+exec !env !denv !_activeThreads !ustk !bstk !k (ForeignCall _ w args)
   | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env)
   = uncurry (denv,,,k)
       <$> (arg ustk bstk args >>= ev >>= res ustk bstk)
   | otherwise
     = die $ "reference to unknown foreign function: " ++ show w
-exec !env !denv !ustk !bstk !k (Fork i) = do
-  tid <- forkEval env =<< peekOff bstk i
+exec !env !denv !activeThreads !ustk !bstk !k (Fork i) = do
+  tid <- forkEval env activeThreads =<< peekOff bstk i
   bstk <- bump bstk
   poke bstk . Foreign . Wrap Rf.threadIdRef $ tid
   pure (denv, ustk, bstk, k)
-exec !env !denv !ustk !bstk !k (Atomically i) = do
+exec !env !denv !activeThreads !ustk !bstk !k (Atomically i) = do
   c <- peekOff bstk i
   bstk <- bump bstk
-  atomicEval env (poke bstk) c
+  atomicEval env activeThreads (poke bstk) c
   pure (denv, ustk, bstk, k)
 {-# inline exec #-}
 
-eval :: CCache -> DEnv
+eval :: CCache -> DEnv -> ActiveThreads
      -> Stack 'UN -> Stack 'BX -> K -> Section -> IO ()
-eval !env !denv !ustk !bstk !k (Match i (TestT df cs)) = do
+eval !env !denv !activeThreads !ustk !bstk !k (Match i (TestT df cs)) = do
   t <- peekOffBi bstk i
-  eval env denv ustk bstk k $ selectTextBranch t df cs
-eval !env !denv !ustk !bstk !k (Match i br) = do
+  eval env denv activeThreads ustk bstk k $ selectTextBranch t df cs
+eval !env !denv !activeThreads !ustk !bstk !k (Match i br) = do
   n <- peekOffN ustk i
-  eval env denv ustk bstk k $ selectBranch n br
-eval !env !denv !ustk !bstk !k (Yield args)
+  eval env denv activeThreads ustk bstk k $ selectBranch n br
+eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
   | asize ustk + asize bstk > 0 , BArg1 i <- args = do
-    peekOff bstk i >>= apply env denv ustk bstk k False ZArgs
+    peekOff bstk i >>= apply env denv activeThreads ustk bstk k False ZArgs
   | otherwise = do
     (ustk, bstk) <- moveArgs ustk bstk args
     ustk <- frameArgs ustk
     bstk <- frameArgs bstk
-    yield env denv ustk bstk k
-eval !env !denv !ustk !bstk !k (App ck r args) =
+    yield env denv activeThreads ustk bstk k
+eval !env !denv !activeThreads !ustk !bstk !k (App ck r args) =
   resolve env denv bstk r
-    >>= apply env denv ustk bstk k ck args
-eval !env !denv !ustk !bstk !k (Call ck n args) =
+    >>= apply env denv activeThreads ustk bstk k ck args
+eval !env !denv !activeThreads !ustk !bstk !k (Call ck n args) =
   combSection env (CIx dummyRef n 0)
-    >>= enter env denv ustk bstk k ck args
-eval !env !denv !ustk !bstk !k (Jump i args) =
-  peekOff bstk i >>= jump env denv ustk bstk k args
-eval !env !denv !ustk !bstk !k (Let nw cix) = do
+    >>= enter env denv activeThreads ustk bstk k ck args
+eval !env !denv !activeThreads !ustk !bstk !k (Jump i args) =
+  peekOff bstk i >>= jump env denv activeThreads ustk bstk k args
+eval !env !denv !activeThreads !ustk !bstk !k (Let nw cix) = do
   (ustk, ufsz, uasz) <- saveFrame ustk
   (bstk, bfsz, basz) <- saveFrame bstk
-  eval env denv ustk bstk (Push ufsz bfsz uasz basz cix k) nw
-eval !env !denv !ustk !bstk !k (Ins i nx) = do
-  (denv, ustk, bstk, k) <- exec env denv ustk bstk k i
-  eval env denv ustk bstk k nx
-eval !_   !_    !_    !_    !_ Exit = pure ()
-eval !_   !_    !_    !_    !_ (Die s) = die s
+  eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) nw
+eval !env !denv !activeThreads !ustk !bstk !k (Ins i nx) = do
+  (denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k i
+  eval env denv activeThreads ustk bstk k nx
+eval !_   !_    !_    !_activeThreads !_    !_ Exit = pure ()
+eval !_   !_    !_    !_activeThreads !_    !_ (Die s) = die s
 {-# noinline eval #-}
 
-forkEval :: CCache -> Closure -> IO ThreadId
-forkEval env clo
-  = forkIO (apply1 err env clo)
+forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId
+forkEval env activeThreads clo
+  = do threadId <- UnliftIO.forkFinally
+                    (apply1 err env activeThreads clo)
+                    (const cleanupThread)
+       trackThread threadId
+       pure threadId
   where
   err :: Stack 'UN -> Stack 'BX -> IO ()
   err _ _ = pure ()
+  trackThread :: ThreadId -> IO ()
+  trackThread threadID = do
+    case activeThreads of
+      Nothing -> pure ()
+      Just activeThreads -> UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.insert threadID ids, ()))
+  cleanupThread :: IO ()
+  cleanupThread = do
+    case activeThreads of
+      Nothing -> pure ()
+      Just activeThreads -> do
+        myThreadId <- UnliftIO.myThreadId
+        UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.delete myThreadId ids, ()))
+
+
+
 {-# inline forkEval #-}
 
-atomicEval :: CCache -> (Closure -> IO ()) -> Closure -> IO ()
-atomicEval env write clo
-  = atomically . unsafeIOToSTM $ apply1 readBack env clo
+atomicEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO ()
+atomicEval env activeThreads write clo
+  = atomically . unsafeIOToSTM $ apply1 readBack env activeThreads clo
   where
   readBack :: Stack 'UN -> Stack 'BX -> IO ()
   readBack _ bstk = peek bstk >>= write
@@ -441,15 +466,15 @@ atomicEval env write clo
 
 -- fast path application
 enter
-  :: CCache -> DEnv -> Stack 'UN -> Stack 'BX -> K
+  :: CCache -> DEnv -> ActiveThreads -> Stack 'UN -> Stack 'BX -> K
   -> Bool -> Args -> Comb -> IO ()
-enter !env !denv !ustk !bstk !k !ck !args !comb = do
+enter !env !denv !activeThreads !ustk !bstk !k !ck !args !comb = do
   ustk <- if ck then ensure ustk uf else pure ustk
   bstk <- if ck then ensure bstk bf else pure bstk
   (ustk, bstk) <- moveArgs ustk bstk args
   ustk <- acceptArgs ustk ua
   bstk <- acceptArgs bstk ba
-  eval env denv ustk bstk k entry
+  eval env denv activeThreads ustk bstk k entry
   where
   Lam ua ba uf bf entry = comb
 {-# inline enter #-}
@@ -467,9 +492,9 @@ name !ustk !bstk !args clo = case clo of
 
 -- slow path application
 apply
-  :: CCache -> DEnv -> Stack 'UN -> Stack 'BX -> K
+  :: CCache -> DEnv -> ActiveThreads -> Stack 'UN -> Stack 'BX -> K
   -> Bool -> Args -> Closure -> IO ()
-apply !env !denv !ustk !bstk !k !ck !args (PAp comb useg bseg) =
+apply !env !denv !activeThreads !ustk !bstk !k !ck !args (PAp comb useg bseg) =
   combSection env comb >>= \case
     Lam ua ba uf bf entry
       | ck || ua <= uac && ba <= bac -> do
@@ -480,48 +505,48 @@ apply !env !denv !ustk !bstk !k !ck !args (PAp comb useg bseg) =
         bstk <- dumpSeg bstk bseg A
         ustk <- acceptArgs ustk ua
         bstk <- acceptArgs bstk ba
-        eval env denv ustk bstk k entry
+        eval env denv activeThreads ustk bstk k entry
       | otherwise -> do
         (useg, bseg) <- closeArgs C ustk bstk useg bseg args
         ustk <- discardFrame =<< frameArgs ustk
         bstk <- discardFrame =<< frameArgs bstk
         bstk <- bump bstk
         poke bstk $ PAp comb useg bseg
-        yield env denv ustk bstk k
+        yield env denv activeThreads ustk bstk k
   where
   uac = asize ustk + ucount args + uscount useg
   bac = asize bstk + bcount args + bscount bseg
-apply !env !denv !ustk !bstk !k !_  !args clo
+apply !env !denv !activeThreads !ustk !bstk !k !_  !args clo
   | ZArgs <- args, asize ustk == 0, asize bstk == 0 = do
     ustk <- discardFrame ustk
     bstk <- discardFrame bstk
     bstk <- bump bstk
     poke bstk clo
-    yield env denv ustk bstk k
+    yield env denv activeThreads ustk bstk k
   | otherwise = die $ "applying non-function: " ++ show clo
 {-# inline apply #-}
 
 jump
-  :: CCache -> DEnv
+  :: CCache -> DEnv -> ActiveThreads
   -> Stack 'UN -> Stack 'BX -> K
   -> Args -> Closure -> IO ()
-jump !env !denv !ustk !bstk !k !args clo = case clo of
+jump !env !denv !activeThreads !ustk !bstk !k !args clo = case clo of
   Captured sk useg bseg -> do
     (useg, bseg) <- closeArgs K ustk bstk useg bseg args
     ustk <- discardFrame ustk
     bstk <- discardFrame bstk
     ustk <- dumpSeg ustk useg . F $ ucount args
     bstk <- dumpSeg bstk bseg . F $ bcount args
-    repush env ustk bstk denv sk k
+    repush env activeThreads ustk bstk denv sk k
   _ -> die "jump: non-cont"
 {-# inline jump #-}
 
 repush
-  :: CCache
+  :: CCache -> ActiveThreads
   -> Stack 'UN -> Stack 'BX -> DEnv -> K -> K -> IO ()
-repush !env !ustk !bstk = go
+repush !env !activeThreads !ustk !bstk = go
  where
- go !denv KE !k = yield env denv ustk bstk k
+ go !denv KE !k = yield env denv activeThreads ustk bstk k
  go !denv (Mark ps cs sk) !k = go denv' sk $ Mark ps cs' k
   where
   denv' = cs <> EC.withoutKeys denv ps
@@ -1405,22 +1430,22 @@ bprim2 !ustk !bstk CMPU _ _ = pure (ustk, bstk) -- impossible
 {-# inline bprim2 #-}
 
 yield
-  :: CCache -> DEnv
+  :: CCache -> DEnv -> ActiveThreads
   -> Stack 'UN -> Stack 'BX -> K -> IO ()
-yield !env !denv !ustk !bstk !k = leap denv k
+yield !env !denv !activeThreads !ustk !bstk !k = leap denv k
  where
  leap !denv0 (Mark ps cs k) = do
    let denv = cs <> EC.withoutKeys denv0 ps
        clo = denv0 EC.! EC.findMin ps
    poke bstk . DataB1 Rf.effectRef 0 =<< peek bstk
-   apply env denv ustk bstk k False (BArg1 0) clo
+   apply env denv activeThreads ustk bstk k False (BArg1 0) clo
  leap !denv (Push ufsz bfsz uasz basz cix k) = do
    Lam _ _ uf bf nx <- combSection env cix
    ustk <- restoreFrame ustk ufsz uasz
    bstk <- restoreFrame bstk bfsz basz
    ustk <- ensure ustk uf
    bstk <- ensure bstk bf
-   eval env denv ustk bstk k nx
+   eval env denv activeThreads ustk bstk k nx
  leap _ (CB (Hook f)) = f ustk bstk
  leap _ KE = pure ()
 {-# inline yield #-}

parser-typechecker/src/Unison/Runtime/Pattern.hs

@@ -32,7 +32,6 @@ import Unison.Pattern
 import qualified Unison.Pattern as P
 import Unison.Reference (Reference(..))
 import Unison.Runtime.ANF (internalBug)
-import Unison.Symbol (Symbol)
 import Unison.Term hiding (Term)
 import qualified Unison.Term as Tm
 import Unison.Var (Var, typed, freshIn, freshenId, Type(Pattern))
@@ -87,9 +86,9 @@ builtinDataSpec :: DataSpec
 builtinDataSpec = Map.fromList decls
  where
  decls = [ (DerivedId x, declFields $ Right y)
-         | (_,x,y) <- builtinDataDecls @Symbol ]
+         | (_,x,y) <- builtinDataDecls ]
       ++ [ (DerivedId x, declFields $ Left y)
-         | (_,x,y) <- builtinEffectDecls @Symbol ]
+         | (_,x,y) <- builtinEffectDecls ]
 
 -- A pattern compilation matrix is just a list of rows. There is
 -- no need for the rows to have uniform length; the variable

parser-typechecker/src/Unison/Server/Backend.hs

@@ -103,6 +103,7 @@ import qualified Unison.PrettyPrintEnv.Util as PPE
 import qualified Unison.Hashing.V2.Convert as Hashing
 import Unison.Util.AnnotatedText (AnnotatedText)
 import qualified Unison.Util.Monoid as Monoid
+import Unison.Symbol (Symbol)
 
 type SyntaxText = UST.SyntaxText' Reference
 
@@ -178,10 +179,10 @@ basicParseNames :: Branch m -> NameScoping -> Names
 basicParseNames root = fst . basicNames' root
 
 loadReferentType ::
-  (Applicative m, Var v) =>
-  Codebase m v Ann ->
+  Applicative m =>
+  Codebase m Symbol Ann ->
   Referent ->
-  m (Maybe (Type v Ann))
+  m (Maybe (Type Symbol Ann))
 loadReferentType codebase = \case
   Referent.Ref r -> Codebase.getTypeOfTerm codebase r
   Referent.Con r _ -> getTypeOfConstructor r
@@ -263,10 +264,10 @@ fuzzyFind path branch query =
 
 -- List the immediate children of a namespace
 findShallow
-  :: (Monad m, Var v)
-  => Codebase m v Ann
+  :: Monad m
+  => Codebase m Symbol Ann
   -> Path.Absolute
-  -> Backend m [ShallowListEntry v Ann]
+  -> Backend m [ShallowListEntry Symbol Ann]
 findShallow codebase path' = do
   let path = Path.unabsolute path'
   root <- getRootBranch codebase
@@ -276,10 +277,9 @@ findShallow codebase path' = do
     Just b  -> findShallowInBranch codebase b
 
 findShallowReadmeInBranchAndRender ::
-  Var v =>
   Width ->
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   NamesWithHistory ->
   Branch IO ->
   Backend IO (Maybe Doc.Doc)
@@ -300,7 +300,7 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr
         hqLen <- liftIO $ Codebase.hashLength codebase
         traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes)
 
-isDoc :: Monad m => Var v => Codebase m v Ann -> Referent -> m Bool
+isDoc :: Monad m => Codebase m Symbol Ann -> Referent -> m Bool
 isDoc codebase ref = do
   ot <- loadReferentType codebase ref
   pure $ isDoc' ot
@@ -315,12 +315,11 @@ isDoc' typeOfTerm = do
 
 termListEntry
   :: Monad m
-  => Var v
-  => Codebase m v Ann
+  => Codebase m Symbol Ann
   -> Branch0 m
   -> Referent
   -> HQ'.HQSegment
-  -> Backend m (TermEntry v Ann)
+  -> Backend m (TermEntry Symbol Ann)
 termListEntry codebase b0 r n = do
   ot <- lift $ loadReferentType codebase r
 
@@ -402,10 +401,10 @@ typeEntryToNamedType (TypeEntry r name tag) = NamedType
   }
 
 findShallowInBranch
-  :: (Monad m, Var v)
-  => Codebase m v Ann
+  :: Monad m
+  => Codebase m Symbol Ann
   -> Branch m
-  -> Backend m [ShallowListEntry v Ann]
+  -> Backend m [ShallowListEntry Symbol Ann]
 findShallowInBranch codebase b = do
   hashLength <- lift $ Codebase.hashLength codebase
   let hqTerm b0 ns r =
@@ -655,14 +654,12 @@ mungeSyntaxText
 mungeSyntaxText = fmap Syntax.convertElement
 
 prettyDefinitionsBySuffixes
-  :: forall v
-   . Var v
-  => NameScoping
+  :: NameScoping
   -> Maybe Branch.Hash
   -> Maybe Width
   -> Suffixify
-  -> Rt.Runtime v
-  -> Codebase IO v Ann
+  -> Rt.Runtime Symbol
+  -> Codebase IO Symbol Ann
   -> [HQ.HashQualified Name]
   -> Backend IO DefinitionDisplayResults
 prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt codebase query
@@ -738,7 +735,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod
         )
       mkTermDefinition r tm = do
         ts <- lift (Codebase.getTypeOfTerm codebase r)
-        let bn = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
+        let bn = bestNameForTerm @Symbol (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
         tag <- termEntryTag <$> termListEntry codebase
                                               (Branch.head branch)
                                               (Referent.Ref r)
@@ -756,7 +753,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod
                              (formatSuffixedType ppe width typeSig)
                              docs
       mkTypeDefinition r tp = do
-        let bn = bestNameForType @v (PPE.suffixifiedPPE ppe) width r
+        let bn = bestNameForType @Symbol (PPE.suffixifiedPPE ppe) width r
         tag <- Just . typeEntryTag <$> typeListEntry
           codebase
           r
@@ -779,20 +776,18 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod
                                     renderedMisses
 
 renderDoc ::
-  forall v.
-  Var v =>
   PPE.PrettyPrintEnvDecl ->
   Width ->
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   Reference ->
   IO (HashQualifiedName, UnisonHash, Doc.Doc)
 renderDoc ppe width rt codebase r = do
-  let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
+  let name = bestNameForTerm @Symbol (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
   let hash = Reference.toText r
   (name,hash,)
     <$> let tm = Term.ref () r
-         in Doc.renderDoc @v ppe terms typeOf eval decls tm
+         in Doc.renderDoc ppe terms typeOf eval decls tm
   where
     terms r@(Reference.Builtin _) = pure (Just (Term.ref () r))
     terms (Reference.DerivedId r) =
@@ -818,9 +813,8 @@ renderDoc ppe width rt codebase r = do
     decls _ = pure Nothing
 
 docsInBranchToHtmlFiles
-  :: Var v
-  => Rt.Runtime v
-  -> Codebase IO v Ann
+  :: Rt.Runtime Symbol
+  -> Codebase IO Symbol Ann
   -> Branch IO
   -> Path
   -> FilePath
@@ -917,15 +911,14 @@ data IncludeCycles
   | DontIncludeCycles
 
 definitionsBySuffixes ::
-  forall m v.
+  forall m.
   MonadIO m =>
-  Var v =>
   NameScoping ->
   Branch m ->
-  Codebase m v Ann ->
+  Codebase m Symbol Ann ->
   IncludeCycles ->
   [HQ.HashQualified Name] ->
-  m (DefinitionResults v)
+  m (DefinitionResults Symbol)
 definitionsBySuffixes namesScope branch codebase includeCycles query = do
   QueryResult misses results <- hqNameQuery namesScope branch codebase query
   terms <- do
@@ -956,7 +949,7 @@ definitionsBySuffixes namesScope branch codebase includeCycles query = do
           SR.Tm' _ (Referent.Con r _) _ -> Just (r ^. ConstructorReference.reference_)
           SR.Tp' _ r _ -> Just r
           _ -> Nothing
-    displayTerm :: Reference -> m (DisplayObject (Type v Ann) (Term v Ann))
+    displayTerm :: Reference -> m (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
     displayTerm = \case
       ref@(Reference.Builtin _) -> do
         pure case Map.lookup ref B.termRefTypes of
@@ -970,7 +963,7 @@ definitionsBySuffixes namesScope branch codebase includeCycles query = do
           Term.Ann' _ _ -> UserObject term
           -- manually annotate if necessary
           _ -> UserObject (Term.ann (ABT.annotation term) term ty)
-    displayType :: Reference -> m (DisplayObject () (DD.Decl v Ann))
+    displayType :: Reference -> m (DisplayObject () (DD.Decl Symbol Ann))
     displayType = \case
       Reference.Builtin _ -> pure (BuiltinObject ())
       Reference.DerivedId rid -> do
@@ -1025,10 +1018,10 @@ typesToSyntax suff width ppe0 types =
       DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d
 
 loadSearchResults
-  :: (Var v, Applicative m)
-  => Codebase m v Ann
+  :: Applicative m
+  => Codebase m Symbol Ann
   -> [SR.SearchResult]
-  -> m [SR'.SearchResult' v Ann]
+  -> m [SR'.SearchResult' Symbol Ann]
 loadSearchResults c = traverse loadSearchResult
  where
   loadSearchResult = \case

parser-typechecker/src/Unison/Server/CodebaseServer.hs

@@ -89,7 +89,7 @@ import qualified Unison.Server.Endpoints.NamespaceDetails as NamespaceDetails
 import qualified Unison.Server.Endpoints.NamespaceListing as NamespaceListing
 import qualified Unison.Server.Endpoints.Projects as Projects
 import Unison.Server.Types (mungeString)
-import Unison.Var (Var)
+import Unison.Symbol (Symbol)
 
 -- HTML content type
 data HTML = HTML
@@ -183,9 +183,8 @@ serverAPI :: Proxy AuthedServerAPI
 serverAPI = Proxy
 
 app ::
-  Var v =>
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   FilePath ->
   Strict.ByteString ->
   Application
@@ -236,10 +235,9 @@ data CodebaseServerOpts = CodebaseServerOpts
 
 -- The auth token required for accessing the server is passed to the function k
 startServer ::
-  Var v =>
   CodebaseServerOpts ->
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   (BaseUrl -> IO ()) ->
   IO ()
 startServer opts rt codebase onStart = do
@@ -291,9 +289,8 @@ serveUI :: Handler () -> FilePath -> Server WebUI
 serveUI tryAuth path _ = tryAuth *> serveIndex path
 
 server ::
-  Var v =>
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   FilePath ->
   Strict.ByteString ->
   Server AuthedServerAPI

parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs

@@ -56,8 +56,8 @@ import Unison.Server.Types
     addHeaders,
     mayDefaultWidth,
   )
+import Unison.Symbol (Symbol)
 import Unison.Util.Pretty (Width)
-import Unison.Var (Var)
 
 type FuzzyFindAPI =
   "find" :> QueryParam "rootBranch" SBH.ShortBranchHash
@@ -127,10 +127,8 @@ instance ToSample FoundResult where
   toSamples _ = noSamples
 
 serveFuzzyFind
-  :: forall v
-   . Var v
-  => Handler ()
-  -> Codebase IO v Ann
+  :: Handler ()
+  -> Codebase IO Symbol Ann
   -> Maybe SBH.ShortBranchHash
   -> Maybe HashQualifiedName
   -> Maybe Int
@@ -163,7 +161,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
               ( a
               , FoundTermResult
                 . FoundTerm
-                    (Backend.bestNameForTerm @v ppe (mayDefaultWidth typeWidth) r)
+                    (Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r)
                 $ Backend.termEntryToNamedTerm ppe typeWidth te
               )
             )
@@ -171,7 +169,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
         Backend.FoundTypeRef r -> do
           te <- Backend.typeListEntry codebase r n
           let namedType = Backend.typeEntryToNamedType te
-          let typeName = Backend.bestNameForType @v ppe (mayDefaultWidth typeWidth) r
+          let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r
           typeHeader <- Backend.typeDeclHeader codebase ppe r
           let ft = FoundType typeName typeHeader namedType
           pure (a, FoundTypeResult ft)

parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs

@@ -48,8 +48,8 @@ import Unison.Server.Types
     addHeaders,
     defaultWidth,
   )
+import Unison.Symbol (Symbol)
 import Unison.Util.Pretty (Width)
-import Unison.Var (Var)
 
 type DefinitionsAPI =
   "getDefinition" :> QueryParam "rootBranch" ShortBranchHash
@@ -110,10 +110,9 @@ instance ToSample DefinitionDisplayResults where
   toSamples _ = noSamples
 
 serveDefinitions
-  :: Var v
-  => Handler ()
-  -> Rt.Runtime v
-  -> Codebase IO v Ann
+  :: Handler ()
+  -> Rt.Runtime Symbol
+  -> Codebase IO Symbol Ann
   -> Maybe ShortBranchHash
   -> Maybe NamespaceFQN
   -> [HashQualifiedName]

parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs

@@ -38,8 +38,8 @@ import Unison.Server.Types
     branchToUnisonHash,
     mayDefaultWidth,
   )
+import Unison.Symbol (Symbol)
 import Unison.Util.Pretty (Width)
-import Unison.Var (Var)
 
 type NamespaceDetailsAPI =
   "namespaces" :> Capture "namespace" NamespaceFQN
@@ -77,10 +77,9 @@ instance ToJSON NamespaceDetails where
 deriving instance ToSchema NamespaceDetails
 
 serve ::
-  Var v =>
   Handler () ->
-  Rt.Runtime v ->
-  Codebase IO v Ann ->
+  Rt.Runtime Symbol ->
+  Codebase IO Symbol Ann ->
   NamespaceFQN ->
   Maybe ShortBranchHash ->
   Maybe Width ->

parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs

@@ -57,6 +57,7 @@ import Unison.Server.Types
     addHeaders,
     branchToUnisonHash,
   )
+import Unison.Symbol (Symbol)
 import Unison.Util.Pretty (Width)
 import Unison.Var (Var)
 import Control.Error.Util ((??))
@@ -156,9 +157,8 @@ backendListEntryToNamespaceObject ppe typeWidth = \case
     PatchObject . NamedPatch $ NameSegment.toText name
 
 serve
-  :: Var v
-  => Handler ()
-  -> Codebase IO v Ann
+  :: Handler ()
+  -> Codebase IO Symbol Ann
   -> Maybe ShortBranchHash
   -> Maybe NamespaceFQN
   -> Maybe NamespaceFQN

parser-typechecker/src/Unison/Server/Endpoints/Projects.hs

@@ -29,8 +29,8 @@ import Unison.Prelude
 import qualified Unison.Server.Backend as Backend
 import Unison.Server.Errors (backendError, badNamespace, rootBranchError)
 import Unison.Server.Types (APIGet, APIHeaders, UnisonHash, addHeaders)
+import Unison.Symbol (Symbol)
 import Unison.Util.Monoid (foldMapM)
-import Unison.Var (Var)
 
 type ProjectsAPI =
   "projects" :> QueryParam "rootBranch" ShortBranchHash
@@ -65,9 +65,8 @@ instance ToJSON ProjectListing where
   toEncoding = genericToEncoding defaultOptions
 
 backendListEntryToProjectListing ::
-  Var v =>
   ProjectOwner ->
-  Backend.ShallowListEntry v a ->
+  Backend.ShallowListEntry Symbol a ->
   Maybe ProjectListing
 backendListEntryToProjectListing owner = \case
   Backend.ShallowBranchEntry name hash _ ->
@@ -80,8 +79,7 @@ backendListEntryToProjectListing owner = \case
   _ -> Nothing
 
 entryToOwner ::
-  Var v =>
-  Backend.ShallowListEntry v a ->
+  Backend.ShallowListEntry Symbol a ->
   Maybe ProjectOwner
 entryToOwner = \case
   Backend.ShallowBranchEntry name _ _ ->
@@ -89,10 +87,8 @@ entryToOwner = \case
   _ -> Nothing
 
 serve ::
-  forall v.
-  Var v =>
   Handler () ->
-  Codebase IO v Ann ->
+  Codebase IO Symbol Ann ->
   Maybe ShortBranchHash ->
   Handler (APIHeaders [ProjectListing])
 serve tryAuth codebase mayRoot = addHeaders <$> (tryAuth *> projects)
@@ -125,7 +121,7 @@ serve tryAuth codebase mayRoot = addHeaders <$> (tryAuth *> projects)
 
     -- Minor helpers
 
-    findShallow :: Branch.Branch IO -> Handler [Backend.ShallowListEntry v Ann]
+    findShallow :: Branch.Branch IO -> Handler [Backend.ShallowListEntry Symbol Ann]
     findShallow branch =
       doBackend $ Backend.findShallowInBranch codebase branch
 

parser-typechecker/src/Unison/TermPrinter.hs

@@ -248,7 +248,13 @@ pretty0
     Delay' x ->
       paren (p >= 11 || isBlock x && p >= 3) $
         fmt S.DelayForceChar (l "'")
-        <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
+        <> (case x of
+              Lets' _ _ -> id
+              -- Add indentation below if we're opening parens with '(
+              -- This is in case the contents are a long function application
+              -- in which case the arguments should be indented.
+              _ -> PP.indentAfterNewline "  ")
+             (pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x)
     List' xs -> PP.group $
       (fmt S.DelimiterChar $ l "[") <> optSpace
           <> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace)
@@ -305,9 +311,9 @@ pretty0
           -- corequisite step in immediateChildBlockTerms (because it doesn't
           -- know bc.)  So we'll fail to take advantage of any opportunity
           -- this let block provides to add a use statement.  Not so bad.
-          (fmt S.ControlKeyword "let") `PP.hang` x
+          fmt S.ControlKeyword "let" `PP.hang` x
       lhs = PP.group (fst (prettyPattern n (ac 0 Block im doc) 10 vs pat))
-         `PP.hang` printGuard guard
+              `PP.hang` printGuard guard
       printGuard Nothing = mempty
       printGuard (Just g') =
         let (_,g) = ABT.unabs g'
@@ -578,7 +584,6 @@ printCase env im doc ms0 = PP.lines $ alignGrid grid where
       pure p
   arrow = fmt S.ControlKeyword "->"
   goBody im' uses body = uses [pretty0 env (ac 0 Block im' doc) body]
-
   -- If there's multiple guarded cases for this pattern, prints as:
   -- MyPattern x y
   --   | guard 1        -> 1
@@ -1099,65 +1104,104 @@ calcImports im tm = (im', render $ getUses result)
                    |> map snd
       in PP.lines (uses ++ rest)
 
--- Given a block term and a name (Prefix, Suffix) of interest, is there a strictly smaller
--- blockterm within it, containing all usages of that name?  A blockterm is a place
--- where the syntax lets us put a use statement, like the branches of an if/then/else.
--- We traverse the block terms by traversing the whole subtree with ABT.find, and paying
--- attention to those subterms that look like a blockterm.  This is complicated
--- by the fact that you can't always tell if a term is a blockterm just
--- by looking at it: in some cases you can only tell when you can see it in the context of
--- the wider term that contains it.  So actually we traverse the tree, at each term
--- looking for child terms that are block terms, and see if any of those contain
--- all the usages of the name.
+-- Given a block term and a name (Prefix, Suffix) of interest, is there a
+-- strictly smaller blockterm within it, containing all usages of that name?
+-- A blockterm is a place where the syntax lets us put a use statement, like the
+-- branches of an if/then/else.
+-- We traverse the block terms by traversing the whole subtree with ABT.find,
+-- and paying attention to those subterms that look like a blockterm.
+-- This is complicated by the fact that you can't always tell if a term is a
+-- blockterm just by looking at it: in some cases you can only tell when you can
+-- see it in the context of the wider term that contains it. So actually we
+-- traverse the tree, at each term looking for child terms that are block terms,
+-- and see if any of those contain all the usages of the name.
 -- Cut out the occurrences of "const id $" to get tracing.
-allInSubBlock :: (Var v, Ord v) => Term3 v PrintAnnotation -> Prefix -> Suffix -> Int -> Bool
-allInSubBlock tm p s i = let found = concat $ ABT.find finder tm
-                             result = any (/= tm) $ found
-                             tr = const id $ trace ("\nallInSubBlock(" ++ show p ++ ", " ++
-                                                    show s ++ ", " ++ show i ++ "): returns " ++
-                                                    show result ++ "\nInput:\n" ++ show tm ++
-                                                    "\nFound: \n" ++ show found ++ "\n\n")
-                         in tr result where
-  getUsages t =    annotation t
-                |> usages
-                |> Map.lookup s
-                |> fmap (Map.lookup p)
-                |> join
-                |> fromMaybe 0
-  finder t = let result = let i' = getUsages t
-                          in if i' < i
-                             then ABT.Prune
-                             else
-                               let found = filter hit $ immediateChildBlockTerms t
-                               in if (i' == i) && (not $ null found)
-                                  then ABT.Found found
-                                  else ABT.Continue
-                 children = concat (map (\t -> "child: " ++ show t ++ "\n") $ immediateChildBlockTerms t)
-                 tr = const id $ trace ("\nfinder: returns " ++ show result ++
-                                        "\n  children:" ++ children ++
-                                        "\n  input: \n" ++ show t ++ "\n\n")
-             in tr $ result
-  hit t = (getUsages t) == i
+allInSubBlock ::
+  (Var v, Ord v) =>
+  Term3 v PrintAnnotation ->
+  Prefix ->
+  Suffix ->
+  Int ->
+  Bool
+allInSubBlock tm p s i =
+  let found = concat $ ABT.find finder tm
+      result = any (/= tm) found
+      tr =
+        const id $ trace
+          ( "\nallInSubBlock("
+              ++ show p
+              ++ ", "
+              ++ show s
+              ++ ", "
+              ++ show i
+              ++ "): returns "
+              ++ show result
+              ++ "\nInput:\n"
+              ++ show tm
+              ++ "\nFound: \n"
+              ++ show found
+              ++ "\n\n"
+          )
+   in tr result
+  where
+    getUsages t =
+      annotation t
+        |> usages
+        |> Map.lookup s
+        |> fmap (Map.lookup p)
+        |> join
+        |> fromMaybe 0
+    finder t =
+      let result =
+            let i' = getUsages t
+             in if i' < i
+                  then ABT.Prune
+                  else
+                    let found = filter hit $ immediateChildBlockTerms t
+                     in if (i' == i) && (not $ null found)
+                          then ABT.Found found
+                          else ABT.Continue
+          children =
+            concat
+              ( map (\t -> "child: " ++ show t ++ "\n") $
+                  immediateChildBlockTerms t
+              )
+          tr =
+            const id $ trace
+              ( "\nfinder: returns "
+                  ++ show result
+                  ++ "\n  children:"
+                  ++ children
+                  ++ "\n  input: \n"
+                  ++ show t
+                  ++ "\n\n"
+              )
+       in tr $ result
+    hit t = (getUsages t) == i
 
--- Return any blockterms at or immediately under this term.  Has to match the places in the
--- syntax that get a call to `calcImports` in `pretty0`.  AST nodes that do a calcImports in
--- pretty0, in order to try and emit a `use` statement, need to be emitted also by this
--- function, otherwise the `use` statement may come out at an enclosing scope instead.
-immediateChildBlockTerms :: (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a]
+-- Return any blockterms at or immediately under this term. Has to match the
+-- places in the syntax that get a call to `calcImports` in `pretty0`.
+-- AST nodes that do a calcImports in pretty0, in order to try and emit a `use`
+-- statement, need to be emitted also by this function, otherwise the `use`
+-- statement may come out at an enclosing scope instead.
+immediateChildBlockTerms ::
+  (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a]
 immediateChildBlockTerms = \case
-    Handle' handler body -> [handler, body]
-    If' _ t f -> [t, f]
-    LetBlock bs _ -> concat $ map doLet bs
-    Match' scrute branches ->
-      if isDestructuringBind scrute branches then [scrute]
-      else concat $ map doCase branches
-    _ -> []
+  Handle' handler body -> [handler, body]
+  If' _ t f -> [t, f]
+  LetBlock bs e -> concatMap doLet bs ++ handleDelay e
+  Delay' b@(Lets' _ _) -> [b]
+  Match' scrute branches ->
+    if isDestructuringBind scrute branches
+      then [scrute]
+      else concatMap doCase branches
+  _ -> []
   where
     doCase (MatchCase _ _ (AbsN' _ body)) = [body]
+    handleDelay (Delay' b@(Lets' _ _)) = [b]
+    handleDelay _ = []
     doLet (v, Ann' tm _) = doLet (v, tm)
-    doLet (v, LamsNamedOpt' _ body) = if isBlank $ Var.nameStr v
-                                      then []
-                                      else [body]
+    doLet (v, LamsNamedOpt' _ body) = [body | not (isBlank $ Var.nameStr v)]
     doLet t = error (show t) []
 
 -- Matches with a single case, no variable shadowing, and where the pattern

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

@@ -12,6 +12,7 @@ import Unison.Codebase.Init
     , Init(..)
     , SpecifiedCodebase(..)
     )
+import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError(..))
 import qualified System.IO.Temp as Temp
 
 -- keep it off for CI, since the random temp dirs it generates show up in the
@@ -58,7 +59,7 @@ test = scope "Codebase.Init" $ tests
         res <- io $ CI.withOpenOrCreateCodebase cbInit "ucm-test" (Specified (DontCreateWhenMissing tmp)) $ \case
           _ -> pure False
         case res of
-          Left (_, CI.NoCodebaseFoundAtSpecifiedDir) -> expect True
+          Left (_, CI.InitErrorOpen OpenCodebaseDoesntExist) -> expect True
           _ -> expect False
     ]
   , scope "*with* a --codebase-create flag" $ tests
@@ -102,8 +103,7 @@ initMockWithoutCodebase ::  IO (Init IO v a)
 initMockWithoutCodebase = do
   let codebase = error "did we /actually/ need a Codebase?"
   pure $ Init {
-    -- withOpenCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either Pretty r),
-    withOpenCodebase = \_ _ _ -> pure (Left "no codebase found"),
+    withOpenCodebase = \_ _ _ -> pure (Left OpenCodebaseDoesntExist),
     -- withCreatedCodebase :: forall r. DebugName -> CodebasePath -> (Codebase m v a -> m r) -> m (Either CreateCodebaseError r),
     withCreatedCodebase = \_ _ action -> Right <$> action codebase,
     -- CodebasePath -> CodebasePath

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

@@ -58,13 +58,12 @@ showParseError :: Var v
 showParseError s = Pr.toANSI 60 . prettyParseError s
 
 parseAndSynthesizeAsFile
-  :: Var v
-  => [Type v]
+  :: [Type Symbol]
   -> FilePath
   -> String
   -> Result
-       (Seq (Note v Ann))
-       (Either Names (TypecheckedUnisonFile v Ann))
+       (Seq (Note Symbol Ann))
+       (Either Names (TypecheckedUnisonFile Symbol Ann))
 parseAndSynthesizeAsFile ambient filename s = FP.parseAndSynthesizeFile
   ambient
   (\_deps -> pure B.typeLookup)

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

@@ -17,7 +17,6 @@ import Data.Word (Word64)
 import Unison.Util.EnumContainers as EC
 
 import Unison.Term (unannotate)
-import Unison.Symbol (Symbol)
 import Unison.Reference (Reference(Builtin))
 import Unison.Runtime.Pattern
 import Unison.Runtime.ANF
@@ -52,7 +51,7 @@ testEval0 env sect = do
   cc <- io baseCCache
   modifyTVarTest (combs cc) (env <>)
   modifyTVarTest (combRefs cc) ((dummyRef <$ env) <>)
-  io $ eval0 cc sect
+  io $ eval0 cc Nothing sect
   ok
 
 builtins :: Reference -> Word64
@@ -63,7 +62,7 @@ builtins r
 
 cenv :: EnumMap Word64 Combs
 cenv = fmap (emitComb numbering 0 mempty . (0,))
-     $ numberedTermLookup @Symbol
+       numberedTermLookup
 
 env :: Combs -> EnumMap Word64 Combs
 env m = mapInsert (bit 24) m

parser-typechecker/tests/Unison/Test/Typechecker/TypeError.hs

@@ -14,7 +14,6 @@ import qualified Unison.Typechecker.Context   as C
 import           Unison.Typechecker.Extractor (ErrorExtractor)
 import qualified Unison.Typechecker.Extractor as Ex
 import qualified Unison.Typechecker.TypeError as Err
-import           Unison.Var                   (Var)
 import qualified Unison.Test.Common as Common
 
 test :: Test ()
@@ -47,12 +46,12 @@ test = scope "> extractor" . tests $
         y s ex = scope s $ expect $ yieldsError s ex
         n s ex = scope s $ expect $ noYieldsError s ex
 
-noYieldsError :: Var v => String -> ErrorExtractor v Ann a -> Bool
+noYieldsError :: String -> ErrorExtractor Symbol Ann a -> Bool
 noYieldsError s ex = not $ yieldsError s ex
 
-yieldsError :: forall v a. Var v => String -> ErrorExtractor v Ann a -> Bool
+yieldsError :: forall a. String -> ErrorExtractor Symbol Ann a -> Bool
 yieldsError s ex = let
   Result notes (Just _) = Common.parseAndSynthesizeAsFile [] "> test" s
-  notes' :: [C.ErrorNote v Ann]
+  notes' :: [C.ErrorNote Symbol Ann]
   notes' = [ n | Result.TypeError n <- toList notes ]
   in any (isJust . Ex.extract ex) notes'

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

@@ -61,7 +61,7 @@ bad r = EasyTest.expectLeft r >> done
 
 test :: Test ()
 test = do
-  rt <- io (RTI.startRuntime "")
+  rt <- io (RTI.startRuntime RTI.Standalone "")
   scope "unison-src"
     . tests
     $ [ go rt shouldPassNow   good

parser-typechecker/unison-parser-typechecker.cabal

@@ -45,6 +45,7 @@ library
       Unison.Codebase.GitError
       Unison.Codebase.Init
       Unison.Codebase.Init.CreateCodebaseError
+      Unison.Codebase.Init.OpenCodebaseError
       Unison.Codebase.Init.Type
       Unison.Codebase.MainTerm
       Unison.Codebase.Metadata

unison-cli/package.yaml

@@ -42,6 +42,9 @@ dependencies:
 
 library:
   source-dirs: src
+  when:
+    - condition: '!os(windows)'
+      dependencies: unix
 
 tests:
   tests:
@@ -65,9 +68,6 @@ executables:
       - template-haskell
       - temporary
       - unison-cli
-    when:
-      - condition: '!os(windows)'
-        dependencies: unix
 
   transcripts:
     source-dirs: transcripts

unison-cli/src/Compat.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE CPP #-}
+
+module Compat where
+
+import Control.Concurrent (mkWeakThreadId, myThreadId)
+import Control.Exception (AsyncException (UserInterrupt), throwTo)
+import System.Mem.Weak (deRefWeak)
+import Unison.Prelude
+import qualified UnliftIO
+
+#if defined(mingw32_HOST_OS)
+import qualified GHC.ConsoleHandler as WinSig
+#else
+import qualified System.Posix.Signals as Sig
+#endif
+
+-- | Constructs a default interrupt handler which builds an interrupt handler which throws a
+-- UserInterrupt exception to the thread in which the setup was initially called.
+defaultInterruptHandler :: IO (IO ())
+defaultInterruptHandler = do
+  main_thread <- myThreadId
+  wtid <- mkWeakThreadId main_thread
+  let interrupt = do
+        r <- deRefWeak wtid
+        case r of
+          Nothing -> return ()
+          Just t -> throwTo t UserInterrupt
+  pure interrupt
+
+-- | Replaces any existing interrupt handlers with the provided IO action while the provided
+-- action is running, restoring any existing handlers afterwards.
+withInterruptHandler :: IO () -> IO a -> IO a
+withInterruptHandler handler action = do
+  UnliftIO.bracket
+    installNewHandlers
+    restoreOldHandlers
+    (\_ -> action)
+  where
+    -- Installs the new handler and returns an action to restore the old handlers.
+    installNewHandlers :: IO (IO ())
+    installNewHandlers = do
+#if defined(mingw32_HOST_OS)
+      let sig_handler WinSig.ControlC = handler
+          sig_handler WinSig.Break    = handler
+          sig_handler _               = return ()
+      oldHandler <- WinSig.installHandler (WinSig.Catch sig_handler)
+      pure (void $ WinSig.installHandler oldHandler)
+#else
+      oldQuitHandler <- Sig.installHandler Sig.sigQUIT  (Sig.Catch handler) Nothing
+      oldInterruptHandler <- Sig.installHandler Sig.sigINT   (Sig.Catch handler) Nothing
+      pure do
+        void $ Sig.installHandler Sig.sigQUIT oldQuitHandler Nothing
+        void $ Sig.installHandler Sig.sigINT oldInterruptHandler Nothing
+#endif
+    restoreOldHandlers :: IO () -> IO ()
+    restoreOldHandlers restore = restore

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

@@ -96,6 +96,8 @@ data Command
 
   UI :: Command m i v ()
 
+  API :: Command m i v ()
+
   DocsToHtml
     :: Branch m -- Root branch
     -> Path -- ^ namespace source
@@ -298,6 +300,7 @@ lookupEvalResult v (_, m) = view _5 <$> Map.lookup v m
 commandName :: Command m i v a -> String
 commandName = \case
   Eval {} -> "Eval"
+  API -> "API"
   UI -> "UI"
   DocsToHtml {} -> "DocsToHtml"
   ConfigLookup {} -> "ConfigLookup"

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

@@ -25,7 +25,7 @@ import qualified Unison.Codebase.Branch as Branch
 import qualified Unison.Codebase.Branch.Merge as Branch
 import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo
 import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache)
-import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
+import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage))
 import Unison.Codebase.Runtime (Runtime)
 import qualified Unison.Codebase.Runtime as Runtime
 import Unison.FileParsers (parseAndSynthesizeFile, synthesizeFile')
@@ -45,7 +45,7 @@ import Unison.Type (Type)
 import qualified Unison.UnisonFile as UF
 import Unison.Util.Free (Free)
 import qualified Unison.Util.Free as Free
-import Unison.Var (Var)
+import qualified Unison.Util.Pretty as P
 import qualified Unison.WatchKind as WK
 import Web.Browser (openBrowser)
 import System.Environment (withArgs)
@@ -54,15 +54,16 @@ import qualified Unison.Codebase.Path as Path
 import Control.Monad.Reader (ReaderT (runReaderT), ask)
 import qualified Control.Concurrent.STM as STM
 import qualified UnliftIO
+import Unison.Symbol (Symbol)
 
 typecheck
-  :: (Monad m, Var v)
-  => [Type v Ann]
-  -> Codebase m v Ann
+  :: Monad m
+  => [Type Symbol Ann]
+  -> Codebase m Symbol Ann
   -> Parser.ParsingEnv
   -> SourceName
   -> LexedSource
-  -> m (TypecheckingResult v)
+  -> m (TypecheckingResult Symbol)
 typecheck ambient codebase parsingEnv sourceName src =
   Result.getResult $ parseAndSynthesizeFile ambient
     (((<> B.typeLookup) <$>) . Codebase.typeLookupForDependencies codebase)
@@ -72,39 +73,46 @@ typecheck ambient codebase parsingEnv sourceName src =
 
 typecheck'
   :: Monad m
-  => Var v
-  => [Type v Ann]
-  -> Codebase m v Ann
-  -> UF.UnisonFile v Ann
-  -> m (TypecheckingResult v)
+  => [Type Symbol Ann]
+  -> Codebase m Symbol Ann
+  -> UF.UnisonFile Symbol Ann
+  -> m (TypecheckingResult Symbol)
 typecheck' ambient codebase file = do
   typeLookup <- (<> B.typeLookup)
     <$> Codebase.typeLookupForDependencies codebase (UF.dependencies file)
   pure . fmap Right $ synthesizeFile' ambient typeLookup file
 
 commandLine
-  :: forall i v a gen
-   . (Var v, Random.DRG gen)
+  :: forall i a gen
+   . Random.DRG gen
   => Config
   -> IO i
   -> (Branch IO -> IO ())
-  -> Runtime v
-  -> (Output v -> IO ())
-  -> (NumberedOutput v -> IO NumberedArgs)
+  -> Runtime Symbol
+  -> (Output Symbol -> IO ())
+  -> (NumberedOutput Symbol -> IO NumberedArgs)
   -> (SourceName -> IO LoadSourceResult)
-  -> Codebase IO v Ann
+  -> Codebase IO Symbol Ann
   -> Maybe Server.BaseUrl
   -> (Int -> IO gen)
-  -> Free (Command IO i v) a
+  -> Free (Command IO i Symbol) a
   -> IO a
 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 -> ReaderT (STM.TVar Int) IO x
+  go :: forall x . Command IO i Symbol 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
+    API           -> lift $ forM_ serverBaseUrl $ \baseUrl ->
+      notifyUser $ PrintMessage $ P.lines
+        ["The API information is as follows:" 
+        , P.newline
+        , P.indentN 2 (P.hiBlue ("UI: " <> fromString (Server.urlFor Server.UI baseUrl)))
+        , P.newline
+        , P.indentN 2 (P.hiBlue ("API: " <> fromString (Server.urlFor Server.Api baseUrl)))
+        ]
     UI            ->
       case serverBaseUrl of
         Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url)
@@ -213,7 +221,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
       -- 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))
+      let runF :: UnliftIO.UnliftIO (Free (Command IO i Symbol))
           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
@@ -221,12 +229,12 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
                    UnliftIO.UnliftIO toIO -> toIO . Free.fold go
       pure runF
 
-  watchCache :: Reference.Id -> IO (Maybe (Term v ()))
+  watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
   watchCache h = do
     maybeTerm <- Codebase.lookupWatchCache codebase h
     pure (Term.amap (const ()) <$> maybeTerm)
 
-  eval1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> _
+  eval1 :: PPE.PrettyPrintEnv -> UseCache -> Term Symbol Ann -> _
   eval1 ppe useCache tm = do
     let codeLookup = Codebase.toCodeLookup codebase
         cache = if useCache then watchCache else Runtime.noCache
@@ -237,7 +245,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
       Left _ -> pure ()
     pure $ r <&> Term.amap (const Ann.External)
 
-  evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> [String] -> _
+  evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile Symbol Ann -> [String] -> _
   evalUnisonFile ppe unisonFile args = withArgs args do
     let codeLookup = Codebase.toCodeLookup codebase
     r <- Runtime.evaluateWatches codeLookup ppe watchCache rt unisonFile

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

@@ -149,6 +149,7 @@ import Unison.Util.Free (Free)
 import UnliftIO (MonadUnliftIO)
 import qualified Data.Set.NonEmpty as NESet
 import Data.Set.NonEmpty (NESet)
+import Unison.Symbol (Symbol)
 import qualified Unison.Codebase.Editor.Input as Input
 
 defaultPatchNameSegment :: NameSegment
@@ -164,7 +165,7 @@ currentPrettyPrintEnvDecl = do
   currentPath' <- Path.unabsolute <$> use LoopState.currentPath
   prettyPrintEnvDecl (Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root')
 
-loop :: forall m v. (MonadUnliftIO m, Var v) => Action m (Either Event Input) v ()
+loop :: forall m. MonadUnliftIO m => Action m (Either Event Input) Symbol ()
 loop = do
   uf <- use LoopState.latestTypecheckedFile
   root' <- use LoopState.root
@@ -308,6 +309,11 @@ loop = do
             [r | SR.Tm (SR.TermResult _ (Referent.Ref r) _) <- rs]
           termResults rs = [r | SR.Tm r <- rs]
           typeResults rs = [r | SR.Tp r <- rs]
+          doRemoveReplacement ::
+               HQ.HashQualified Name
+            -> Maybe PatchPath
+            -> Bool
+            -> Action' m Symbol ()
           doRemoveReplacement from patchPath isTerm = do
             let patchPath' = fromMaybe defaultPatchPath patchPath
             patch <- getPatchAt patchPath'
@@ -320,7 +326,7 @@ loop = do
                     if isTerm
                       then Set.fromList $ SR.termName <$> termResults hits
                       else Set.fromList $ SR.typeName <$> typeResults hits
-                go :: Reference -> Action m (Either Event Input) v ()
+                go :: Reference -> Action m (Either Event Input) Symbol ()
                 go fr = do
                   let termPatch =
                         over Patch.termEdits (R.deleteDom fr) patch
@@ -328,7 +334,7 @@ loop = do
                         over Patch.typeEdits (R.deleteDom fr) patch
                       (patchPath'', patchName) = resolveSplit' patchPath'
                   -- Save the modified patch
-                  stepAtM
+                  stepAtM Branch.CompressHistory
                     inputDescription
                     ( patchPath'',
                       Branch.modifyPatches
@@ -340,8 +346,6 @@ loop = do
             unless (Set.null misses) $
               respond $ SearchTermsNotFound (Set.toList misses)
             traverse_ go (if isTerm then tmRefs else tpRefs)
-          branchExists dest _x = respond $ BranchAlreadyExists dest
-          branchExistsSplit = branchExists . Path.unsplit'
           typeExists dest = respond . TypeAlreadyExists dest
           termExists dest = respond . TermAlreadyExists dest
           inputDescription :: LoopState.InputDescription
@@ -377,6 +381,7 @@ loop = do
             UpdateI p _selection -> "update " <> opatch p
             PropagatePatchI p scope -> "patch " <> ps' p <> " " <> p' scope
             UndoI {} -> "undo"
+            ApiI -> "api"
             UiI -> "ui"
             DocsToHtmlI path dir -> "docs.to-html " <> Path.toText' path <> " " <> Text.pack dir
             ExecuteI s args -> "execute " <> (Text.unwords . fmap Text.pack $ (s : args))
@@ -469,13 +474,17 @@ loop = do
           stepManyAt = Unison.Codebase.Editor.HandleInput.stepManyAt inputDescription
           updateRoot = flip Unison.Codebase.Editor.HandleInput.updateRoot inputDescription
           syncRoot = use LoopState.root >>= updateRoot
+          updateAtM ::
+            Path.Absolute
+            -> (Branch m -> Action m i v1 (Branch m))
+            -> Action m i v1 Bool
           updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription
           unlessGitError = unlessError' Output.GitError
           importRemoteBranch ns mode preprocess =
             ExceptT . eval $ ImportRemoteBranch ns mode preprocess
           loadSearchResults = eval . LoadSearchResults
           saveAndApplyPatch patchPath'' patchName patch' = do
-            stepAtM
+            stepAtM Branch.CompressHistory
               (inputDescription <> " (1/2)")
               ( patchPath'',
                 Branch.modifyPatches patchName (const patch')
@@ -516,7 +525,7 @@ loop = do
                   then do
                     let makeDeleteTermNames = fmap (BranchUtil.makeDeleteTermName resolvedPath) . toList $ tms
                     let makeDeleteTypeNames = fmap (BranchUtil.makeDeleteTypeName resolvedPath) . toList $ tys
-                    stepManyAt (makeDeleteTermNames ++ makeDeleteTypeNames)
+                    stepManyAt Branch.CompressHistory (makeDeleteTermNames ++ makeDeleteTypeNames)
                     root'' <- use LoopState.root
                     diffHelper (Branch.head root') (Branch.head root'')
                       >>= respondNumbered . uncurry ShowDiffAfterDeleteDefinitions
@@ -524,6 +533,7 @@ loop = do
                     ppeDecl <- currentPrettyPrintEnvDecl
                     respondNumbered $ CantDeleteDefinitions ppeDecl endangerments
        in case input of
+            ApiI -> eval API
             CreateMessage pretty ->
               respond $ PrintMessage pretty
             ShowReflogI -> do
@@ -646,7 +656,7 @@ loop = do
                   lift $ do
                     mergedb <- eval $ Merge Branch.RegularMerge baseb headb
                     squashedb <- eval $ Merge Branch.SquashMerge headb baseb
-                    stepManyAt
+                    stepManyAt Branch.AllowRewritingHistory
                       [ BranchUtil.makeSetBranch (dest, "base") baseb,
                         BranchUtil.makeSetBranch (dest, "head") headb,
                         BranchUtil.makeSetBranch (dest, "merged") mergedb,
@@ -666,21 +676,29 @@ loop = do
             -- move the LoopState.root to a sub-branch
             MoveBranchI Nothing dest -> do
               b <- use LoopState.root
-              stepManyAt
+              -- Overwrite history at destination.
+              stepManyAt Branch.AllowRewritingHistory
                 [ (Path.empty, const Branch.empty0),
                   BranchUtil.makeSetBranch (resolveSplit' dest) b
                 ]
               success
-            MoveBranchI (Just src) dest ->
-              maybe (branchNotFound' src) srcOk (getAtSplit' src)
-              where
-                srcOk b = maybe (destOk b) (branchExistsSplit dest) (getAtSplit' dest)
-                destOk b = do
-                  stepManyAt
-                    [ BranchUtil.makeDeleteBranch (resolveSplit' src),
-                      BranchUtil.makeSetBranch (resolveSplit' dest) b
-                    ]
-                  success -- could give rando stats about new defns
+            MoveBranchI (Just src) dest -> unlessError $ do
+              srcBranch <- case getAtSplit' src of
+                Just existingSrc | not (Branch.isEmpty0 (Branch.head existingSrc)) -> do
+                  pure existingSrc
+                _ -> throwError $ BranchNotFound (Path.unsplit' src)
+              case getAtSplit' dest of
+                Just existingDest
+                  | not (Branch.isEmpty0 (Branch.head existingDest)) -> do
+                    -- Branch exists and isn't empty, print an error
+                    throwError (BranchAlreadyExists (Path.unsplit' dest))
+                _ -> pure ()
+              -- allow rewriting history to ensure we move the branch's history too.
+              lift $ stepManyAt Branch.AllowRewritingHistory
+                [ BranchUtil.makeDeleteBranch (resolveSplit' src),
+                  BranchUtil.makeSetBranch (resolveSplit' dest) srcBranch
+                ]
+              lift $ success -- could give rando stats about new defns
             MovePatchI src dest -> do
               psrc <- getPatchAtSplit' src
               pdest <- getPatchAtSplit' dest
@@ -689,6 +707,7 @@ loop = do
                 (_, Just _) -> patchExists dest
                 (Just p, Nothing) -> do
                   stepManyAt
+                    Branch.CompressHistory
                     [ BranchUtil.makeDeletePatch (resolveSplit' src),
                       BranchUtil.makeReplacePatch (resolveSplit' dest) p
                     ]
@@ -700,19 +719,25 @@ loop = do
                 (Nothing, _) -> patchNotFound src
                 (_, Just _) -> patchExists dest
                 (Just p, Nothing) -> do
-                  stepAt (BranchUtil.makeReplacePatch (resolveSplit' dest) p)
+                  stepAt
+                    Branch.CompressHistory
+                    (BranchUtil.makeReplacePatch (resolveSplit' dest) p)
                   success
             DeletePatchI src -> do
               psrc <- getPatchAtSplit' src
               case psrc of
                 Nothing -> patchNotFound src
                 Just _ -> do
-                  stepAt (BranchUtil.makeDeletePatch (resolveSplit' src))
+                  stepAt
+                    Branch.CompressHistory
+                    (BranchUtil.makeDeletePatch (resolveSplit' src))
                   success
             DeleteBranchI insistence Nothing -> do
               hasConfirmed <- confirmedCommand input
               if (hasConfirmed || insistence == Force)
-                then do stepAt (Path.empty, const Branch.empty0)
+                then do stepAt
+                          Branch.CompressHistory  -- Wipe out all definitions, but keep root branch history.
+                          (Path.empty, const Branch.empty0)
                         respond DeletedEverything
                 else respond DeleteEverythingConfirmation
             DeleteBranchI insistence (Just p) -> do
@@ -732,7 +757,7 @@ loop = do
                          respondNumbered $ CantDeleteNamespace ppeDecl endangerments
               where
                 doDelete b0 = do
-                      stepAt $ BranchUtil.makeSetBranch (resolveSplit' p) Branch.empty
+                      stepAt Branch.CompressHistory $ BranchUtil.makeDeleteBranch (resolveSplit' p)
                       -- Looks similar to the 'toDelete' above... investigate me! ;)
                       diffHelper b0 Branch.empty0
                         >>= respondNumbered
@@ -815,7 +840,7 @@ loop = do
               referents <- resolveHHQS'Referents src
               case (toList referents, toList (getTerms dest)) of
                 ([r], []) -> do
-                  stepAt (BranchUtil.makeAddTermName (resolveSplit' dest) r (oldMD r))
+                  stepAt Branch.CompressHistory (BranchUtil.makeAddTermName (resolveSplit' dest) r (oldMD r))
                   success
                 ([_], rs@(_ : _)) -> termExists dest (Set.fromList rs)
                 ([], _) -> either termNotFound' termNotFound src
@@ -834,7 +859,7 @@ loop = do
               refs <- resolveHHQS'Types src
               case (toList refs, toList (getTypes dest)) of
                 ([r], []) -> do
-                  stepAt (BranchUtil.makeAddTypeName (resolveSplit' dest) r (oldMD r))
+                  stepAt Branch.CompressHistory (BranchUtil.makeAddTypeName (resolveSplit' dest) r (oldMD r))
                   success
                 ([_], rs@(_ : _)) -> typeExists dest (Set.fromList rs)
                 ([], _) -> either typeNotFound' typeNotFound src
@@ -860,7 +885,7 @@ loop = do
               let destAbs = resolveToAbsolute dest'
               old <- getAt destAbs
               let (unknown, actions) = foldl' go mempty srcs
-              stepManyAt actions
+              stepManyAt Branch.CompressHistory actions
               new <- getAt destAbs
               diffHelper (Branch.head old) (Branch.head new)
                 >>= respondNumbered . uncurry (ShowDiffAfterModifyBranch dest' destAbs)
@@ -963,7 +988,7 @@ loop = do
                 eval $ CreateAuthorInfo authorFullName
               -- add the new definitions to the codebase and to the namespace
               traverse_ (eval . uncurry3 PutTerm) [guid, author, copyrightHolder]
-              stepManyAt
+              stepManyAt Branch.CompressHistory
                 [ BranchUtil.makeAddTermName (resolveSplit' authorPath) (d authorRef) mempty,
                   BranchUtil.makeAddTermName (resolveSplit' copyrightHolderPath) (d copyrightHolderRef) mempty,
                   BranchUtil.makeAddTermName (resolveSplit' guidPath) (d guidRef) mempty
@@ -988,7 +1013,7 @@ loop = do
             MoveTermI src dest ->
               case (toList (getHQ'Terms src), toList (getTerms dest)) of
                 ([r], []) -> do
-                  stepManyAt
+                  stepManyAt Branch.CompressHistory
                     [ BranchUtil.makeDeleteTermName p r,
                       BranchUtil.makeAddTermName (resolveSplit' dest) r (mdSrc r)
                     ]
@@ -1002,7 +1027,7 @@ loop = do
             MoveTypeI src dest ->
               case (toList (getHQ'Types src), toList (getTypes dest)) of
                 ([r], []) -> do
-                  stepManyAt
+                  stepManyAt Branch.CompressHistory
                     [ BranchUtil.makeDeleteTypeName p r,
                       BranchUtil.makeAddTypeName (resolveSplit' dest) r (mdSrc r)
                     ]
@@ -1108,7 +1133,7 @@ loop = do
                 conflicted = getHQ'Types (fmap HQ'.toNameOnly hq)
                 makeDelete =
                   BranchUtil.makeDeleteTypeName (resolveSplit' (HQ'.toName <$> hq))
-                go r = stepManyAt . fmap makeDelete . toList . Set.delete r $ conflicted
+                go r = stepManyAt Branch.CompressHistory . fmap makeDelete . toList . Set.delete r $ conflicted
             ResolveTermNameI hq -> do
               refs <- getHQ'TermsIncludingHistorical hq
               zeroOneOrMore refs (termNotFound hq) go (termConflicted hq)
@@ -1116,7 +1141,7 @@ loop = do
                 conflicted = getHQ'Terms (fmap HQ'.toNameOnly hq)
                 makeDelete =
                   BranchUtil.makeDeleteTermName (resolveSplit' (HQ'.toName <$> hq))
-                go r = stepManyAt . fmap makeDelete . toList . Set.delete r $ conflicted
+                go r = stepManyAt Branch.CompressHistory . fmap makeDelete . toList . Set.delete r $ conflicted
             ReplaceI from to patchPath -> do
               let patchPath' = fromMaybe defaultPatchPath patchPath
               patch <- getPatchAt patchPath'
@@ -1155,7 +1180,7 @@ loop = do
                   replaceTerms ::
                     Reference ->
                     Reference ->
-                    Action m (Either Event Input) v ()
+                    Action m (Either Event Input) Symbol ()
                   replaceTerms fr tr = do
                     mft <- eval $ LoadTypeOfTerm fr
                     mtt <- eval $ LoadTypeOfTerm tr
@@ -1181,7 +1206,7 @@ loop = do
                   replaceTypes ::
                     Reference ->
                     Reference ->
-                    Action m (Either Event Input) v ()
+                    Action m (Either Event Input) Symbol ()
                   replaceTypes fr tr = do
                     let patch' =
                           -- The modified patch
@@ -1237,7 +1262,7 @@ loop = do
                       . toSlurpResult currentPath' uf
                       <$> slurpResultNames
                   let adds = Slurp.adds sr
-                  stepAtNoSync (Path.unabsolute currentPath', doSlurpAdds adds uf)
+                  stepAtNoSync Branch.CompressHistory (Path.unabsolute currentPath', doSlurpAdds adds uf)
                   eval . AddDefsToCodebase . filterBySlurpResult sr $ uf
                   ppe <- prettyPrintEnvDecl =<< displayNames uf
                   respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
@@ -1436,7 +1461,7 @@ loop = do
               -- due to builtin terms; so we don't just reuse `uf` above.
               let names0 =
                     Builtin.names0
-                      <> UF.typecheckedToNames @v IOSource.typecheckedFile'
+                      <> UF.typecheckedToNames IOSource.typecheckedFile'
               let srcb = BranchUtil.fromNames names0
               _ <- updateAtM (currentPath' `snoc` "builtin") $ \destb ->
                 eval $ Merge Branch.RegularMerge srcb destb
@@ -1464,13 +1489,18 @@ loop = do
                 let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path
                 lift $ case pullMode of
                   Input.PullWithHistory -> do
-                    mergeBranchAndPropagateDefaultPatch
-                      Branch.RegularMerge
-                      inputDescription
-                      (Just unchangedMsg)
-                      remoteBranch
-                      printDiffPath
-                      destAbs
+                    destBranch <- getAt destAbs
+                    if Branch.isEmpty0 (Branch.head destBranch)
+                       then do
+                         void $ updateAtM destAbs (const $ pure remoteBranch)
+                         respond $ MergeOverEmpty path
+                       else mergeBranchAndPropagateDefaultPatch
+                              Branch.RegularMerge
+                              inputDescription
+                              (Just unchangedMsg)
+                              remoteBranch
+                              printDiffPath
+                              destAbs
                   Input.PullWithoutHistory -> do
                     didUpdate <- updateAtM
                                    destAbs
@@ -1894,7 +1924,7 @@ handleUpdate input maybePatchPath hqs = do
       when (Slurp.isNonempty sr) $ do
         -- take a look at the `updates` from the SlurpResult
         -- and make a patch diff to record a replacement from the old to new references
-        stepManyAtMNoSync
+        stepManyAtMNoSync Branch.CompressHistory
           [ ( Path.unabsolute currentPath',
               pure . doSlurpUpdates typeEdits termEdits termDeprecations
             ),
@@ -2023,7 +2053,7 @@ manageLinks silent srcs mdValues op = do
                     go types src = op (src, mdType, mdValue) types
               in over Branch.terms tmUpdates . over Branch.types tyUpdates $ b0
           steps = srcs <&> \(path, _hq) -> (Path.unabsolute (resolveToAbsolute path), step)
-      stepManyAtNoSync steps
+      stepManyAtNoSync Branch.CompressHistory steps
 
 -- Takes a maybe (namespace address triple); returns it as-is if `Just`;
 -- otherwise, tries to load a value from .unisonConfig, and complains
@@ -2084,7 +2114,7 @@ resolveHQToLabeledDependencies = \case
       types <- eval $ TypeReferencesByShortHash sh
       pure $ Set.map LD.referent terms <> Set.map LD.typeRef types
 
-doDisplay :: Var v => OutputLocation -> NamesWithHistory -> Term v () -> Action' m v ()
+doDisplay :: OutputLocation -> NamesWithHistory -> Term Symbol () -> Action' m Symbol ()
 doDisplay outputLoc names tm = do
   ppe <- prettyPrintEnvDecl names
   tf <- use LoopState.latestTypecheckedFile
@@ -2186,7 +2216,7 @@ propagatePatchNoSync ::
 propagatePatchNoSync patch scopePath = do
   r <- use LoopState.root
   let nroot = Branch.toNames (Branch.head r)
-  stepAtMNoSync'
+  stepAtMNoSync' Branch.CompressHistory
     ( Path.unabsolute scopePath,
       lift . lift . Propagate.propagateAndApply nroot patch
     )
@@ -2201,7 +2231,7 @@ propagatePatch ::
 propagatePatch inputDescription patch scopePath = do
   r <- use LoopState.root
   let nroot = Branch.toNames (Branch.head r)
-  stepAtM'
+  stepAtM' Branch.CompressHistory
     (inputDescription <> " (applying patch)")
     ( Path.unabsolute scopePath,
       lift . lift . Propagate.propagateAndApply nroot patch
@@ -2551,97 +2581,108 @@ stepAt ::
   forall m i v.
   Monad m =>
   LoopState.InputDescription ->
+  Branch.UpdateStrategy ->
   (Path, Branch0 m -> Branch0 m) ->
   Action m i v ()
-stepAt cause = stepManyAt @m @[] cause . pure
+stepAt cause strat = stepManyAt @m @[] cause strat . pure
 
 stepAtNoSync ::
   forall m i v.
   Monad m =>
+  Branch.UpdateStrategy ->
   (Path, Branch0 m -> Branch0 m) ->
   Action m i v ()
-stepAtNoSync = stepManyAtNoSync @m @[] . pure
+stepAtNoSync strat = stepManyAtNoSync @m @[] strat . pure
 
 stepAtM ::
   forall m i v.
   Monad m =>
+  Branch.UpdateStrategy ->
   LoopState.InputDescription ->
   (Path, Branch0 m -> m (Branch0 m)) ->
   Action m i v ()
-stepAtM cause = stepManyAtM @m @[] cause . pure
+stepAtM cause strat = stepManyAtM @m @[] cause strat . pure
 
 stepAtM' ::
   forall m i v.
   Monad m =>
+  Branch.UpdateStrategy ->
   LoopState.InputDescription ->
   (Path, Branch0 m -> Action m i v (Branch0 m)) ->
   Action m i v Bool
-stepAtM' cause = stepManyAtM' @m @[] cause . pure
+stepAtM' cause strat = stepManyAtM' @m @[] cause strat . pure
 
 stepAtMNoSync' ::
   forall m i v.
   Monad m =>
+  Branch.UpdateStrategy ->
   (Path, Branch0 m -> Action m i v (Branch0 m)) ->
   Action m i v Bool
-stepAtMNoSync' = stepManyAtMNoSync' @m @[] . pure
+stepAtMNoSync' strat = stepManyAtMNoSync' @m @[] strat . pure
 
 stepManyAt ::
   (Monad m, Foldable f) =>
   LoopState.InputDescription ->
+  Branch.UpdateStrategy ->
   f (Path, Branch0 m -> Branch0 m) ->
   Action m i v ()
-stepManyAt reason actions = do
-  stepManyAtNoSync actions
+stepManyAt reason strat actions = do
+  stepManyAtNoSync strat actions
   b <- use LoopState.root
   updateRoot b reason
 
 -- Like stepManyAt, but doesn't update the LoopState.root
 stepManyAtNoSync ::
   (Monad m, Foldable f) =>
+  Branch.UpdateStrategy ->
   f (Path, Branch0 m -> Branch0 m) ->
   Action m i v ()
-stepManyAtNoSync actions = do
+stepManyAtNoSync strat actions = do
   b <- use LoopState.root
-  let new = Branch.stepManyAt actions b
+  let new = Branch.stepManyAt strat actions b
   LoopState.root .= new
 
 stepManyAtM ::
   (Monad m, Foldable f) =>
+  Branch.UpdateStrategy ->
   LoopState.InputDescription ->
   f (Path, Branch0 m -> m (Branch0 m)) ->
   Action m i v ()
-stepManyAtM reason actions = do
-  stepManyAtMNoSync actions
+stepManyAtM strat reason actions = do
+  stepManyAtMNoSync strat actions
   b <- use LoopState.root
   updateRoot b reason
 
 stepManyAtMNoSync ::
   (Monad m, Foldable f) =>
+  Branch.UpdateStrategy ->
   f (Path, Branch0 m -> m (Branch0 m)) ->
   Action m i v ()
-stepManyAtMNoSync actions = do
+stepManyAtMNoSync strat actions = do
   b <- use LoopState.root
-  b' <- eval . Eval $ Branch.stepManyAtM actions b
+  b' <- eval . Eval $ Branch.stepManyAtM strat actions b
   LoopState.root .= b'
 
 stepManyAtM' ::
   (Monad m, Foldable f) =>
+  Branch.UpdateStrategy ->
   LoopState.InputDescription ->
   f (Path, Branch0 m -> Action m i v (Branch0 m)) ->
   Action m i v Bool
-stepManyAtM' reason actions = do
+stepManyAtM' strat reason actions = do
   b <- use LoopState.root
-  b' <- Branch.stepManyAtM actions b
+  b' <- Branch.stepManyAtM strat actions b
   updateRoot b' reason
   pure (b /= b')
 
 stepManyAtMNoSync' ::
   (Monad m, Foldable f) =>
+  Branch.UpdateStrategy ->
   f (Path, Branch0 m -> Action m i v (Branch0 m)) ->
   Action m i v Bool
-stepManyAtMNoSync' actions = do
+stepManyAtMNoSync' strat actions = do
   b <- use LoopState.root
-  b' <- Branch.stepManyAtM actions b
+  b' <- Branch.stepManyAtM strat actions b
   LoopState.root .= b'
   pure (b /= b')
 
@@ -2899,11 +2940,11 @@ toSlurpResult curPath uf existingNames =
             go (n, _) = (not . R.memberDom n) existingNames
 
 displayI ::
-  (Monad m, Var v) =>
+  Monad m =>
   Names ->
   OutputLocation ->
   HQ.HashQualified Name ->
-  Action m (Either Event Input) v ()
+  Action m (Either Event Input) Symbol ()
 displayI prettyPrintNames outputLoc hq = do
   uf <- use LoopState.latestTypecheckedFile >>= addWatch (HQ.toString hq)
   case uf of
@@ -2934,11 +2975,11 @@ displayI prettyPrintNames outputLoc hq = do
             doDisplay outputLoc ns tm
 
 docsI ::
-  (Ord v, Monad m, Var v) =>
+  Monad m =>
   SrcLoc ->
   Names ->
   Path.HQSplit' ->
-  Action m (Either Event Input) v ()
+  Action m (Either Event Input) Symbol ()
 docsI srcLoc prettyPrintNames src = do
   fileByName
   where

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

@@ -170,6 +170,7 @@ data Input
     | DebugDumpNamespaceSimpleI
     | DebugClearWatchI
     | QuitI
+    | ApiI
     | UiI
     | DocsToHtmlI Path' FilePath
     | GistI GistInput

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

@@ -212,6 +212,8 @@ data Output v
   | ShowReflog [ReflogEntry]
   | PullAlreadyUpToDate ReadRemoteNamespace Path'
   | PullSuccessful ReadRemoteNamespace Path'
+    -- | Indicates a trivial merge where the destination was empty and was just replaced.
+  | MergeOverEmpty Path'
   | MergeAlreadyUpToDate Path' Path'
   | PreviewMergeAlreadyUpToDate Path' Path'
   | -- | No conflicts or edits remain for the current patch.
@@ -346,6 +348,7 @@ isFailure o = case o of
   NoBranchWithHash {} -> True
   PullAlreadyUpToDate {} -> False
   PullSuccessful {} -> False
+  MergeOverEmpty {} -> False
   MergeAlreadyUpToDate {} -> False
   PreviewMergeAlreadyUpToDate {} -> False
   NoConflictsOrEdits {} -> False

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

@@ -652,5 +652,8 @@ computeFrontier getDependents patch names = do
     -> m (R.Relation Reference Reference)
   addDependents dependents ref =
     (\ds -> R.insertManyDom ds ref dependents)
-      .   Set.filter (Names.contains names)
+      .   Set.filter isNamed
       <$> getDependents ref
+  isNamed :: Reference -> Bool
+  isNamed =
+    Names.contains names

unison-cli/src/Unison/Codebase/TranscriptParser.hs

@@ -146,7 +146,7 @@ run version dir configFile stanzas codebase = do
     (config, cancelConfig)   <-
       catchIOError (watchConfig configFile) $ \_ ->
         die "Your .unisonConfig could not be loaded. Check that it's correct!"
-    runtime                  <- RTI.startRuntime version
+    runtime                  <- RTI.startRuntime RTI.Standalone version
     traverse_ (atomically . Q.enqueue inputQueue) (stanzas `zip` [1..])
     let patternMap =
           Map.fromList

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

@@ -11,6 +11,7 @@ import Control.Lens ((^.))
 import Unison.ConstructorReference (GConstructorReference(..))
 import Unison.Reference (Reference)
 import Unison.Referent (Referent)
+import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Var (Var)
@@ -40,13 +41,13 @@ import qualified Unison.Builtin as Builtin
 
 type Pretty = P.Pretty P.ColorText
 
-displayTerm :: (Var v, Monad m)
+displayTerm :: Monad m
            => PPE.PrettyPrintEnvDecl
-           -> (Reference -> m (Maybe (Term v ())))
-           -> (Referent -> m (Maybe (Type v ())))
-           -> (Term v () -> m (Maybe (Term v ())))
-           -> (Reference -> m (Maybe (DD.Decl v ())))
-           -> Term v ()
+           -> (Reference -> m (Maybe (Term Symbol ())))
+           -> (Referent -> m (Maybe (Type Symbol ())))
+           -> (Term Symbol () -> m (Maybe (Term Symbol ())))
+           -> (Reference -> m (Maybe (DD.Decl Symbol ())))
+           -> Term Symbol ()
            -> m Pretty
 displayTerm = displayTerm' False
 
@@ -62,14 +63,14 @@ displayTerm = displayTerm' False
 --
 type ElideUnit = Bool
 
-displayTerm' :: (Var v, Monad m)
+displayTerm' :: Monad m
            => ElideUnit
            -> PPE.PrettyPrintEnvDecl
-           -> (Reference -> m (Maybe (Term v ())))
-           -> (Referent -> m (Maybe (Type v ())))
-           -> (Term v () -> m (Maybe (Term v ())))
-           -> (Reference -> m (Maybe (DD.Decl v ())))
-           -> Term v ()
+           -> (Reference -> m (Maybe (Term Symbol ())))
+           -> (Referent -> m (Maybe (Type Symbol ())))
+           -> (Term Symbol () -> m (Maybe (Term Symbol ())))
+           -> (Reference -> m (Maybe (DD.Decl Symbol ())))
+           -> Term Symbol ()
            -> m Pretty
 displayTerm' elideUnit pped terms typeOf eval types = \case
   tm@(Term.Apps' (Term.Constructor' (ConstructorReference typ _)) _)
@@ -99,13 +100,13 @@ displayTerm' elideUnit pped terms typeOf eval types = \case
 
 -- assume this is given a
 -- Pretty.Annotated ann (Either SpecialForm ConsoleText)
-displayPretty :: forall v m . (Var v, Monad m)
+displayPretty :: forall m . Monad m
               => PPE.PrettyPrintEnvDecl
-              -> (Reference -> m (Maybe (Term v ())))
-              -> (Referent  -> m (Maybe (Type v ())))
-              -> (Term v () -> m (Maybe (Term v ())))
-              -> (Reference -> m (Maybe (DD.Decl v ())))
-              -> Term v ()
+              -> (Reference -> m (Maybe (Term Symbol ())))
+              -> (Referent  -> m (Maybe (Type Symbol ())))
+              -> (Term Symbol () -> m (Maybe (Term Symbol ())))
+              -> (Reference -> m (Maybe (DD.Decl Symbol ())))
+              -> Term Symbol ()
               -> m Pretty
 displayPretty pped terms typeOf eval types tm = go tm
   where

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

@@ -48,7 +48,6 @@ import qualified Unison.Names as Names
 import Unison.Prelude
 import qualified Unison.Util.ColorText as CT
 import Unison.Util.Monoid (intercalateMap)
-import qualified Unison.Util.Pretty as P
 import qualified Unison.Util.Relation as R
 import qualified Unison.Util.Pretty as P
 
@@ -355,6 +354,15 @@ docs =
     )
     (bimap fromString Input.DocsI . traverse Path.parseHQSplit')
 
+api :: InputPattern
+api =
+  InputPattern
+    "api"
+    []
+    []
+    "`api` provides details about the API."
+    (const $ pure Input.ApiI)
+
 ui :: InputPattern
 ui =
   InputPattern
@@ -1940,6 +1948,7 @@ validInputs =
     view,
     display,
     displayTo,
+    api,
     ui,
     docs,
     docsToHtml,

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

@@ -10,7 +10,7 @@ module Unison.CommandLine.Main
 import Unison.Prelude
 
 import Control.Concurrent.STM (atomically)
-import Control.Exception (finally, catch, AsyncException(UserInterrupt), asyncExceptionFromException)
+import Control.Exception (finally, catch)
 import Control.Monad.State (runStateT)
 import Data.Configurator.Types (Config)
 import Data.IORef
@@ -45,11 +45,12 @@ import qualified Unison.Util.TQueue as Q
 import qualified Unison.CommandLine.Welcome as Welcome
 import Control.Lens (view)
 import Control.Error (rightMay)
-import UnliftIO (catchSyncOrAsync, throwIO, withException)
+import qualified UnliftIO
 import System.IO (hPutStrLn, stderr)
 import Unison.Codebase.Editor.Output (Output)
 import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
 import qualified Unison.Codebase.Editor.HandleInput as HandleInput
+import Compat (withInterruptHandler)
 
 getUserInput
   :: forall m v a
@@ -157,10 +158,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
               (putPrettyNonempty o)
               (putPrettyLnUnpaged o))
 
-    let interruptHandler :: SomeException -> IO (Either Event Input)
-        interruptHandler (asyncExceptionFromException -> Just UserInterrupt) = awaitInput
-        interruptHandler e = hPutStrLn stderr ("Exception: " <> show e) *> throwIO e
-        cleanup = do
+    let cleanup = do
           Runtime.terminate runtime
           cancelConfig
           cancelFileSystemWatch
@@ -168,8 +166,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
         awaitInput :: IO (Either Event Input)
         awaitInput = do
           -- use up buffered input before consulting external events
-          i <- readIORef initialInputsRef
-          (case i of
+          readIORef initialInputsRef >>= \case
             h:t -> writeIORef initialInputsRef t >> pure h
             [] ->
               -- Race the user input and file watch.
@@ -180,30 +177,57 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
                   e
                 x      -> do
                   writeIORef pageOutput True
-                  pure x) `catchSyncOrAsync` interruptHandler
+                  pure x
+    (onInterrupt, waitForInterrupt) <- buildInterruptHandler
+    withInterruptHandler onInterrupt $ do
+      let loop :: LoopState.LoopState IO Symbol -> IO ()
+          loop state = do
+            writeIORef pathRef (view LoopState.currentPath state)
+            let free = runStateT (runMaybeT HandleInput.loop) state
+            let handleCommand = HandleCommand.commandLine config awaitInput
+                                         (writeIORef rootRef)
+                                         runtime
+                                         notify
+                                         (\o -> let (p, args) = notifyNumbered o in
+                                          putPrettyNonempty p $> args)
+                                         loadSourceFile
+                                         codebase
+                                         serverBaseUrl
+                                         (const Random.getSystemDRG)
+                                         free
+            UnliftIO.race waitForInterrupt (try handleCommand) >>= \case
+              -- SIGINT
+              Left () -> do hPutStrLn stderr "\nAborted."
+                            loop state
+              -- Exception during command execution
+              Right (Left e) -> do printException e
+                                   loop state
+              -- Success
+              Right (Right (o, state')) -> do
+                case o of
+                  Nothing -> pure ()
+                  Just () -> do
+                    writeIORef numberedArgsRef (LoopState._numberedArgs state')
+                    loop state'
 
-    let loop :: LoopState.LoopState IO Symbol -> IO ()
-        loop state = do
-          writeIORef pathRef (view LoopState.currentPath state)
-          let free = runStateT (runMaybeT HandleInput.loop) state
-          (o, state') <- HandleCommand.commandLine config awaitInput
-                                       (writeIORef rootRef)
-                                       runtime
-                                       notify
-                                       (\o -> let (p, args) = notifyNumbered o in
-                                        putPrettyNonempty p $> args)
-                                       loadSourceFile
-                                       codebase
-                                       serverBaseUrl
-                                       (const Random.getSystemDRG)
-                                       free
-          case o of
-            Nothing -> pure ()
-            Just () -> do
-              writeIORef numberedArgsRef (LoopState._numberedArgs state')
-              loop state'
-    -- Run the main program loop, always run cleanup,
-    -- If an exception occurred, print it before exiting.
-    (loop (LoopState.loopState0 root initialPath)
-      `withException` \e -> hPutStrLn stderr ("Exception: " <> show (e :: SomeException)))
-      `finally` cleanup
+      -- Run the main program loop, always run cleanup,
+      -- If an exception occurred, print it before exiting.
+      loop (LoopState.loopState0 root initialPath)
+        `finally` cleanup
+  where
+    printException :: SomeException -> IO ()
+    printException e = hPutStrLn stderr ("Encountered Exception: " <> show (e :: SomeException))
+
+
+-- | Installs a posix interrupt handler for catching SIGINT.
+-- This replaces GHC's default sigint handler which throws a UserInterrupt async exception
+-- and kills the entire process.
+--
+-- Returns an IO action which blocks until a ctrl-c is detected. It may be used multiple
+-- times.
+buildInterruptHandler :: IO (IO (), IO ())
+buildInterruptHandler = do
+    ctrlCMarker <- UnliftIO.newEmptyMVar
+    let onInterrupt = void $ UnliftIO.tryPutMVar ctrlCMarker ()
+    let waitForInterrupt =  UnliftIO.takeMVar ctrlCMarker
+    pure $ (onInterrupt,waitForInterrupt)

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

@@ -576,8 +576,10 @@ notifyUser dir o = case o of
       P.group (either P.shown prettyPath' b) <> "is an empty namespace."
   BranchNotEmpty path ->
     pure . P.warnCallout $
-      "I was expecting the namespace " <> prettyPath' path
-        <> " to be empty for this operation, but it isn't."
+      P.lines
+        [ "The current namespace '" <> prettyPath' path <> "' is not empty. `pull-request.load` downloads the PR into the current namespace which would clutter it.",
+          "Please switch to an empty namespace and try again." 
+        ]
   CantUndo reason -> case reason of
     CantUndoPastStart -> pure . P.warnCallout $ "Nothing more to undo."
     CantUndoPastMerge -> pure . P.warnCallout $ "Sorry, I can't undo a merge (not implemented yet)."
@@ -1294,6 +1296,10 @@ notifyUser dir o = case o of
       P.wrap $
         "Successfully updated" <> prettyPath' dest <> "from"
           <> P.group (prettyRemoteNamespace ns <> ".")
+  MergeOverEmpty dest ->
+    pure . P.okCallout $
+      P.wrap $
+        "The destination" <> prettyPath' dest <> "was empty, and was replaced instead of merging."
   MergeAlreadyUpToDate src dest ->
     pure . P.callout "😶" $
       P.wrap $

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

@@ -87,7 +87,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
     when debugTranscriptOutput $ traceM output
     pure output
   case result of
-    Left e -> fail $ P.toANSI 80 e
+    Left e -> fail $ P.toANSI 80 (P.shown e)
     Right x -> pure x
 
 lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a
@@ -95,5 +95,5 @@ lowLevel (Codebase root fmt) action = do
   let cbInit = case fmt of CodebaseFormat2 -> SC.init
   result <- Codebase.Init.withOpenCodebase cbInit "lowLevel" root action
   case result of
-    Left p -> PT.putPrettyLn p *> pure (error "This really should have loaded")
+    Left e -> PT.putPrettyLn (P.shown e) *> pure (error "This really should have loaded")
     Right a -> pure a

unison-cli/transcripts/Transcripts.hs

@@ -1,4 +1,3 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
 {-# LANGUAGE OverloadedStrings #-}
 
 {- This module kicks off the Transcript Tests.
@@ -6,32 +5,34 @@
 -}
 module Main (main) where
 
-import           Unison.Prelude
-import           EasyTest
-import           Shellmet                       (($|))
-import           System.Directory
-import           System.FilePath                ( (</>)
-                                                , splitFileName
-                                                , takeExtensions
-                                                , takeBaseName
-                                                )
-import           System.Process                 ( readProcessWithExitCode )
-
-import           Data.Text                      ( pack
-                                                , unpack
-                                                )
-import           Data.List
-
+import Data.Bifunctor (second)
+import Data.List
+import Data.Text
+  ( pack,
+    unpack,
+  )
+import EasyTest
+import Shellmet (($|))
+import System.Directory
 import System.Environment (getArgs)
+import System.FilePath
+  ( splitFileName,
+    takeBaseName,
+    takeExtensions,
+    (</>),
+  )
+import System.Process (readProcessWithExitCode)
+import Unison.Prelude
 
 data TestConfig = TestConfig
-  { matchPrefix    :: Maybe String
-  } deriving Show
+  { matchPrefix :: Maybe String
+  }
+  deriving (Show)
 
 type TestBuilder = FilePath -> FilePath -> [String] -> String -> Test ()
 
-testBuilder
-  :: FilePath -> FilePath -> [String] -> String -> Test ()
+testBuilder ::
+  FilePath -> FilePath -> [String] -> String -> Test ()
 testBuilder ucm dir prelude transcript = scope transcript $ do
   io $ fromString ucm args
   ok
@@ -39,8 +40,8 @@ testBuilder ucm dir prelude transcript = scope transcript $ do
     files = fmap (pack . (dir </>)) (prelude ++ [transcript])
     args = ["transcript"] ++ files
 
-testBuilder'
-  :: FilePath -> FilePath -> [String] -> String -> Test ()
+testBuilder' ::
+  FilePath -> FilePath -> [String] -> String -> Test ()
 testBuilder' ucm dir prelude transcript = scope transcript $ do
   let output = dir </> takeBaseName transcript <> ".output.md"
   io $ runAndCaptureError ucm args output
@@ -60,31 +61,31 @@ testBuilder' ucm dir prelude transcript = scope transcript $ do
     dropRunMessage :: String -> String
     dropRunMessage = unlines . reverse . drop 3 . reverse . lines
 
-
 buildTests :: TestConfig -> TestBuilder -> FilePath -> Test ()
 buildTests config testBuilder dir = do
   io
-     . putStrLn
-     . unlines
-     $ [ ""
-       , "Searching for transcripts to run in: " ++ dir
-       ]
+    . putStrLn
+    . unlines
+    $ [ "",
+        "Searching for transcripts to run in: " ++ dir
+      ]
   files <- io $ listDirectory dir
-  let
-    -- Any files that start with _ are treated as prelude
-    (prelude, transcripts) =
-      partition ((isPrefixOf "_") . snd . splitFileName)
-      . sort
-        -- if there is a matchPrefix set, check for a prefix match - or return True
-      . filter (\f -> maybe True (`isPrefixOf` f) (matchPrefix config))
-      . filter (\f -> takeExtensions f == ".md") $ files
+  -- Any files that start with _ are treated as prelude
+  let (prelude, transcripts) =
+        files
+          & sort
+          & filter (\f -> takeExtensions f == ".md")
+          & partition ((isPrefixOf "_") . snd . splitFileName)
+          -- if there is a matchPrefix set, filter non-prelude files by that prefix - or return True
+          & second (filter (\f -> maybe True (`isPrefixOf` f) (matchPrefix config)))
 
   ucm <- io $ unpack <$> "stack" $| ["exec", "--", "which", "unison"] -- todo: what is it in windows?
   case length transcripts of
-    0 -> pure ()  -- EasyTest exits early with "no test results recorded"
-                  -- if you don't give it any tests, this keeps it going
-                  -- till the end so we can search all transcripts for
-                  -- prefix matches.
+    0 -> pure ()
+    -- EasyTest exits early with "no test results recorded"
+    -- if you don't give it any tests, this keeps it going
+    -- till the end so we can search all transcripts for
+    -- prefix matches.
     _ -> tests (testBuilder ucm dir prelude <$> transcripts)
 
 -- Transcripts that exit successfully get cleaned-up by the transcript parser.
@@ -102,29 +103,27 @@ cleanup = do
     io
       . putStrLn
       . unlines
-      $ [ ""
-        , "NOTE: All transcript codebases have been moved into"
-        , "the `test-output` directory. Feel free to delete it."
+      $ [ "",
+          "NOTE: All transcript codebases have been moved into",
+          "the `test-output` directory. Feel free to delete it."
         ]
 
 test :: TestConfig -> Test ()
 test config = do
-  buildTests config testBuilder
-    $ "unison-src" </> "transcripts"
-  buildTests config testBuilder
-    $ "unison-src" </> "transcripts-using-base"
-  buildTests config testBuilder'
-    $ "unison-src" </> "transcripts" </> "errors"
+  buildTests config testBuilder $
+    "unison-src" </> "transcripts"
+  buildTests config testBuilder $
+    "unison-src" </> "transcripts-using-base"
+  buildTests config testBuilder' $
+    "unison-src" </> "transcripts" </> "errors"
   cleanup
 
 handleArgs :: [String] -> TestConfig
 handleArgs args =
-  let
-    matchPrefix = case args of
-      [prefix] -> Just prefix
-      _        -> Nothing
-  in
-    TestConfig matchPrefix
+  let matchPrefix = case args of
+        [prefix] -> Just prefix
+        _ -> Nothing
+   in TestConfig matchPrefix
 
 main :: IO ()
 main = do

unison-cli/unison-cli.cabal

@@ -23,6 +23,7 @@ flag optimized
 
 library
   exposed-modules:
+      Compat
       Unison.Codebase.Editor.AuthorInfo
       Unison.Codebase.Editor.Command
       Unison.Codebase.Editor.HandleCommand
@@ -109,6 +110,9 @@ library
     , unliftio
   if flag(optimized)
     ghc-options: -O2 -funbox-strict-fields
+  if !os(windows)
+    build-depends:
+        unix
   default-language: Haskell2010
 
 executable integration-tests
@@ -253,7 +257,6 @@ executable unison
   main-is: Main.hs
   other-modules:
       ArgParse
-      Compat
       System.Path
       Version
       Paths_unison_cli
@@ -320,9 +323,6 @@ executable unison
     , unliftio
   if flag(optimized)
     ghc-options: -O2 -funbox-strict-fields
-  if !os(windows)
-    build-depends:
-        unix
   default-language: Haskell2010
 
 test-suite tests

unison-cli/unison/Compat.hs

@@ -1,34 +0,0 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
-{-# LANGUAGE CPP #-}
-module Compat where
-
-import Control.Concurrent (mkWeakThreadId, myThreadId)
-import Control.Exception (AsyncException (UserInterrupt), throwTo)
-import System.Mem.Weak (deRefWeak)
-
-#if defined(mingw32_HOST_OS)
-import qualified GHC.ConsoleHandler as WinSig
-#else
-import qualified System.Posix.Signals as Sig
-#endif
-
-installSignalHandlers :: IO ()
-installSignalHandlers = do
-  main_thread <- myThreadId
-  wtid <- mkWeakThreadId main_thread
-  let interrupt = do
-        r <- deRefWeak wtid
-        case r of
-          Nothing -> return ()
-          Just t  -> throwTo t UserInterrupt
-
-#if defined(mingw32_HOST_OS)
-  let sig_handler WinSig.ControlC = interrupt
-      sig_handler WinSig.Break    = interrupt
-      sig_handler _               = return ()
-  _ <- WinSig.installHandler (WinSig.Catch sig_handler)
-#else
-  _ <- Sig.installHandler Sig.sigQUIT  (Sig.Catch interrupt) Nothing
-  _ <- Sig.installHandler Sig.sigINT   (Sig.Catch interrupt) Nothing
-#endif
-  return ()

unison-cli/unison/Main.hs

@@ -28,6 +28,7 @@ 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 Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError(..))
 import qualified Unison.Codebase.Editor.Input as Input
 import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace)
 import qualified Unison.Codebase.Editor.VersionParser as VP
@@ -49,7 +50,7 @@ import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import qualified Version
 import UnliftIO.Directory ( getHomeDirectory )
-import Compat ( installSignalHandlers )
+import Compat ( defaultInterruptHandler, withInterruptHandler )
 import ArgParse
     ( UsageRenderer,
       GlobalOptions(GlobalOptions, codebasePathOption),
@@ -67,10 +68,11 @@ import Unison.CommandLine.Welcome (CodebaseInitStatus(..))
 
 main :: IO ()
 main = do
+ interruptHandler <- defaultInterruptHandler
+ withInterruptHandler interruptHandler $ do
   progName <- getProgName
   -- hSetBuffering stdout NoBuffering -- cool
 
-  void installSignalHandlers
   (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribeWithDate
   let GlobalOptions{codebasePathOption=mCodePathOption} = globalOptions
   let mcodepath = fmap codebasePathOptionToPath mCodePathOption
@@ -98,7 +100,7 @@ main = do
 
      Run (RunFromSymbol mainName) args -> do
       getCodebaseOrExit mCodePathOption \(_, _, theCodebase) -> do
-        runtime <- RTI.startRuntime Version.gitDescribeWithDate
+        runtime <- RTI.startRuntime RTI.Standalone 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."
@@ -108,7 +110,7 @@ main = do
               Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
               Right contents -> do
                 getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-                  rt <- RTI.startRuntime Version.gitDescribeWithDate
+                  rt <- RTI.startRuntime RTI.Standalone 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
@@ -117,7 +119,7 @@ main = do
         Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
         Right contents -> do
           getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-            rt <- RTI.startRuntime Version.gitDescribeWithDate
+            rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate
             let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
             launch
               currentDir config rt theCodebase
@@ -184,7 +186,7 @@ main = do
        runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
      Launch isHeadless codebaseServerOpts downloadBase -> do
        getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-         runtime <- RTI.startRuntime Version.gitDescribeWithDate
+         runtime <- RTI.startRuntime RTI.UCM Version.gitDescribeWithDate
          Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do
            case isHeadless of
                Headless -> do
@@ -372,12 +374,21 @@ getCodebaseOrExit codebasePathOption action = do
           executableName <- P.text . Text.pack <$> getProgName
 
           case err of
-            NoCodebaseFoundAtSpecifiedDir ->
+            InitErrorOpen OpenCodebaseDoesntExist ->
               pure (P.lines
                 [ "No codebase exists in " <> pDir <> ".",
                   "Run `" <> executableName <> " --codebase-create " <> P.string dir <> " to create one, then try again!"
                 ])
 
+            InitErrorOpen (OpenCodebaseUnknownSchemaVersion _) ->
+              pure (P.lines
+                [ "I can't read the codebase in " <> pDir <> " because it was constructed using a newer version of unison."
+                , "Please upgrade your version of UCM."
+                ])
+
+            InitErrorOpen (OpenCodebaseOther errMessage) ->
+              pure errMessage
+
             FoundV1Codebase ->
               pure (P.lines
                 [ "Found a v1 codebase at " <> pDir <> ".",

unison-core/src/Unison/ABT.hs

@@ -9,7 +9,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 
-module Unison.ABT 
+module Unison.ABT
   ( -- * Types
     ABT(..)
   , Term(..)

unison-core/src/Unison/Names.hs

@@ -381,10 +381,16 @@ difference a b = Names (R.difference (terms a) (terms b))
                        (R.difference (types a) (types b))
 
 contains :: Names -> Reference -> Bool
-contains names r =
-  -- this check makes `contains` O(n) instead of O(log n)
-  (Set.member r . Set.map Referent.toReference . R.ran) (terms names)
-  || R.memberRan r (types names)
+contains names =
+  -- We want to compute `termsReferences` only once, if `contains` is partially applied to a `Names`, and called over
+  -- and over for different references. GHC would probably float `termsReferences` out without the explicit lambda, but
+  -- it's written like this just to be sure.
+  \r -> Set.member r termsReferences || R.memberRan r (types names)
+  where
+    -- this check makes `contains` O(n) instead of O(log n)
+    termsReferences :: Set Reference
+    termsReferences =
+      Set.map Referent.toReference (R.ran (terms names))
 
 -- | filters out everything from the domain except what's conflicted
 conflicts :: Names -> Names

unison-src/transcripts-round-trip/main.md

@@ -255,6 +255,64 @@ x = 2
 .> add
 ```
 
+## Unison Cloud roundtrip issues
+
+Regression tests for  https://github.com/unisonweb/unison/issues/2650
+
+```unison:hide
+broken =
+    addNumbers: 'Nat
+    addNumbers = 'let
+      use Nat +
+      y = 12
+      13 + y
+    !addNumbers    
+```
+
+``` ucm
+.> add
+.> edit broken
+.> undo
+```
+
+``` ucm
+.> load scratch.u
+```
+
+```unison:hide
+tvarmodify tvar fun = ()
+
+broken tvar = 
+  '(tvarmodify tvar (cases
+     Some _ -> "oh boy isn't this a very very very very very very very long string?"
+     None -> ""))
+```
+
+``` ucm
+.> add
+.> edit tvarmodify broken
+.> undo
+```
+
+``` ucm
+.> load scratch.u
+```
+
+```unison:hide
+broken = cases 
+  Some loooooooooooooooooooooooooooooooooooooooooooooooooooooooong | loooooooooooooooooooooooooooooooooooooooooooooooooooooooong == 1 -> ()
+```
+
+``` ucm
+.> add
+.> edit broken
+.> undo
+```
+
+``` ucm
+.> load scratch.u
+```
+
 ## Guard patterns on long lines
 
 ```unison:hide
@@ -278,8 +336,5 @@ foo = let
 
 ```ucm
 .> load scratch.u
-.> add
 ```
 
-
-

unison-src/transcripts-round-trip/main.output.md

@@ -34,15 +34,15 @@ x = 1 + 1
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1. #hmq8ode0gs : add
-  2. #oqt1jsjk91 : builtins.mergeio
+  1. #edkeq4dlqo : add
+  2. #ehfimtkqge : builtins.mergeio
   3. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1. #e5ctdurcur : add
-  2. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  3. #hmq8ode0gs : add
-  4. #oqt1jsjk91 : builtins.mergeio
+  1. #dne7ugdlmg : add
+  2. #ehfimtkqge : reset-root #ehfimtkqge
+  3. #edkeq4dlqo : add
+  4. #ehfimtkqge : builtins.mergeio
   5. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -191,19 +191,19 @@ f x = let
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1. #ql7sn0ps1v : add
-  2. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  3. #e5ctdurcur : add
-  4. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  5. #hmq8ode0gs : add
-  6. #oqt1jsjk91 : builtins.mergeio
+  1. #ps96u84es8 : add
+  2. #ehfimtkqge : reset-root #ehfimtkqge
+  3. #dne7ugdlmg : add
+  4. #ehfimtkqge : reset-root #ehfimtkqge
+  5. #edkeq4dlqo : add
+  6. #ehfimtkqge : builtins.mergeio
   7. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -273,21 +273,21 @@ h xs = match xs with
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1. #q6qaupqk4a : add
-  2. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  3. #ql7sn0ps1v : add
-  4. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  5. #e5ctdurcur : add
-  6. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  7. #hmq8ode0gs : add
-  8. #oqt1jsjk91 : builtins.mergeio
+  1. #13i3s2120q : add
+  2. #ehfimtkqge : reset-root #ehfimtkqge
+  3. #ps96u84es8 : add
+  4. #ehfimtkqge : reset-root #ehfimtkqge
+  5. #dne7ugdlmg : add
+  6. #ehfimtkqge : reset-root #ehfimtkqge
+  7. #edkeq4dlqo : add
+  8. #ehfimtkqge : builtins.mergeio
   9. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -353,23 +353,23 @@ foo n _ = n
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1.  #75hol9q7nl : add
-  2.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  3.  #q6qaupqk4a : add
-  4.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  5.  #ql7sn0ps1v : add
-  6.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  7.  #e5ctdurcur : add
-  8.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  9.  #hmq8ode0gs : add
-  10. #oqt1jsjk91 : builtins.mergeio
+  1.  #29at46a9as : add
+  2.  #ehfimtkqge : reset-root #ehfimtkqge
+  3.  #13i3s2120q : add
+  4.  #ehfimtkqge : reset-root #ehfimtkqge
+  5.  #ps96u84es8 : add
+  6.  #ehfimtkqge : reset-root #ehfimtkqge
+  7.  #dne7ugdlmg : add
+  8.  #ehfimtkqge : reset-root #ehfimtkqge
+  9.  #edkeq4dlqo : add
+  10. #ehfimtkqge : builtins.mergeio
   11. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -432,25 +432,25 @@ foo =
   most recent, along with the command that got us there. Try:
   
     `fork 2 .old`             
-    `fork #oqt1jsjk91 .old`   to make an old namespace
+    `fork #ehfimtkqge .old`   to make an old namespace
                               accessible again,
                               
-    `reset-root #oqt1jsjk91`  to reset the root namespace and
+    `reset-root #ehfimtkqge`  to reset the root namespace and
                               its history to that of the
                               specified namespace.
   
-  1.  #j2jte1lhh2 : add
-  2.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  3.  #75hol9q7nl : add
-  4.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  5.  #q6qaupqk4a : add
-  6.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  7.  #ql7sn0ps1v : add
-  8.  #oqt1jsjk91 : reset-root #oqt1jsjk91
-  9.  #e5ctdurcur : add
-  10. #oqt1jsjk91 : reset-root #oqt1jsjk91
-  11. #hmq8ode0gs : add
-  12. #oqt1jsjk91 : builtins.mergeio
+  1.  #7b35f5f5ue : add
+  2.  #ehfimtkqge : reset-root #ehfimtkqge
+  3.  #29at46a9as : add
+  4.  #ehfimtkqge : reset-root #ehfimtkqge
+  5.  #13i3s2120q : add
+  6.  #ehfimtkqge : reset-root #ehfimtkqge
+  7.  #ps96u84es8 : add
+  8.  #ehfimtkqge : reset-root #ehfimtkqge
+  9.  #dne7ugdlmg : add
+  10. #ehfimtkqge : reset-root #ehfimtkqge
+  11. #edkeq4dlqo : add
+  12. #ehfimtkqge : builtins.mergeio
   13. #sjg2v58vn2 : (initial reflogged namespace)
 
 .> reset-root 2
@@ -758,6 +758,179 @@ x = 2
 
   ⊡ Ignored previously added definitions: docTest2
 
+```
+## Unison Cloud roundtrip issues
+
+Regression tests for  https://github.com/unisonweb/unison/issues/2650
+
+```unison
+broken =
+    addNumbers: 'Nat
+    addNumbers = 'let
+      use Nat +
+      y = 12
+      13 + y
+    !addNumbers    
+```
+
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    broken : Nat
+
+.> edit broken
+
+  ☝️
+  
+  I added these definitions to the top of
+  /Users/runar/work/unison/scratch.u
+  
+    broken : Nat
+    broken =
+      addNumbers : 'Nat
+      addNumbers = 'let
+        use Nat +
+        y = 12
+        13 + y
+      !addNumbers
+  
+  You can edit them there, then do `update` to replace the
+  definitions currently in this namespace.
+
+.> undo
+
+  Here are the changes I undid
+  
+  Added definitions:
+  
+    1. broken : Nat
+
+```
+```ucm
+.> load scratch.u
+
+  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`:
+    
+      broken : Nat
+
+```
+```unison
+tvarmodify tvar fun = ()
+
+broken tvar = 
+  '(tvarmodify tvar (cases
+     Some _ -> "oh boy isn't this a very very very very very very very long string?"
+     None -> ""))
+```
+
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    broken     : tvar -> () -> ()
+    tvarmodify : tvar -> fun -> ()
+
+.> edit tvarmodify broken
+
+  ☝️
+  
+  I added these definitions to the top of
+  /Users/runar/work/unison/scratch.u
+  
+    broken : tvar -> () -> ()
+    broken tvar =
+      '(tvarmodify
+          tvar
+          (cases
+            Some _ ->
+              "oh boy isn't this a very very very very very very very long string?"
+            None   -> ""))
+    
+    tvarmodify : tvar -> fun -> ()
+    tvarmodify tvar fun = ()
+  
+  You can edit them there, then do `update` to replace the
+  definitions currently in this namespace.
+
+.> undo
+
+  Here are the changes I undid
+  
+  Added definitions:
+  
+    1. broken     : tvar -> () -> ()
+    2. tvarmodify : tvar -> fun -> ()
+
+```
+```ucm
+.> load scratch.u
+
+  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`:
+    
+      broken     : tvar -> '()
+      tvarmodify : tvar -> fun -> ()
+
+```
+```unison
+broken = cases 
+  Some loooooooooooooooooooooooooooooooooooooooooooooooooooooooong | loooooooooooooooooooooooooooooooooooooooooooooooooooooooong == 1 -> ()
+```
+
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    broken : Optional Nat -> ()
+
+.> edit broken
+
+  ☝️
+  
+  I added these definitions to the top of
+  /Users/runar/work/unison/scratch.u
+  
+    broken : Optional Nat -> ()
+    broken = cases
+      Some
+        loooooooooooooooooooooooooooooooooooooooooooooooooooooooong | loooooooooooooooooooooooooooooooooooooooooooooooooooooooong
+        == 1 ->
+        ()
+  
+  You can edit them there, then do `update` to replace the
+  definitions currently in this namespace.
+
+.> undo
+
+  Here are the changes I undid
+  
+  Added definitions:
+  
+    1. broken : Optional Nat -> ()
+
+```
+```ucm
+.> load scratch.u
+
+  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`:
+    
+      broken : Optional Nat -> ()
+
 ```
 ## Guard patterns on long lines
 
@@ -796,10 +969,10 @@ foo = let
     foo =
       go x =
         'match (a -> a) x with
-          SomethingUnusuallyLong
-            lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij 
-            | lijaefliejalfijelfj == aefilaeifhlei -> 0
-            | lijaefliejalfijelfj == liaehjffeafijij -> 1
+            SomethingUnusuallyLong
+              lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij 
+              | lijaefliejalfijelfj == aefilaeifhlei   -> 0
+              | lijaefliejalfijelfj == liaehjffeafijij -> 1
       go (SomethingUnusuallyLong "one" "two" "three")
   
   You can edit them there, then do `update` to replace the
@@ -831,11 +1004,4 @@ foo = let
       structural type SomethingUnusuallyLong
       foo : 'Nat
 
-.> add
-
-  ⍟ I've added these definitions:
-  
-    structural type SomethingUnusuallyLong
-    foo : 'Nat
-
 ```

unison-src/transcripts/bug-strange-closure.output.md

@@ -2077,9 +2077,9 @@ rendered = Pretty.get (docFormatConsole doc.guide)
                                                     (Term.Term
                                                       (Any
                                                         '(f x ->
-                                                          f x
-                                                            Nat.+ sqr
-                                                                    1))))),
+                                                            f x
+                                                              Nat.+ sqr
+                                                                      1))))),
                                                 !Lit
                                                 (Right
                                                   (Plain "-")),
@@ -2276,8 +2276,8 @@ rendered = Pretty.get (docFormatConsole doc.guide)
                                                         (Term.Term
                                                           (Any
                                                             '(x ->
-                                                              sqr
-                                                                x))))),
+                                                                sqr
+                                                                  x))))),
                                                     !Lit
                                                     (Right
                                                       (Plain ".")) ]) ])) ]))) ]))) ])))),

unison-src/transcripts/empty-namespaces.md

@@ -48,6 +48,8 @@ stuff.thing = 2
 .> delete.namespace .deleted
 ```
 
+## fork
+
 I should be allowed to fork over a deleted namespace
 
 ```ucm
@@ -60,3 +62,24 @@ The history from the `deleted` namespace should have been overwritten by the his
 .> history stuff
 .> history deleted
 ```
+
+## move.namespace
+
+```unison:hide
+moveoverme.x = 1
+moveme.y = 2
+```
+
+```ucm:hide
+.> add
+```
+
+I should be able to move a namespace over-top of a deleted namespace.
+The history should be that of the moved namespace.
+
+```ucm
+.> delete.namespace moveoverme
+.> history moveme
+.> move.namespace moveme moveoverme
+.> history moveoverme
+```

unison-src/transcripts/empty-namespaces.output.md

@@ -82,6 +82,8 @@ deleted.x = 1
 stuff.thing = 2
 ```
 
+## fork
+
 I should be allowed to fork over a deleted namespace
 
 ```ucm
@@ -112,3 +114,45 @@ The history from the `deleted` namespace should have been overwritten by the his
   □ #3bm1524lb7 (start of history)
 
 ```
+## move.namespace
+
+```unison
+moveoverme.x = 1
+moveme.y = 2
+```
+
+I should be able to move a namespace over-top of a deleted namespace.
+The history should be that of the moved namespace.
+
+```ucm
+.> delete.namespace moveoverme
+
+  Removed definitions:
+  
+    1. x : ##Nat
+  
+  Tip: You can use `undo` or `reflog` to undo this change.
+
+.> history moveme
+
+  Note: The most recent namespace hash is immediately below this
+        message.
+  
+  
+  
+  □ #ldl7o5e9i5 (start of history)
+
+.> move.namespace moveme moveoverme
+
+  Done.
+
+.> history moveoverme
+
+  Note: The most recent namespace hash is immediately below this
+        message.
+  
+  
+  
+  □ #ldl7o5e9i5 (start of history)
+
+```