Merge branch 'trunk' into work/compiler

.github/workflows/ci.yaml

@@ -157,6 +157,10 @@ jobs:
         run: stack --no-terminal build --fast --test unison-cli
       - name: unison-parser-typechecker tests
         run: stack --no-terminal build --fast --test unison-parser-typechecker
+      - name: unison-syntax tests
+        run: stack --no-terminal build --fast --test unison-syntax
+      - name: unison-util-bytes tests
+        run: stack --no-terminal build --fast --test unison-util-bytes
       - name: unison-util-relation tests
         run: stack --no-terminal build --fast --test unison-util-relation
       - name: transcripts

.github/workflows/release.yaml

@@ -11,6 +11,10 @@ on:
         description: 'Release Version (E.g. M4 or M4a)'
         required: true
         type: string
+      share_base_path:
+        description: 'Path to base version that UCM should pull by default (E.g. `unison.public.base.releases.M4`)'
+        required: true
+        type: string
       target:
         description: 'Ref to use for this release, defaults to trunk'
         required: true
@@ -57,6 +61,8 @@ jobs:
 
     name: "build_linux"
     runs-on: ubuntu-20.04
+    env:
+      UNISON_BASE_PATH: "${{inputs.share_base_path}}"
     steps:
       - uses: actions/checkout@v2
         with:
@@ -102,7 +108,11 @@ jobs:
           echo "$PWD/stack-"* >> $GITHUB_PATH
 
       - name: build
-        run: stack --no-terminal build --flag unison-parser-typechecker:optimized
+        run: |
+          # unison-cli checks env vars for which base version to automatically pull,
+          # so it needs to be forced to rebuild to ensure those are updated.
+          stack clean unison-cli
+          stack --no-terminal build --flag unison-parser-typechecker:optimized
 
       - name: fetch latest Unison Local UI and package with ucm
         run: |
@@ -123,6 +133,8 @@ jobs:
   build_macos:
     name: "build_macos"
     runs-on: macos-11
+    env:
+      UNISON_BASE_PATH: "${{inputs.share_base_path}}"
     steps:
       - uses: actions/checkout@v2
         with:
@@ -171,7 +183,11 @@ jobs:
         run: rm -rf ~/.stack/setup-exe-cache
 
       - name: build
-        run: stack --no-terminal build --flag unison-parser-typechecker:optimized
+        run: |
+          # unison-cli checks env vars for which base version to automatically pull,
+          # so it needs to be forced to rebuild to ensure those are updated.
+          stack clean unison-cli
+          stack --no-terminal build --flag unison-parser-typechecker:optimized
 
       - name: fetch latest Unison Local UI and package with ucm
         run: |
@@ -192,6 +208,8 @@ jobs:
   build_windows:
     name: "build_windows"
     runs-on: windows-2019
+    env:
+      UNISON_BASE_PATH: "${{inputs.share_base_path}}"
 
     steps:
       - uses: actions/checkout@v2
@@ -239,6 +257,10 @@ jobs:
 
       - name: build
         run: |
+          # unison-cli checks env vars for which base version to automatically pull,
+          # so it needs to be forced to rebuild to ensure those are updated.
+          stack clean unison-cli
+
           # Windows will crash on build intermittently because the filesystem
           # sucks at managing concurrent file access;
           # Just keep retrying on these failures.

README.md

@@ -5,8 +5,9 @@ The Unison language
 
 * [Overview](#overview)
 * [Building using Stack](#building-using-stack)
-* [Language Server Protocol (LSP)](#language-server-protocol-lsp)
+* [Language Server Protocol (LSP)](docs/language-server.markdown)
 * [Codebase Server](#codebase-server)
+* [Configuration](./docs/configuration.md)
 
 Overview
 --------
@@ -67,3 +68,8 @@ connect to the server.
 
 The port, host and token can all be configured by providing environment
 variables when starting `ucm`: `UCM_PORT`, `UCM_HOST`, and `UCM_TOKEN`.
+
+Configuration
+-------------
+
+See the documentation for configuration [here](docs/configuration.md)

codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs

@@ -4,11 +4,13 @@ module U.Codebase.Sqlite.Operations
     loadRootCausalHash,
     expectRootCausalHash,
     expectRootCausal,
+    expectRootBranchHash,
     loadCausalHashAtPath,
     expectCausalHashAtPath,
     saveBranch,
     loadCausalBranchByCausalHash,
     expectCausalBranchByCausalHash,
+    expectBranchByBranchHash,
     expectNamespaceStatsByHash,
     expectNamespaceStatsByHashId,
 
@@ -65,7 +67,7 @@ module U.Codebase.Sqlite.Operations
     termsMentioningType,
 
     -- ** name lookup index
-    rebuildNameIndex,
+    updateNameIndex,
     rootNamesByPath,
     NamesByPath (..),
 
@@ -91,7 +93,7 @@ module U.Codebase.Sqlite.Operations
     Q.s2cTermWithType,
     Q.s2cDecl,
     declReferencesByPrefix,
-    branchHashesByPrefix,
+    namespaceHashesByPrefix,
     derivedDependencies,
   )
 where
@@ -117,7 +119,7 @@ import qualified U.Codebase.Reference as C.Reference
 import qualified U.Codebase.Referent as C
 import qualified U.Codebase.Referent as C.Referent
 import qualified U.Codebase.Reflog as Reflog
-import U.Codebase.ShortHash (ShortBranchHash (ShortBranchHash))
+import U.Codebase.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..))
 import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch
 import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch.Diff
 import qualified U.Codebase.Sqlite.Branch.Diff as S.BranchDiff
@@ -196,6 +198,11 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId
 expectRootCausalHash :: Transaction CausalHash
 expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot
 
+expectRootBranchHash :: Transaction BranchHash
+expectRootBranchHash = do
+  rootCausalHashId <- Q.expectNamespaceRoot
+  expectValueHashByCausalHashId rootCausalHashId
+
 loadRootCausalHash :: Transaction (Maybe CausalHash)
 loadRootCausalHash =
   runMaybeT $
@@ -631,7 +638,8 @@ saveBranch ::
 saveBranch hh (C.Causal hc he parents me) = do
   when debug $ traceM $ "\nOperations.saveBranch \n  hc = " ++ show hc ++ ",\n  he = " ++ show he ++ ",\n  parents = " ++ show (Map.keys parents)
 
-  (chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do
+  -- Save the causal
+  (chId, bhId) <- whenNothingM (Q.loadCausalByCausalHash hc) do
     -- if not exist, create these
     chId <- Q.saveCausalHash hc
     bhId <- Q.saveBranchHash he
@@ -648,7 +656,9 @@ saveBranch hh (C.Causal hc he parents me) = do
     -- Save these CausalHashIds to the causal_parents table,
     Q.saveCausal hh chId bhId parentCausalHashIds
     pure (chId, bhId)
-  boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do
+
+  -- Save the namespace
+  boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByBranchHashId bhId) do
     branch <- me
     dbBranch <- c2sBranch branch
     stats <- namespaceStatsForDbBranch dbBranch
@@ -716,6 +726,16 @@ loadDbBranchByCausalHashId causalHashId =
     Nothing -> pure Nothing
     Just branchObjectId -> Just <$> expectDbBranch branchObjectId
 
+expectBranchByBranchHashId :: Db.BranchHashId -> Transaction (C.Branch.Branch Transaction)
+expectBranchByBranchHashId bhId = do
+  boId <- Q.expectBranchObjectIdByBranchHashId bhId
+  expectBranch boId
+
+expectBranchByBranchHash :: BranchHash -> Transaction (C.Branch.Branch Transaction)
+expectBranchByBranchHash bh = do
+  bhId <- Q.saveBranchHash bh
+  expectBranchByBranchHashId bhId
+
 -- | Expect a branch value given its causal hash id.
 expectDbBranchByCausalHashId :: Db.CausalHashId -> Transaction S.DbBranch
 expectDbBranchByCausalHashId causalHashId = do
@@ -1003,14 +1023,14 @@ declReferentsByPrefix b32prefix pos cid = do
       (_localIds, decl) <- Q.expectDeclObject r (decodeDeclElement i)
       pure (C.Decl.declType decl, length (C.Decl.constructorTypes decl))
 
-branchHashesByPrefix :: ShortBranchHash -> Transaction (Set BranchHash)
-branchHashesByPrefix (ShortBranchHash b32prefix) = do
+namespaceHashesByPrefix :: ShortNamespaceHash -> Transaction (Set BranchHash)
+namespaceHashesByPrefix (ShortNamespaceHash b32prefix) = do
   hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix
   hashes <- traverse (Q.expectHash . Db.unBranchHashId) hashIds
   pure $ Set.fromList . map BranchHash $ hashes
 
-causalHashesByPrefix :: ShortBranchHash -> Transaction (Set CausalHash)
-causalHashesByPrefix (ShortBranchHash b32prefix) = do
+causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash)
+causalHashesByPrefix (ShortCausalHash b32prefix) = do
   hashIds <- Q.causalHashIdByBase32Prefix b32prefix
   hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds
   pure $ Set.fromList . map CausalHash $ hashes
@@ -1018,9 +1038,18 @@ causalHashesByPrefix (ShortBranchHash b32prefix) = do
 -- | returns a list of known definitions referencing `r`
 dependents :: Q.DependentsSelector -> C.Reference -> Transaction (Set C.Reference.Id)
 dependents selector r = do
-  r' <- c2sReference r
-  sIds <- Q.getDependentsForDependency selector r'
-  Set.traverse s2cReferenceId sIds
+  mr <- case r of
+    C.ReferenceBuiltin {} -> pure (Just r)
+    C.ReferenceDerived id_ ->
+      objectExistsForHash (view C.idH id_) <&> \case
+        True -> Just r
+        False -> Nothing
+  case mr of
+    Nothing -> pure mempty
+    Just r -> do
+      r' <- c2sReference r
+      sIds <- Q.getDependentsForDependency selector r'
+      Set.traverse s2cReferenceId sIds
 
 -- | returns a list of known definitions referencing `h`
 dependentsOfComponent :: H.Hash -> Transaction (Set C.Reference.Id)
@@ -1038,13 +1067,19 @@ derivedDependencies cid = do
   cids <- traverse s2cReferenceId sids
   pure $ Set.fromList cids
 
--- | Given the list of term and type names from the root branch, rebuild the name lookup
--- table.
-rebuildNameIndex :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)] -> [S.NamedRef C.Reference] -> Transaction ()
-rebuildNameIndex termNames typeNames = do
-  Q.resetNameLookupTables
-  Q.insertTermNames ((fmap (c2sTextReferent *** fmap c2sConstructorType) <$> termNames))
-  Q.insertTypeNames ((fmap c2sTextReference <$> typeNames))
+-- | Given lists of names to add and remove, update the index accordingly.
+updateNameIndex ::
+  -- |  (add terms, remove terms)
+  ([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Referent]) ->
+  -- |  (add types, remove types)
+  ([S.NamedRef C.Reference], [S.NamedRef C.Reference]) ->
+  Transaction ()
+updateNameIndex (newTermNames, removedTermNames) (newTypeNames, removedTypeNames) = do
+  Q.ensureNameLookupTables
+  Q.removeTermNames ((fmap c2sTextReferent <$> removedTermNames))
+  Q.removeTypeNames ((fmap c2sTextReference <$> removedTypeNames))
+  Q.insertTermNames (fmap (c2sTextReferent *** fmap c2sConstructorType) <$> newTermNames)
+  Q.insertTypeNames (fmap c2sTextReference <$> newTypeNames)
 
 data NamesByPath = NamesByPath
   { termNamesInPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)],

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -79,7 +79,9 @@ module U.Codebase.Sqlite.Queries
     loadCausalByCausalHash,
     expectCausalByCausalHash,
     loadBranchObjectIdByCausalHashId,
+    loadBranchObjectIdByBranchHashId,
     expectBranchObjectIdByCausalHashId,
+    expectBranchObjectIdByBranchHashId,
 
     -- ** causal_parent table
     saveCausalParents,
@@ -104,6 +106,7 @@ module U.Codebase.Sqlite.Queries
     getDependentsForDependencyComponent,
     getDependenciesForDependent,
     getDependencyIdsForDependent,
+    getDependenciesBetweenTerms,
 
     -- ** migrations
     currentSchemaVersion,
@@ -130,9 +133,12 @@ module U.Codebase.Sqlite.Queries
     causalHashIdByBase32Prefix,
 
     -- * Name Lookup
-    resetNameLookupTables,
+    ensureNameLookupTables,
+    dropNameLookupTables,
     insertTermNames,
     insertTypeNames,
+    removeTermNames,
+    removeTypeNames,
     rootTermNamesByPath,
     rootTypeNamesByPath,
     getNamespaceDefinitionCount,
@@ -1038,6 +1044,19 @@ loadBranchObjectIdByCausalHashIdSql =
     WHERE causal.self_hash_id = ?
   |]
 
+expectBranchObjectIdByBranchHashId :: BranchHashId -> Transaction BranchObjectId
+expectBranchObjectIdByBranchHashId id = queryOneCol loadBranchObjectIdByBranchHashIdSql (Only id)
+
+loadBranchObjectIdByBranchHashId :: BranchHashId -> Transaction (Maybe BranchObjectId)
+loadBranchObjectIdByBranchHashId id = queryMaybeCol loadBranchObjectIdByBranchHashIdSql (Only id)
+
+loadBranchObjectIdByBranchHashIdSql :: Sql
+loadBranchObjectIdByBranchHashIdSql =
+  [here|
+    SELECT object_id FROM hash_object
+    WHERE hash_id = ?
+  |]
+
 saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction ()
 saveCausalParents child parents = executeMany sql $ (child,) <$> parents where
   sql = [here|
@@ -1286,8 +1305,8 @@ garbageCollectWatchesWithoutObjects = do
       (SELECT hash_object.hash_id FROM hash_object)
     |]
 
-addToDependentsIndex :: Reference.Reference -> Reference.Id -> Transaction ()
-addToDependentsIndex dependency dependent = execute sql (dependency :. dependent)
+addToDependentsIndex :: [Reference.Reference] -> Reference.Id -> Transaction ()
+addToDependentsIndex dependencies dependent = executeMany sql (map (:. dependent) dependencies)
   where sql = [here|
     INSERT INTO dependents_index (
       dependency_builtin,
@@ -1387,13 +1406,122 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) =
         FROM dependents_index
         WHERE dependency_builtin IS NULL
           AND dependent_object_id = ?
-          AND dependen_component_index = ?
+          AND dependent_component_index = ?
       |]
 
     isNotSelfReference :: Reference.Id -> Bool
     isNotSelfReference (C.Reference.Id oid1 _) =
       oid0 /= oid1
 
+-- | Given two term (components) A and B, return the set of all terms that are along any "dependency path" from A to B,
+-- not including A nor B; i.e., the transitive dependencies of A that are transitive dependents of B.
+--
+-- For example, if A depends on X and Y, X depends on Q, Y depends on Z, and X and Z depend on B...
+--
+--     --X-----Q
+--    /     \
+--   A       B
+--    \     /
+--     Y---Z
+--
+-- ...then `getDependenciesBetweenTerms A B` would return the set {X Y Z}
+getDependenciesBetweenTerms :: ObjectId -> ObjectId -> Transaction (Set ObjectId)
+getDependenciesBetweenTerms oid1 oid2 =
+  queryListCol sql (oid1, oid2, oid2) <&> Set.fromList
+  where
+    -- Given the example above, we'd have tables that look like this.
+    --
+    -- First, the `paths` table finds all paths from source `A`, exploring depth-first. As a minor optimization, we seed
+    -- the search not with `A`, but rather the direct dependencies of `A` (namely `X` and `Y`).
+    --
+    -- Naming note: "path_init" / "path_last" refer to the "init" / "last" elements of a list segments of a list (though
+    -- our "last" is in reverse order):
+    --
+    --        [foo, bar, baz, qux]
+    --   init  ^^^^^^^^^^^^^
+    --   last                 ^^^
+    --
+    -- +-paths-------------------------+
+    -- +-level-+-path_last-+-path_init-+
+    -- |     0 |         X |        '' | -- path: [X]
+    -- |     0 |         Y |        '' | -- path: [Y]
+    -- |     1 |         B |      'X,' | -- path: [X,B]   -- ends in B, yay!
+    -- |     1 |         Q |      'X,' | -- path: [X,Q]
+    -- |     1 |         Z |      'Y,' | -- path: [Y,Z]
+    -- |     2 |         B |    'Z,Y,' | -- path: [Y,Z,B] -- ends in B, yay!
+    -- +-------+-----------+-----------+
+    --
+    -- Next, we seed another recursive CTE with those paths that end in the sink `B`. This is just the (very verbose)
+    -- way to unnest an array in SQLite. All we're doing is turning the set of strings {'X,' 'Z,Y,'}, each of which
+    -- represents the inner nodes of a full path between `A` and `B`, into the set {X Z Y}, which is just the full set
+    -- of such inner nodes, along any path.
+    --
+    -- +-elems-----------------+
+    -- +-path_elem-+-path_init-+
+    -- |           |      'X,' |
+    -- |           |    'Z,Y,' |
+    -- |       'X' |        '' |
+    -- |       'Z' |      'Y,' |
+    -- |       'Y' |        '' |
+    -- +-----------+-----------+
+    --
+    -- And finally, we just select out the non-null `path_elem` rows from here, casting the strings back to integers for
+    -- clarity (this isn't very matter - SQLite would cast on-the-fly).
+    --
+    -- +-path_elem-+
+    -- |         X |
+    -- |         Z |
+    -- |         Y |
+    -- +-----------+
+    --
+    -- Notes
+    --
+    -- (1) We only care about term dependencies, not type dependencies. This is because a type can only depend on types,
+    --     not terms, so there is no point in searching through a type's transitive dependencies looking for our sink.
+    -- (2) No need to search beyond the sink itself, since component dependencies form a DAG.
+    -- (3) An explicit cast from e.g. string '1' to int 1 isn't strictly necessary.
+    sql :: Sql
+    sql = [here|
+      WITH RECURSIVE paths(level, path_last, path_init) AS (
+        SELECT
+          0,
+          dependents_index.dependency_object_id,
+          ''
+        FROM dependents_index
+          JOIN object ON dependents_index.dependency_object_id = object.id
+        WHERE dependents_index.dependent_object_id = ?
+          AND object.type_id = 0 -- Note (1)
+          AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
+        UNION ALL
+        SELECT
+          paths.level + 1 AS level,
+          dependents_index.dependency_object_id,
+          dependents_index.dependent_object_id || ',' || paths.path_init
+        FROM paths
+          JOIN dependents_index
+            ON paths.path_last = dependents_index.dependent_object_id
+          JOIN object ON dependents_index.dependency_object_id = object.id
+        WHERE object.type_id = 0 -- Note (1)
+          AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
+          AND paths.path_last != ? -- Note (2)
+        ORDER BY level DESC
+      ),
+      elems(path_elem, path_init) AS (
+        SELECT null, path_init
+        FROM paths
+        WHERE paths.path_last = ?
+        UNION ALL
+        SELECT
+          substr(path_init, 0, instr(path_init, ',')),
+          substr(path_init, instr(path_init, ',') + 1)
+        FROM elems
+        WHERE path_init != ''
+      )
+      SELECT DISTINCT CAST(path_elem AS integer) AS path_elem -- Note (3)
+      FROM elems
+      WHERE path_elem IS NOT null
+    |]
+
 objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId]
 objectIdByBase32Prefix objType prefix = queryListCol sql (objType, likeEscape '\\' prefix <> "%") where sql = [here|
   SELECT object.id FROM object
@@ -1441,14 +1569,26 @@ removeHashObjectsByHashingVersion hashVersion =
       WHERE hash_version = ?
 |]
 
--- | Drop and recreate the name lookup tables. Use this when resetting names to a new branch.
-resetNameLookupTables :: Transaction ()
-resetNameLookupTables = do
-  execute_ "DROP TABLE IF EXISTS term_name_lookup"
-  execute_ "DROP TABLE IF EXISTS type_name_lookup"
+-- | Not used in typical operations, but if we ever end up in a situation where a bug
+-- has caused the name lookup index to go out of sync this can be used to get back to a clean
+-- slate.
+dropNameLookupTables :: Transaction ()
+dropNameLookupTables = do
   execute_
     [here|
-      CREATE TABLE term_name_lookup (
+    DROP TABLE IF EXISTS term_name_lookup
+  |]
+  execute_
+    [here|
+    DROP TABLE IF EXISTS type_name_lookup
+  |]
+
+-- | Ensure the name lookup tables exist.
+ensureNameLookupTables :: Transaction ()
+ensureNameLookupTables = do
+  execute_
+    [here|
+      CREATE TABLE IF NOT EXISTS term_name_lookup (
         -- The name of the term: E.g. map.List.base
         reversed_name TEXT NOT NULL,
         -- The namespace containing this term, not reversed: E.g. base.List
@@ -1463,7 +1603,7 @@ resetNameLookupTables = do
     |]
   execute_
     [here|
-      CREATE INDEX term_names_by_namespace ON term_name_lookup(namespace)
+      CREATE INDEX IF NOT EXISTS term_names_by_namespace ON term_name_lookup(namespace)
     |]
   -- Don't need this index at the moment, but will likely be useful later.
   -- execute_
@@ -1472,7 +1612,7 @@ resetNameLookupTables = do
   --   |]
   execute_
     [here|
-      CREATE TABLE type_name_lookup (
+      CREATE TABLE IF NOT EXISTS type_name_lookup (
         -- The name of the term: E.g. List.base
         reversed_name TEXT NOT NULL,
         -- The namespace containing this term, not reversed: E.g. base.List
@@ -1485,7 +1625,7 @@ resetNameLookupTables = do
     |]
   execute_
     [here|
-      CREATE INDEX type_names_by_namespace ON type_name_lookup(namespace)
+      CREATE INDEX IF NOT EXISTS type_names_by_namespace ON type_name_lookup(namespace)
     |]
 
 -- Don't need this index at the moment, but will likely be useful later.
@@ -1508,6 +1648,37 @@ insertTermNames names = do
         ON CONFLICT DO NOTHING
         |]
 
+-- | Remove the given set of term names into the name lookup table
+removeTermNames :: [NamedRef Referent.TextReferent] -> Transaction ()
+removeTermNames names = do
+  executeMany sql names
+  where
+    sql =
+      [here|
+      DELETE FROM term_name_lookup
+        WHERE
+        reversed_name IS ?
+        AND referent_builtin IS ?
+        AND referent_component_hash IS ?
+        AND referent_component_index IS ?
+        AND referent_constructor_index IS ?
+        |]
+
+-- | Remove the given set of term names into the name lookup table
+removeTypeNames :: [NamedRef (Reference.TextReference)] -> Transaction ()
+removeTypeNames names = do
+  executeMany sql names
+  where
+    sql =
+      [here|
+      DELETE FROM type_name_lookup
+        WHERE
+        reversed_name IS ?
+        AND reference_builtin IS ?
+        AND reference_component_hash IS ?
+        AND reference_component_index IS ?
+        |]
+
 -- | We need to escape any special characters for globbing.
 --
 -- >>> globEscape "Nat.*.doc"
@@ -1612,6 +1783,7 @@ rootTypeNamesByPath mayNamespace = do
         ORDER BY (namespace GLOB ? OR namespace = ?) DESC
         |]
 
+-- | @before x y@ returns whether or not @x@ occurred before @y@, i.e. @x@ is an ancestor of @y@.
 before :: CausalHashId -> CausalHashId -> Transaction Bool
 before chId1 chId2 = queryOneCol sql (chId2, chId1)
   where
@@ -1877,8 +2049,7 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT
          in S.putBytes Serialization.putTermFormat $ S.Term.Term li
   oId <- saveObject hh hashId ObjectType.TermComponent bytes
   -- populate dependents index
-  let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..])
-      unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
+  let unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
       unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) =
         let self = C.Reference.Id oId i
             dependencies :: Set S.Reference =
@@ -1903,8 +2074,9 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT
                       ++ map getSTermLink tmLinks
                       ++ map getTypeSRef (tpRefs ++ tpRefs')
                       ++ map getSTypeLink tpLinks
-         in Set.map (,self) dependencies
-  traverse_ (uncurry addToDependentsIndex) dependencies
+         in (dependencies, self)
+  for_ (map unlocalizeRefs (sTermElements `zip` [0 ..])) \(dependencies, dependent) ->
+    addToDependentsIndex (Set.toList dependencies) dependent
   for_ ((snd <$> terms) `zip` [0 ..]) \(tp, i) -> do
     let self = C.Referent.RefId (C.Reference.Id oId i)
         typeForIndexing = toReference tp
@@ -1936,8 +2108,7 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
          in S.putBytes Serialization.putDeclFormat $ S.Decl.Decl li
   oId <- saveObject hh hashId ObjectType.DeclComponent bytes
   -- populate dependents index
-  let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..])
-      unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
+  let unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
       unlocalizeRefs ((LocalIds tIds oIds, decl), i) =
         let self = C.Reference.Id oId i
             dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
@@ -1946,8 +2117,9 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
               C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
               C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
               C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
-         in Set.map ((,self) . getSRef) dependencies
-  traverse_ (uncurry addToDependentsIndex) dependencies
+         in (Set.map getSRef dependencies, self)
+  for_ (map unlocalizeRefs (sDeclElements `zip` [0 ..])) \(dependencies, dependent) ->
+    addToDependentsIndex (Set.toList dependencies) dependent
   for_ ((fmap C.Decl.constructorTypes decls) `zip` [0 ..]) \(ctors, i) ->
     for_ (ctors `zip` [0 ..]) \(tp, j) -> do
       let self = C.Referent.ConId (C.Reference.Id oId i) j

codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs

@@ -265,9 +265,8 @@ trySync hh runSrc runDest tCache hCache oCache cCache = \case
     syncDependenciesIndex :: Sqlite.Reference.Id -> Sqlite.Reference.Id -> m ()
     syncDependenciesIndex ref ref' = do
       deps <- runSrc (Q.getDependenciesForDependent ref)
-      for_ deps \dep -> do
-        dep' <- expectSyncedObjectReference dep
-        runDest (Q.addToDependentsIndex dep' ref')
+      deps' <- for deps expectSyncedObjectReference
+      runDest (Q.addToDependentsIndex deps' ref')
 
     syncLocalIds :: L.LocalIds -> ValidateT (Set Entity) m L.LocalIds
     syncLocalIds (L.LocalIds tIds oIds) = do

codebase2/codebase/U/Codebase/ShortHash.hs

@@ -2,7 +2,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module U.Codebase.ShortHash where
+module U.Codebase.ShortHash
+  ( ShortHash (..),
+    ShortCausalHash (..),
+    ShortNamespaceHash (..),
+    shortenTo,
+  )
+where
 
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -20,7 +26,11 @@ data ShortHash
   | ShortHash {prefix :: Text, cycle :: Maybe Word64, cid :: Maybe Word64}
   deriving (Eq, Ord, Show)
 
-data ShortBranchHash = ShortBranchHash {toText :: Text} deriving (Eq, Ord, Show)
+newtype ShortCausalHash = ShortCausalHash {shortCausalHashToText :: Text}
+  deriving stock (Eq, Ord, Show)
+
+newtype ShortNamespaceHash = ShortNamespaceHash {shortNamespaceHashToText :: Text}
+  deriving stock (Eq, Ord, Show)
 
 shortenTo :: Int -> ShortHash -> ShortHash
 shortenTo _ b@(Builtin _) = b

codebase2/core/U/Core/ABT.hs

@@ -171,7 +171,7 @@ visit' f t = case out t of
 
 -- | Apply an effectful function to an ABT tree top down, sequencing the results.
 visit_ ::
-  (Traversable f, Monad g, Ord v) =>
+  (Traversable f, Applicative g, Ord v) =>
   (f (Term f v a) -> g ()) ->
   Term f v a ->
   g (Term f v a)
@@ -179,7 +179,7 @@ visit_ f t = case out t of
   Var _ -> pure t
   Cycle body -> cycle (annotation t) <$> visit_ f body
   Abs x e -> abs (annotation t) x <$> visit_ f e
-  Tm body -> f body >> tm (annotation t) <$> traverse (visit_ f) body
+  Tm body -> f body *> (tm (annotation t) <$> traverse (visit_ f) body)
 
 -- | `visit` specialized to the `Identity` effect.
 visitPure ::

codebase2/util/src/U/Util/Monoid.hs

@@ -1,6 +1,7 @@
 module U.Util.Monoid where
 
 import Control.Monad (foldM)
+import Control.Monad.Extra ((>=>))
 import Data.Foldable (toList)
 import Data.List (intersperse)
 
@@ -10,6 +11,9 @@ intercalateMap :: (Foldable t, Monoid a) => a -> (b -> a) -> t b -> a
 intercalateMap separator renderer elements =
   mconcat $ intersperse separator (renderer <$> toList elements)
 
+intercalateMapM :: (Traversable t, Monad m, Monoid a) => a -> (b -> m a) -> t b -> m a
+intercalateMapM separator renderer = traverse renderer >=> return . intercalateMap separator id
+
 fromMaybe :: Monoid a => Maybe a -> a
 fromMaybe Nothing = mempty
 fromMaybe (Just a) = a
@@ -24,4 +28,4 @@ isEmpty a = a == mempty
 nonEmpty = not . isEmpty
 
 foldMapM :: (Monad m, Foldable f, Monoid b) => (a -> m b) -> f a -> m b
-foldMapM f as = foldM (\b a -> fmap (b <>) (f a)) mempty as
+foldMapM f = foldM (\b a -> fmap (b <>) (f a)) mempty

docs/configuration.md

@@ -0,0 +1,103 @@
+# Configuration
+
+
+* [UCM Configuration](#ucm-configuration)
+    * [`UNISON_DEBUG`](#unison_debug)
+    * [`UNISON_PAGER`](#unison_pager)
+    * [`UNISON_LSP_PORT`](#unison_lsp_port)
+    * [`UNISON_SHARE_HOST`](#unison_share_host)
+    * [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token)
+    * [Local Codebase Server](#local-codebase-server)
+* [Codebase Configuration](#codebase-configuration)
+
+## UCM Configuration
+
+### `UNISON_DEBUG`
+
+Enable debugging output for various portions of the application. 
+See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags.
+
+E.g.
+
+```sh
+# Enable ALL debugging flags (likely quite noisy)
+$ UNISON_DEBUG= ucm
+# Enable timing debugging, printing how long different actions take.
+$ UNISON_DEBUG=timing ucm
+# Enable LSP and TIMING debugging
+$ UNISON_DEBUG=lsp,timing ucm
+```
+
+### `UNISON_PAGER`
+
+Allows selecting which pager to use for long command outputs.
+Defaults to `less` on Linux & Mac, `more` on Windows
+
+E.g.
+
+```sh
+# User more instead of less
+$ UNISON_PAGER=more ucm
+```
+
+### `UNISON_LSP_PORT`
+
+Allows selecting the port to run the LSP server on. Defaults to `5757`.
+
+E.g.
+
+```sh
+$ UNISON_LSP_PORT=8080 ucm
+```
+
+### `UNISON_SHARE_HOST`
+
+Allows selecting the location for the default Share server.
+
+E.g.
+
+```sh
+$ UNISON_SHARE_HOST="http://localhost:5424" ucm
+```
+
+### `UNISON_SHARE_ACCESS_TOKEN`
+
+Allows overriding the credentials used when authenticating with the Share server.
+
+E.g.
+
+```sh
+$ UNISON_SHARE_ACCESS_TOKEN="my.token.string" ucm
+```
+
+### Local Codebase Server
+
+The port, host and token to be used for the local codebase server can all be configured by providing environment
+variables when starting `ucm`, using `UCM_PORT`, `UCM_HOST`, and `UCM_TOKEN`.
+
+E.g.
+
+```sh
+UCM_PORT=8080 UCM_HOST=localhost UCM_TOKEN=1234 ucm
+```
+
+## Codebase Configuration
+
+Also, see the guide [here](https://www.unison-lang.org/learn/tooling/configuration/)
+
+The following configuration options can be provided within the `.unisonConfig` file,
+which exists within the codebase directory, or at `~/.unisonConfig` for your default codebase.
+
+```
+# Attach myself as author and use BSD license for all of my contributions
+DefaultMetadata = [ ".metadata.authors.chrispenner"
+                  , ".metadata.licenses.chrispenner" ]
+
+# RemoteMapping allows mapping a path in the codebase to a specific location on share.
+# Here I state that I want my .share namespace to push to .chrispenner.public
+# Everything inside .share will be mapped accordingly, e.g. .share.foo will map to
+# chrispenner.public.foo on share.
+RemoteMapping {
+  share = "chrispenner.public"
+}
+```

docs/language-server.markdown

@@ -6,9 +6,9 @@
 
 Supported features:
 
-* Show type on hover
+* Autocompletion
 * Inline type and parser error messages
-* NO autocomplete yet, but soon.
+* Show type on hover
 
 Notes:
 
@@ -30,7 +30,8 @@ Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the fo
     "unison": {
       "filetypes": ["unison"],
       "host": "127.0.0.1",
-      "port": 5757
+      "port": 5757,
+      "settings": {}
     }
   }
 ```
@@ -39,5 +40,25 @@ Note that you'll need to start UCM _before_ you try connecting to it in your edi
 
 ### VSCode
 
-VSCode doesn't allow customizing LSP implementations without an extension,
-Hang tight, one will be available soon!
+Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison).
+
+
+### Other Editors
+
+If your editor provides a mechanism for connecting to a host and port, provide a host of `127.0.0.1` and port `5757`.
+
+If your editor requires a command to run, you can provide the command `nc localhost 5757` on Mac, or `netcat localhost 5757` on linux.
+Note that some editors require passing the command and arguments as separate parameters.
+
+## Configuration
+
+Supported settings and their defaults. See information for your language server client about where to provide these.
+
+```json
+{
+  // The number of completions the server should collect and send based on a single query.
+  // Increasing this limit will provide more completion results, but at the cost of being slower to respond.
+  // If explicitly set to `null` the server will return ALL completions available.
+  "maxCompletions": 100
+}
+```

hie.yaml

@@ -51,6 +51,12 @@ cradle:
     - path: "lib/unison-util-base32hex-orphans-sqlite/src"
       component: "unison-util-base32hex-orphans-sqlite:lib"
 
+    - path: "lib/unison-util-bytes/src"
+      component: "unison-util-bytes:lib"
+
+    - path: "lib/unison-util-bytes/test"
+      component: "unison-util-bytes:test:util-bytes-tests"
+
     - path: "lib/unison-util-relation/src"
       component: "unison-util-relation:lib"
 
@@ -60,6 +66,9 @@ cradle:
     - path: "lib/unison-util-relation/benchmarks/relation/Main.hs"
       component: "unison-util-relation:bench:relation"
 
+    - path: "lib/unison-util-rope/src"
+      component: "unison-util-rope:lib"
+
     - path: "parser-typechecker/src"
       component: "unison-parser-typechecker:lib"
 
@@ -102,6 +111,12 @@ cradle:
     - path: "unison-share-api/src"
       component: "unison-share-api:lib"
 
+    - path: "unison-syntax/src"
+      component: "unison-syntax:lib"
+
+    - path: "unison-syntax/test"
+      component: "unison-syntax:test:syntax-tests"
+
     - path: "yaks/easytest/src"
       component: "easytest:lib"
 

lib/unison-prelude/src/Unison/Debug.hs

@@ -34,6 +34,9 @@ data DebugFlag
     LSP
   | -- | Timing how long things take
     Timing
+  | -- | Useful for adding temporary debugging statements during development.
+    -- Remove uses of Debug.Temp before merging to keep things clean for the next person :)
+    Temp
   deriving (Eq, Ord, Show, Bounded, Enum)
 
 debugFlags :: Set DebugFlag
@@ -54,6 +57,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
       "SYNC" -> pure Sync
       "LSP" -> pure LSP
       "TIMING" -> pure Timing
+      "TEMP" -> pure Temp
       _ -> empty
 {-# NOINLINE debugFlags #-}
 
@@ -93,6 +97,10 @@ debugTiming :: Bool
 debugTiming = Timing `Set.member` debugFlags
 {-# NOINLINE debugTiming #-}
 
+debugTemp :: Bool
+debugTemp = Temp `Set.member` debugFlags
+{-# NOINLINE debugTemp #-}
+
 -- | Use for trace-style selective debugging.
 -- E.g. 1 + (debug Git "The second number" 2)
 --
@@ -142,3 +150,4 @@ shouldDebug = \case
   Sync -> debugSync
   LSP -> debugLSP
   Timing -> debugTiming
+  Temp -> debugTemp

lib/unison-pretty-printer/src/Unison/Util/Pretty.hs

@@ -40,6 +40,7 @@ module Unison.Util.Pretty
     column3UnzippedM,
     column3sep,
     column3Header,
+    columnNHeader,
     commas,
     commented,
     oxfordCommas,
@@ -101,6 +102,7 @@ module Unison.Util.Pretty
     spaceIfNeeded,
     spaced,
     spacedMap,
+    spacedTraverse,
     spacesIfBreak,
     string,
     surroundCommas,
@@ -405,6 +407,9 @@ spaced = intercalateMap softbreak id
 spacedMap :: (Foldable f, IsString s) => (a -> Pretty s) -> f a -> Pretty s
 spacedMap f as = spaced . fmap f $ toList as
 
+spacedTraverse :: (Traversable f, IsString s, Applicative m) => (a -> m (Pretty s)) -> f a -> m (Pretty s)
+spacedTraverse f as = spaced <$> traverse f as
+
 commas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
 commas = intercalateMap ("," <> softbreak) id
 
@@ -469,7 +474,7 @@ excerptSep' ::
 excerptSep' maxCount summarize s ps = case maxCount of
   Just max
     | length ps > max ->
-        sep s (take max ps) <> summarize (length ps - max)
+      sep s (take max ps) <> summarize (length ps - max)
   _ -> sep s ps
 
 nonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> [Pretty s]
@@ -579,7 +584,7 @@ excerptColumn2Headed ::
 excerptColumn2Headed max hd cols = case max of
   Just max
     | len > max ->
-        lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
+      lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
   _ -> column2 (hd : cols)
   where
     len = length cols

lib/unison-util-bytes/package.yaml

@@ -0,0 +1,67 @@
+name: unison-util-bytes
+github: unisonweb/unison
+copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
+
+ghc-options: -Wall
+
+dependencies:
+  - base
+  - basement
+  - bytestring
+  - bytestring-to-vector
+  - deepseq
+  - memory
+  - primitive
+  - text
+  - vector
+  - unison-prelude
+  - unison-util-rope
+  - zlib
+
+library:
+  source-dirs: src
+  when:
+    - condition: false
+      other-modules: Paths_unison_util_bytes
+
+tests:
+  util-bytes-tests:
+    when:
+      - condition: false
+        other-modules: Paths_unison_util_bytes
+    dependencies:
+      - code-page
+      - easytest
+      - unison-util-bytes
+    main: Main.hs
+    source-dirs: test
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DeriveAnyClass
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - DerivingVia
+  - DoAndIfThenElse
+  - DuplicateRecordFields
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - OverloadedStrings
+  - PatternSynonyms
+  - RankNTypes
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - ViewPatterns

lib/unison-util-bytes/src/Unison/Util/Bytes.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 

lib/unison-util-bytes/test/Main.hs

@@ -1,14 +1,18 @@
-module Unison.Test.Util.Bytes where
+module Main (main) where
 
-import Control.Monad
 import qualified Data.ByteString as BS
-import Data.List (foldl')
 import EasyTest
+import System.IO.CodePage (withCP65001)
+import Unison.Prelude
 import qualified Unison.Util.Bytes as Bytes
 
+main :: IO ()
+main =
+  withCP65001 (run (scope "util.bytes" test))
+
 test :: Test ()
 test =
-  scope "util.bytes" . tests $
+  tests $
     [ scope "empty ==" . expect $ Bytes.empty == Bytes.empty,
       scope "empty `compare`" . expect $ Bytes.empty `compare` Bytes.empty == EQ,
       scope "==" . expect $

lib/unison-util-bytes/unison-util-bytes.cabal

@@ -0,0 +1,119 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           unison-util-bytes
+version:        0.0.0
+homepage:       https://github.com/unisonweb/unison#readme
+bug-reports:    https://github.com/unisonweb/unison/issues
+copyright:      Copyright (C) 2013-2022 Unison Computing, PBC and contributors
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/unisonweb/unison
+
+library
+  exposed-modules:
+      Unison.Util.Bytes
+  hs-source-dirs:
+      src
+  default-extensions:
+      ApplicativeDo
+      BangPatterns
+      BlockArguments
+      DeriveAnyClass
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      DoAndIfThenElse
+      DuplicateRecordFields
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NamedFieldPuns
+      OverloadedStrings
+      PatternSynonyms
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      ViewPatterns
+  ghc-options: -Wall
+  build-depends:
+      base
+    , basement
+    , bytestring
+    , bytestring-to-vector
+    , deepseq
+    , memory
+    , primitive
+    , text
+    , unison-prelude
+    , unison-util-rope
+    , vector
+    , zlib
+  default-language: Haskell2010
+
+test-suite util-bytes-tests
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  hs-source-dirs:
+      test
+  default-extensions:
+      ApplicativeDo
+      BangPatterns
+      BlockArguments
+      DeriveAnyClass
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      DoAndIfThenElse
+      DuplicateRecordFields
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NamedFieldPuns
+      OverloadedStrings
+      PatternSynonyms
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      ViewPatterns
+  ghc-options: -Wall
+  build-depends:
+      base
+    , basement
+    , bytestring
+    , bytestring-to-vector
+    , code-page
+    , deepseq
+    , easytest
+    , memory
+    , primitive
+    , text
+    , unison-prelude
+    , unison-util-bytes
+    , unison-util-rope
+    , vector
+    , zlib
+  default-language: Haskell2010

lib/unison-util-rope/package.yaml

@@ -0,0 +1,45 @@
+name: unison-util-rope
+github: unisonweb/unison
+copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
+
+ghc-options: -Wall
+
+dependencies:
+  - base
+  - deepseq
+
+library:
+  source-dirs: src
+  when:
+    - condition: false
+      other-modules: Paths_unison_util_rope
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DeriveAnyClass
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - DerivingVia
+  - DoAndIfThenElse
+  - DuplicateRecordFields
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - OverloadedStrings
+  - PatternSynonyms
+  - RankNTypes
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - ViewPatterns

lib/unison-util-rope/src/Unison/Util/Rope.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE FunctionalDependencies #-}
-
 module Unison.Util.Rope
   ( chunks,
     singleton,

lib/unison-util-rope/unison-util-rope.cabal

@@ -0,0 +1,56 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           unison-util-rope
+version:        0.0.0
+homepage:       https://github.com/unisonweb/unison#readme
+bug-reports:    https://github.com/unisonweb/unison/issues
+copyright:      Copyright (C) 2013-2022 Unison Computing, PBC and contributors
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/unisonweb/unison
+
+library
+  exposed-modules:
+      Unison.Util.Rope
+  hs-source-dirs:
+      src
+  default-extensions:
+      ApplicativeDo
+      BangPatterns
+      BlockArguments
+      DeriveAnyClass
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      DoAndIfThenElse
+      DuplicateRecordFields
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NamedFieldPuns
+      OverloadedStrings
+      PatternSynonyms
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      ViewPatterns
+  ghc-options: -Wall
+  build-depends:
+      base
+    , deepseq
+  default-language: Haskell2010

parser-typechecker/package.yaml

@@ -45,6 +45,7 @@ dependencies:
   - fingertree
   - fsnotify
   - fuzzyfind
+  - free
   - generic-lens
   - generic-monoid
   - hashable
@@ -111,9 +112,12 @@ dependencies:
   - unison-prelude
   - unison-pretty-printer
   - unison-sqlite
+  - unison-syntax
   - unison-util
   - unison-util-base32hex
+  - unison-util-bytes
   - unison-util-relation
+  - unison-util-rope
   - unison-util-serialization
   - unliftio
   - uri-encode

parser-typechecker/src/U/Codebase/Branch/Diff.hs

@@ -0,0 +1,174 @@
+module U.Codebase.Branch.Diff
+  ( TreeDiff (..),
+    NameChanges (..),
+    DefinitionDiffs (..),
+    Diff (..),
+    diffBranches,
+    nameChanges,
+  )
+where
+
+import Control.Comonad.Cofree
+import Control.Lens (ifoldMap)
+import qualified Control.Lens as Lens
+import qualified Data.Map as Map
+import qualified Data.Semialign as Align
+import qualified Data.Set as Set
+import Data.These
+import U.Codebase.Branch
+import qualified U.Codebase.Branch.Type as Branch
+import qualified U.Codebase.Causal as Causal
+import U.Codebase.Reference (Reference)
+import U.Codebase.Referent (Referent)
+import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
+import Unison.Name (Name)
+import qualified Unison.Name as Name
+import Unison.Prelude
+
+data Diff a = Diff
+  { adds :: Set a,
+    removals :: Set a
+  }
+  deriving (Show, Eq, Ord)
+
+-- | Represents the changes to definitions at a given path, not including child paths.
+--
+-- Note: doesn't yet include any info on metadata or patch diffs. Feel free to add it.
+data DefinitionDiffs = DefinitionDiffs
+  { termDiffs :: Map NameSegment (Diff Referent),
+    typeDiffs :: Map NameSegment (Diff Reference)
+    -- termMetadataDiffs :: Map (NameSegment, Referent) (Diff Reference),
+    -- typeMetadataDiffs :: Map (NameSegment, Reference) (Diff Reference)
+    -- patchDiffs :: Map NameSegment (Diff ())
+  }
+  deriving stock (Show, Eq, Ord)
+
+instance Semigroup DefinitionDiffs where
+  a <> b =
+    DefinitionDiffs
+      { termDiffs = termDiffs a <> termDiffs b,
+        typeDiffs = typeDiffs a <> typeDiffs b
+      }
+
+instance Monoid DefinitionDiffs where
+  mempty = DefinitionDiffs mempty mempty
+
+-- | A tree of local diffs. Each node of the tree contains the definition diffs at that path.
+newtype TreeDiff = TreeDiff
+  { unTreeDiff :: Cofree (Map NameSegment) DefinitionDiffs
+  }
+  deriving stock (Show, Eq, Ord)
+
+instance Semigroup TreeDiff where
+  TreeDiff (a :< as) <> TreeDiff (b :< bs) =
+    TreeDiff $ (a <> b) :< (Map.unionWith mergeCofrees as bs)
+    where
+      mergeCofrees x y = unTreeDiff (TreeDiff x <> TreeDiff y)
+
+instance Monoid TreeDiff where
+  mempty = TreeDiff (mempty :< mempty)
+
+instance Lens.AsEmpty TreeDiff where
+  _Empty = Lens.only mempty
+
+-- | A summary of a 'TreeDiff', containing all names added and removed.
+-- Note that there isn't a clear notion of a name "changing" since conflicts might muddy the notion
+-- by having multiple copies of both the from and to names, so we just talk about adds and
+-- removals instead.
+data NameChanges = NameChanges
+  { termNameAdds :: [(Name, Referent)],
+    termNameRemovals :: [(Name, Referent)],
+    typeNameAdds :: [(Name, Reference)],
+    typeNameRemovals :: [(Name, Reference)]
+  }
+
+instance Semigroup NameChanges where
+  (NameChanges a b c d) <> (NameChanges a2 b2 c2 d2) =
+    NameChanges (a <> a2) (b <> b2) (c <> c2) (d <> d2)
+
+instance Monoid NameChanges where
+  mempty = NameChanges mempty mempty mempty mempty
+
+-- | Diff two Branches, returning a tree containing all of the changes
+diffBranches :: forall m. Monad m => Branch m -> Branch m -> m TreeDiff
+diffBranches from to = do
+  let termDiffs = diffMap (terms from) (terms to)
+  let typeDiffs = diffMap (types from) (types to)
+  let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
+  childDiff <- do
+    Align.align (children from) (children to)
+      & wither
+        ( \case
+            This ca -> do
+              -- TODO: For the names index we really don't need to know which exact
+              -- names were removed, we just need to delete from the index using a
+              -- prefix query, this would be faster than crawling to get all the deletes.
+              removedChildBranch <- Causal.value ca
+              Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
+            That ca -> do
+              newChildBranch <- Causal.value ca
+              Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
+            These fromC toC
+              | Causal.valueHash fromC == Causal.valueHash toC -> do
+                  -- This child didn't change.
+                  pure Nothing
+              | otherwise -> do
+                  fromChildBranch <- Causal.value fromC
+                  toChildBranch <- Causal.value toC
+                  diffBranches fromChildBranch toChildBranch >>= \case
+                    Lens.Empty -> pure Nothing
+                    TreeDiff cfr -> pure . Just $ cfr
+        )
+  pure $ TreeDiff (defDiff :< childDiff)
+  where
+    diffMap :: forall ref. Ord ref => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
+    diffMap l r =
+      Align.align l r
+        & fmap
+          ( \case
+              (This refs) -> (Diff {removals = Map.keysSet refs, adds = mempty})
+              (That refs) -> (Diff {removals = mempty, adds = Map.keysSet refs})
+              (These l' r') ->
+                let lRefs = Map.keysSet l'
+                    rRefs = Map.keysSet r'
+                 in (Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs})
+          )
+
+-- | Get a summary of all of the name adds and removals from a tree diff.
+--
+-- The provided name will be prepended to all names in the output diff, and can be useful if diffing branches at a
+-- specific sub-tree, but you can pass 'Nothing' if you're diffing from the root.
+nameChanges ::
+  Maybe Name ->
+  TreeDiff ->
+  NameChanges
+nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) =
+  let (termNameAdds, termNameRemovals) =
+        ( termDiffs
+            & ifoldMap \ns diff ->
+              let name = appendName ns
+               in (listifyNames name $ adds diff, listifyNames name $ removals diff)
+        )
+      (typeNameAdds, typeNameRemovals) =
+        ( typeDiffs
+            & ifoldMap \ns diff ->
+              let name = appendName ns
+               in (listifyNames name $ adds diff, listifyNames name $ removals diff)
+        )
+      childNameChanges =
+        ( children
+            & ifoldMap \ns childTree ->
+              nameChanges (Just $ appendName ns) (TreeDiff childTree)
+        )
+   in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges
+  where
+    appendName :: NameSegment -> Name
+    appendName ns =
+      case namePrefix of
+        Nothing -> Name.fromSegment . Cv.namesegment2to1 $ ns
+        Just prefix -> prefix Lens.|> Cv.namesegment2to1 ns
+    listifyNames :: (Name -> Set ref -> [(Name, ref)])
+    listifyNames name xs =
+      xs
+        & Set.toList
+        & fmap (name,)

parser-typechecker/src/Unison/Codebase.hs

@@ -12,6 +12,7 @@ module Unison.Codebase
     unsafeGetTypeOfTermById,
     isTerm,
     putTerm,
+    putTermComponent,
     termMetadata,
 
     -- ** Referents (sorta-termlike)
@@ -28,6 +29,7 @@ module Unison.Codebase
     unsafeGetTypeDeclaration,
     getDeclComponent,
     putTypeDeclaration,
+    putTypeDeclarationComponent,
     typeReferencesByPrefix,
     isType,
 
@@ -35,7 +37,7 @@ module Unison.Codebase
     branchExists,
     getBranchForHash,
     putBranch,
-    branchHashesByPrefix,
+    causalHashesByPrefix,
     lca,
     beforeImpl,
     getShallowBranchAtPath,
@@ -273,7 +275,7 @@ debug :: Bool
 debug = False
 
 -- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase
-installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m ()
+installUcmDependencies :: Codebase m Symbol Parser.Ann -> Sqlite.Transaction ()
 installUcmDependencies c = do
   let uf =
         ( UF.typecheckedUnisonFile
@@ -288,10 +290,10 @@ installUcmDependencies c = do
 -- if it makes sense to later.
 addDefsToCodebase ::
   forall m v a.
-  (Monad m, Var v, Show a) =>
+  (Var v, Show a) =>
   Codebase m v a ->
   UF.TypecheckedUnisonFile v a ->
-  m ()
+  Sqlite.Transaction ()
 addDefsToCodebase c uf = do
   traverse_ (goType Right) (UF.dataDeclarationsId' uf)
   traverse_ (goType Left) (UF.effectDeclarationsId' uf)
@@ -302,11 +304,11 @@ addDefsToCodebase c uf = do
     goTerm (r, Nothing, tm, tp) = putTerm c r tm tp
     goTerm (r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp
     goTerm _ = pure ()
-    goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> m ()
+    goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> Sqlite.Transaction ()
     goType _f pair | debug && trace ("Codebase.addDefsToCodebase.goType " ++ show pair) False = undefined
     goType f (ref, decl) = putTypeDeclaration c ref (f decl)
 
-getTypeOfConstructor :: (Monad m, Ord v) => Codebase m v a -> ConstructorReference -> m (Maybe (Type v a))
+getTypeOfConstructor :: Ord v => Codebase m v a -> ConstructorReference -> Sqlite.Transaction (Maybe (Type v a))
 getTypeOfConstructor codebase (ConstructorReference r0 cid) =
   case r0 of
     Reference.DerivedId r -> do
@@ -330,10 +332,10 @@ lookupWatchCache codebase h = do
   maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
 
 typeLookupForDependencies ::
-  (Monad m, BuiltinAnnotation a) =>
+  BuiltinAnnotation a =>
   Codebase m Symbol a ->
   Set Reference ->
-  m (TL.TypeLookup Symbol a)
+  Sqlite.Transaction (TL.TypeLookup Symbol a)
 typeLookupForDependencies codebase s = do
   when debug $ traceM $ "typeLookupForDependencies " ++ show s
   foldM go mempty s
@@ -351,9 +353,9 @@ typeLookupForDependencies codebase s = do
               Nothing -> pure mempty
     go tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins
 
-toCodeLookup :: Monad m => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
+toCodeLookup :: MonadIO m => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
 toCodeLookup c =
-  CL.CodeLookup (getTerm c) (getTypeDeclaration c)
+  CL.CodeLookup (getTerm c) (runTransaction c . getTypeDeclaration c)
     <> Builtin.codeLookup
     <> IOSource.codeLookupM
 
@@ -362,10 +364,10 @@ toCodeLookup c =
 -- Note that it is possible to call 'putTerm', then 'getTypeOfTerm', and receive @Nothing@, per the semantics of
 -- 'putTerm'.
 getTypeOfTerm ::
-  (Applicative m, BuiltinAnnotation a) =>
+  BuiltinAnnotation a =>
   Codebase m Symbol a ->
   Reference ->
-  m (Maybe (Type Symbol a))
+  Sqlite.Transaction (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
@@ -376,10 +378,10 @@ getTypeOfTerm c r = case r of
 
 -- | Get the type of a referent.
 getTypeOfReferent ::
-  (BuiltinAnnotation a, Monad m) =>
+  BuiltinAnnotation a =>
   Codebase m Symbol a ->
   Referent.Referent ->
-  m (Maybe (Type Symbol a))
+  Sqlite.Transaction (Maybe (Type Symbol a))
 getTypeOfReferent c = \case
   Referent.Ref r -> getTypeOfTerm c r
   Referent.Con r _ -> getTypeOfConstructor c r
@@ -392,7 +394,7 @@ componentReferencesForReference c = \case
 
 -- | Get the set of terms, type declarations, and builtin types that depend on the given term, type declaration, or
 -- builtin type.
-dependents :: Functor m => Codebase m v a -> Queries.DependentsSelector -> Reference -> m (Set Reference)
+dependents :: Codebase m v a -> Queries.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference)
 dependents c selector r =
   Set.union (Builtin.builtinTypeDependents r)
     . Set.map Reference.DerivedId
@@ -426,13 +428,13 @@ termsMentioningType c ty =
 
 -- | Check whether a reference is a term.
 isTerm ::
-  (Applicative m, BuiltinAnnotation a) =>
+  BuiltinAnnotation a =>
   Codebase m Symbol a ->
   Reference ->
-  m Bool
+  Sqlite.Transaction Bool
 isTerm code = fmap isJust . getTypeOfTerm code
 
-isType :: Applicative m => Codebase m v a -> Reference -> m Bool
+isType :: Codebase m v a -> Reference -> Sqlite.Transaction Bool
 isType c r = case r of
   Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
   Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
@@ -446,7 +448,7 @@ data Preprocessing m
   | Preprocessed (Branch m -> m (Branch m))
 
 -- | Sync elements as needed from a remote git codebase into the local one.
--- If `sbh` is supplied, we try to load the specified branch hash;
+-- If `sch` is supplied, we try to load the specified branch hash;
 -- otherwise we try to load the root branch.
 importRemoteBranch ::
   forall m v a.
@@ -499,21 +501,21 @@ unsafeGetTerm codebase rid =
     Just term -> pure term
 
 -- | Like 'getTypeDeclaration', for when the type declaration is known to exist in the codebase.
-unsafeGetTypeDeclaration :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Decl v a)
+unsafeGetTypeDeclaration :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Decl v a)
 unsafeGetTypeDeclaration codebase rid =
   getTypeDeclaration codebase rid >>= \case
     Nothing -> error (reportBug "E129043" ("type decl " ++ show rid ++ " not found"))
     Just decl -> pure decl
 
 -- | Like 'getTypeOfTerm', but for when the term is known to exist in the codebase.
-unsafeGetTypeOfTermById :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Type v a)
+unsafeGetTypeOfTermById :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Type v a)
 unsafeGetTypeOfTermById codebase rid =
   getTypeOfTermImpl codebase rid >>= \case
     Nothing -> error (reportBug "E377910" ("type of term " ++ show rid ++ " not found"))
     Just ty -> pure ty
 
 -- | Like 'unsafeGetTerm', but returns the type of the term, too.
-unsafeGetTermWithType :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
+unsafeGetTermWithType :: (HasCallStack, MonadIO m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
 unsafeGetTermWithType codebase rid = do
   term <- unsafeGetTerm codebase rid
   ty <-
@@ -521,7 +523,7 @@ unsafeGetTermWithType codebase rid = do
     -- inferred type). In this case, we can avoid looking up the type separately.
     case term of
       Term.Ann' _ ty -> pure ty
-      _ -> unsafeGetTypeOfTermById codebase rid
+      _ -> runTransaction codebase (unsafeGetTypeOfTermById codebase rid)
   pure (term, ty)
 
 -- | Like 'getTermComponentWithTypes', for when the term component is known to exist in the codebase.

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

@@ -28,7 +28,6 @@ module Unison.Codebase.Branch
 
     -- * Branch tests
     isEmpty,
-    isEmpty0,
     isOne,
     before,
     lca,
@@ -85,12 +84,16 @@ module Unison.Codebase.Branch
 where
 
 import Control.Lens hiding (children, cons, transform, uncons)
+import Control.Monad.State (State)
+import qualified Control.Monad.State as State
 import Data.Bifunctor (second)
+import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 import qualified Data.Semialign as Align
+import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
 import Data.These (These (..))
-import U.Codebase.Branch (NamespaceStats (..))
+import U.Codebase.Branch.Type (NamespaceStats (..))
 import Unison.Codebase.Branch.Raw (Raw)
 import Unison.Codebase.Branch.Type
   ( Branch (..),
@@ -104,6 +107,7 @@ import Unison.Codebase.Branch.Type
     head,
     headHash,
     history,
+    namespaceHash,
   )
 import Unison.Codebase.Causal (Causal)
 import qualified Unison.Codebase.Causal as Causal
@@ -121,7 +125,7 @@ import Unison.Prelude hiding (empty)
 import Unison.Reference (TypeReference)
 import Unison.Referent (Referent)
 import qualified Unison.Util.List as List
-import Unison.Util.Relation (Relation)
+import qualified Unison.Util.Monoid as Monoid
 import qualified Unison.Util.Relation as R
 import qualified Unison.Util.Relation as Relation
 import qualified Unison.Util.Relation4 as R4
@@ -193,6 +197,11 @@ branch0 terms types children edits =
       _types = types,
       _children = children,
       _edits = edits,
+      isEmpty0 =
+        R.null (Star3.d1 terms)
+          && R.null (Star3.d1 types)
+          && Map.null edits
+          && all (isEmpty0 . head) children,
       -- These are all overwritten immediately
       deepTerms = R.empty,
       deepTypes = R.empty,
@@ -211,80 +220,157 @@ branch0 terms types children edits =
 -- | Derive the 'deepTerms' field of a branch.
 deriveDeepTerms :: Branch0 m -> Branch0 m
 deriveDeepTerms branch =
-  branch {deepTerms = makeDeepTerms (_terms branch) (nonEmptyChildren branch)}
+  branch {deepTerms = R.fromList (makeDeepTerms branch)}
   where
-    makeDeepTerms :: Metadata.Star Referent NameSegment -> Map NameSegment (Branch m) -> Relation Referent Name
-    makeDeepTerms terms children =
-      R.mapRanMonotonic Name.fromSegment (Star3.d1 terms) <> ifoldMap go children
+    makeDeepTerms :: Branch0 m -> [(Referent, Name)]
+    makeDeepTerms branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Relation Referent Name
-        go n b =
-          R.mapRan (Name.cons n) (deepTerms $ head b)
+        -- `reversePrefix` might be ["Nat", "base", "lib"], and `b0` the `Nat` sub-namespace.
+        -- Then `R.toList` might produce the NameSegment "+", and we put the two together to
+        -- construct the name `Name Relative ("+" :| ["Nat","base","lib"])`.
+        go ::
+          forall m.
+          Seq (DeepChildAcc m) ->
+          [(Referent, Name)] ->
+          DeepState m [(Referent, Name)]
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let terms :: [(Referent, Name)]
+              terms =
+                map
+                  (second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix)))
+                  (R.toList (Star3.d1 (_terms b0)))
+          children <- deepChildrenHelper e
+          go (work <> children) (terms <> acc)
 
 -- | Derive the 'deepTypes' field of a branch.
-deriveDeepTypes :: Branch0 m -> Branch0 m
+deriveDeepTypes :: forall m. Branch0 m -> Branch0 m
 deriveDeepTypes branch =
-  branch {deepTypes = makeDeepTypes (_types branch) (nonEmptyChildren branch)}
+  branch {deepTypes = R.fromList (makeDeepTypes branch)}
   where
-    makeDeepTypes :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Relation TypeReference Name
-    makeDeepTypes types children =
-      R.mapRanMonotonic Name.fromSegment (Star3.d1 types) <> ifoldMap go children
+    makeDeepTypes :: Branch0 m -> [(TypeReference, Name)]
+    makeDeepTypes branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Relation TypeReference Name
-        go n b =
-          R.mapRan (Name.cons n) (deepTypes $ head b)
+        go ::
+          Seq (DeepChildAcc m) ->
+          [(TypeReference, Name)] ->
+          DeepState m [(TypeReference, Name)]
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let types :: [(TypeReference, Name)]
+              types = map (second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix))) (R.toList (Star3.d1 (_types b0)))
+          children <- deepChildrenHelper e
+          go (work <> children) (types <> acc)
 
 -- | Derive the 'deepTermMetadata' field of a branch.
-deriveDeepTermMetadata :: Branch0 m -> Branch0 m
+deriveDeepTermMetadata :: forall m. Branch0 m -> Branch0 m
 deriveDeepTermMetadata branch =
-  branch {deepTermMetadata = makeDeepTermMetadata (_terms branch) (nonEmptyChildren branch)}
+  branch {deepTermMetadata = R4.fromList (makeDeepTermMetadata branch)}
   where
-    makeDeepTermMetadata :: Metadata.Star Referent NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 Referent Name
-    makeDeepTermMetadata terms children =
-      R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 terms) <> ifoldMap go children
+    makeDeepTermMetadata :: Branch0 m -> [(Referent, Name, Metadata.Type, Metadata.Value)]
+    makeDeepTermMetadata branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Metadata.R4 Referent Name
-        go n b =
-          R4.mapD2 (Name.cons n) (deepTermMetadata $ head b)
+        go ::
+          Seq (DeepChildAcc m) ->
+          [(Referent, Name, Metadata.Type, Metadata.Value)] ->
+          DeepState m [(Referent, Name, Metadata.Type, Metadata.Value)]
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let termMetadata :: [(Referent, Name, Metadata.Type, Metadata.Value)]
+              termMetadata =
+                map
+                  (\(r, n, t, v) -> (r, Name.fromReverseSegments (n NonEmpty.:| reversePrefix), t, v))
+                  (Metadata.starToR4List (_terms b0))
+          children <- deepChildrenHelper e
+          go (work <> children) (termMetadata <> acc)
 
 -- | Derive the 'deepTypeMetadata' field of a branch.
-deriveDeepTypeMetadata :: Branch0 m -> Branch0 m
+deriveDeepTypeMetadata :: forall m. Branch0 m -> Branch0 m
 deriveDeepTypeMetadata branch =
-  branch {deepTypeMetadata = makeDeepTypeMetadata (_types branch) (nonEmptyChildren branch)}
+  branch {deepTypeMetadata = R4.fromList (makeDeepTypeMetadata branch)}
   where
-    makeDeepTypeMetadata :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 TypeReference Name
-    makeDeepTypeMetadata types children =
-      R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 types) <> ifoldMap go children
+    makeDeepTypeMetadata :: Branch0 m -> [(TypeReference, Name, Metadata.Type, Metadata.Value)]
+    makeDeepTypeMetadata branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Metadata.R4 TypeReference Name
-        go n b =
-          R4.mapD2 (Name.cons n) (deepTypeMetadata $ head b)
+        go ::
+          Seq (DeepChildAcc m) ->
+          [(TypeReference, Name, Metadata.Type, Metadata.Value)] ->
+          DeepState m [(TypeReference, Name, Metadata.Type, Metadata.Value)]
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let typeMetadata :: [(TypeReference, Name, Metadata.Type, Metadata.Value)]
+              typeMetadata =
+                map
+                  (\(r, n, t, v) -> (r, Name.fromReverseSegments (n NonEmpty.:| reversePrefix), t, v))
+                  (Metadata.starToR4List (_types b0))
+          children <- deepChildrenHelper e
+          go (work <> children) (typeMetadata <> acc)
 
 -- | Derive the 'deepPaths' field of a branch.
-deriveDeepPaths :: Branch0 m -> Branch0 m
+deriveDeepPaths :: forall m. Branch0 m -> Branch0 m
 deriveDeepPaths branch =
-  branch {deepPaths = makeDeepPaths (nonEmptyChildren branch)}
+  branch {deepPaths = makeDeepPaths branch}
   where
-    makeDeepPaths :: Map NameSegment (Branch m) -> Set Path
-    makeDeepPaths children =
-      Set.mapMonotonic Path.singleton (Map.keysSet children) <> ifoldMap go children
+    makeDeepPaths :: Branch0 m -> Set Path
+    makeDeepPaths branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Set Path
-        go n b =
-          Set.map (Path.cons n) (deepPaths $ head b)
+        go :: Seq (DeepChildAcc m) -> Set Path -> DeepState m (Set Path)
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let paths :: Set Path
+              paths =
+                if isEmpty0 b0
+                  then Set.empty
+                  else (Set.singleton . Path . Seq.fromList . reverse) reversePrefix
+          children <- deepChildrenHelper e
+          go (work <> children) (paths <> acc)
 
 -- | Derive the 'deepEdits' field of a branch.
-deriveDeepEdits :: Branch0 m -> Branch0 m
+deriveDeepEdits :: forall m. Branch0 m -> Branch0 m
 deriveDeepEdits branch =
-  branch {deepEdits = makeDeepEdits (_edits branch) (nonEmptyChildren branch)}
+  branch {deepEdits = makeDeepEdits branch}
   where
-    makeDeepEdits :: Map NameSegment (EditHash, m Patch) -> Map NameSegment (Branch m) -> Map Name EditHash
-    makeDeepEdits edits children =
-      Map.mapKeysMonotonic Name.fromSegment (Map.map fst edits) <> ifoldMap go children
+    makeDeepEdits :: Branch0 m -> Map Name EditHash
+    makeDeepEdits branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
       where
-        go :: NameSegment -> Branch m -> Map Name EditHash
-        go n b =
-          Map.mapKeys (Name.cons n) (deepEdits $ head b)
+        go :: (Seq (DeepChildAcc m)) -> Map Name EditHash -> DeepState m (Map Name EditHash)
+        go Seq.Empty acc = pure acc
+        go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
+          let edits :: Map Name EditHash
+              edits =
+                Map.mapKeysMonotonic
+                  (Name.fromReverseSegments . (NonEmpty.:| reversePrefix))
+                  (fst <$> _edits b0)
+          children <- deepChildrenHelper e
+          go (work <> children) (edits <> acc)
+
+-- | State used by deepChildrenHelper to determine whether to descend into a child branch.
+-- Contains the set of visited namespace hashes.
+type DeepState m = State (Set (NamespaceHash m))
+
+-- | Represents a unit of remaining work in traversing children for computing `deep*`.
+-- (reverse prefix to a branch, the number of `lib` segments in the reverse prefix, and the branch itself)
+type DeepChildAcc m = ([NameSegment], Int, Branch0 m)
+
+-- | Helper for knowing whether to descend into a child branch or not.
+-- Accepts child namespaces with previously unseen hashes, and any nested under 1 or fewer `lib` segments.
+deepChildrenHelper :: forall m. DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
+deepChildrenHelper (reversePrefix, libDepth, b0) = do
+  let go :: (NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m))
+      go (ns, b) = do
+        let h = namespaceHash b
+        result <- do
+          let isShallowDependency = libDepth <= 1
+          isUnseenNamespace <- State.gets (Set.notMember h)
+          pure
+            if isShallowDependency || isUnseenNamespace
+              then
+                let libDepth' = if ns == "lib" then libDepth + 1 else libDepth
+                 in Seq.singleton (ns : reversePrefix, libDepth', head b)
+              else Seq.empty
+        State.modify' (Set.insert h)
+        pure result
+  Monoid.foldMapM go (Map.toList (nonEmptyChildren b0))
 
 -- | Update the head of the current causal.
 -- This re-hashes the current causal head after modifications.
@@ -360,17 +446,7 @@ one = Branch . Causal.one
 
 empty0 :: Branch0 m
 empty0 =
-  Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty
-
--- | Checks whether a Branch0 is empty, which means that the branch contains no terms or
--- types, and that the heads of all children are empty by the same definition.
--- This is not as easy as checking whether the branch is equal to the `empty0` branch
--- because child branches may be empty, but still have history.
-isEmpty0 :: Branch0 m -> Bool
-isEmpty0 (Branch0 _terms _types _children _edits deepTerms deepTypes _deepTermMetadata _deepTypeMetadata _deepPaths deepEdits) =
-  Relation.null deepTerms
-    && Relation.null deepTypes
-    && Map.null deepEdits
+  Branch0 mempty mempty mempty mempty True mempty mempty mempty mempty mempty mempty
 
 -- | Checks whether a branch is empty AND has no history.
 isEmpty :: Branch m -> Bool

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

@@ -5,6 +5,7 @@ module Unison.Codebase.Branch.Type
     CausalHash (..),
     head,
     headHash,
+    namespaceHash,
     Branch (..),
     Branch0 (..),
     history,
@@ -51,13 +52,17 @@ head (Branch c) = Causal.head c
 headHash :: Branch m -> CausalHash
 headHash (Branch c) = Causal.currentHash c
 
+namespaceHash :: Branch m -> NamespaceHash m
+namespaceHash (Branch c) = Causal.valueHash c
+
 -- | A node in the Unison namespace hierarchy.
 --
 -- '_terms' and '_types' are the declarations at this level.
 -- '_children' are the nodes one level below us.
 -- '_edits' are the 'Patch's stored at this node in the code.
 --
--- The @deep*@ fields are derived from the four above.
+-- The remaining fields are derived from the four above.
+-- Please don't set them manually; use Branch.empty0 or Branch.branch0 to construct them.
 data Branch0 m = Branch0
   { _terms :: Star Referent NameSegment,
     _types :: Star Reference NameSegment,
@@ -65,6 +70,9 @@ data Branch0 m = Branch0
     -- Every level in the tree has a history.
     _children :: Map NameSegment (Branch m),
     _edits :: Map NameSegment (EditHash, m Patch),
+    -- | True if a branch and its children have no definitions or edits in them.
+    -- (Computed recursively, and small enough to justify storing here to avoid computing more than once.)
+    isEmpty0 :: Bool,
     -- names and metadata for this branch and its children
     -- (ref, (name, value)) iff ref has metadata `value` at name `name`
     deepTerms :: Relation Referent Name,

parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs

@@ -11,8 +11,8 @@ import qualified Data.Text as Text
 import qualified U.Util.Monoid as Monoid
 import Unison.Codebase.Path (Path)
 import qualified Unison.Codebase.Path as Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
+import qualified Unison.Codebase.ShortCausalHash as SCH
 import Unison.Prelude
 import Unison.Share.Types
 
@@ -66,7 +66,7 @@ writeToReadGit = \case
 writePathToRead :: WriteRemotePath -> ReadRemoteNamespace
 writePathToRead = \case
   WriteRemotePathGit WriteGitRemotePath {repo, path} ->
-    ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sbh = Nothing, path}
+    ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path}
   WriteRemotePathShare WriteShareRemotePath {server, repo, path} ->
     ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path}
 
@@ -80,12 +80,12 @@ printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe
 -- | print remote namespace
 printNamespace :: ReadRemoteNamespace -> Text
 printNamespace = \case
-  ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} ->
-    printReadGitRepo repo <> maybePrintSBH sbh <> maybePrintPath path
+  ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} ->
+    printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path
     where
-      maybePrintSBH = \case
+      maybePrintSCH = \case
         Nothing -> mempty
-        Just sbh -> "#" <> SBH.toText sbh
+        Just sch -> "#" <> SCH.toText sch
   ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} ->
     displayShareCodeserver server repo path
 
@@ -110,7 +110,7 @@ data ReadRemoteNamespace
 
 data ReadGitRemoteNamespace = ReadGitRemoteNamespace
   { repo :: ReadGitRepo,
-    sbh :: Maybe ShortBranchHash,
+    sch :: Maybe ShortCausalHash,
     path :: Path
   }
   deriving stock (Eq, Show)
@@ -118,7 +118,7 @@ data ReadGitRemoteNamespace = ReadGitRemoteNamespace
 data ReadShareRemoteNamespace = ReadShareRemoteNamespace
   { server :: ShareCodeserver,
     repo :: Text,
-    -- sbh :: Maybe ShortBranchHash, -- maybe later
+    -- sch :: Maybe ShortCausalHash, -- maybe later
     path :: Path
   }
   deriving stock (Eq, Show)

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

@@ -35,7 +35,7 @@ execute codebase runtime mainName =
     let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
         loadTypeOfTerm = Codebase.getTypeOfTerm codebase
     let mainType = Runtime.mainType runtime
-    mt <- liftIO $ getMainTerm loadTypeOfTerm parseNames mainName mainType
+    mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
     case mt of
       MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.string s)
       MainTerm.NotFound s -> throwError ("Not found: " <> P.string s)

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

@@ -4,7 +4,7 @@ module Unison.Codebase.GitError where
 
 import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
 import Unison.Codebase.Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Prelude
 
 type CodebasePath = FilePath
@@ -28,8 +28,8 @@ data GitProtocolError
   deriving anyclass (Exception)
 
 data GitCodebaseError h
-  = NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash
-  | RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h)
+  = NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash
+  | RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h)
   | CouldntLoadRootBranch ReadGitRepo h
   | CouldntParseRemoteBranch ReadGitRepo String
   | CouldntLoadSyncedBranch ReadGitRemoteNamespace h

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

@@ -146,7 +146,7 @@ withNewUcmCodebaseOrExit cbInit debugName path action = do
   prettyDir <- P.string <$> canonicalizePath path
   let codebaseSetup codebase = do
         liftIO $ PT.putPrettyLn' . P.wrap $ "Initializing a new codebase in: " <> prettyDir
-        Codebase.installUcmDependencies codebase
+        Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
   createCodebase cbInit debugName path (\cb -> codebaseSetup cb *> action cb)
     >>= \case
       Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure

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

@@ -29,7 +29,16 @@ type Star a n = Star3 a n Type (Type, Value)
 type R4 a n = R4.Relation4 a n Type Value
 
 starToR4 :: (Ord r, Ord n) => Star r n -> Relation4 r n Type Value
-starToR4 = R4.fromList . fmap (\(r, n, _, (t, v)) -> (r, n, t, v)) . Star3.toList
+starToR4 = R4.fromList . starToR4List
+
+-- | Flattens a Metadata.Star into a 4-tuple.
+starToR4List :: Ord r => Star r n -> [(r, n, Type, Value)]
+starToR4List s =
+  [ (f, x, y, z)
+    | f <- Set.toList (Star3.fact s),
+      x <- Set.toList (R.lookupDom f (Star3.d1 s)),
+      (y, z) <- Set.toList (R.lookupDom f (Star3.d3 s))
+  ]
 
 hasMetadata :: Ord a => a -> Type -> Value -> Star a n -> Bool
 hasMetadata a t v = Set.member (t, v) . R.lookupDom a . Star3.d3

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

@@ -1,38 +0,0 @@
-module Unison.Codebase.ShortBranchHash
-  ( toString,
-    toHash,
-    fromHash,
-    fromText,
-    ShortBranchHash (..),
-  )
-where
-
-import qualified Data.Set as Set
-import qualified Data.Text as Text
-import qualified Unison.Hash as Hash
-import Unison.Prelude
-
-newtype ShortBranchHash = ShortBranchHash {toText :: Text} -- base32hex characters
-  deriving stock (Eq, Ord, Generic)
-
-toString :: ShortBranchHash -> String
-toString = Text.unpack . toText
-
-toHash :: Coercible Hash.Hash h => ShortBranchHash -> Maybe h
-toHash = fmap coerce . Hash.fromBase32Hex . toText
-
-fromHash :: Coercible h Hash.Hash => Int -> h -> ShortBranchHash
-fromHash len =
-  ShortBranchHash . Text.take len . Hash.base32Hex . coerce
-
--- abc -> SBH abc
--- #abc -> SBH abc
-fromText :: Text -> Maybe ShortBranchHash
-fromText (Text.dropWhile (== '#') -> t)
-  | Text.all (`Set.member` Hash.validBase32HexChars) t =
-    Just $
-      ShortBranchHash t
-fromText _ = Nothing
-
-instance Show ShortBranchHash where
-  show (ShortBranchHash h) = '#' : Text.unpack h

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

@@ -0,0 +1,39 @@
+module Unison.Codebase.ShortCausalHash
+  ( toString,
+    toHash,
+    fromHash,
+    fromText,
+    ShortCausalHash (..),
+  )
+where
+
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Unison.Hash as Hash
+import Unison.Prelude
+
+-- | Causal Hash Prefix
+newtype ShortCausalHash = ShortCausalHash {toText :: Text} -- base32hex characters
+  deriving stock (Eq, Ord, Generic)
+
+toString :: ShortCausalHash -> String
+toString = Text.unpack . toText
+
+toHash :: Coercible Hash.Hash h => ShortCausalHash -> Maybe h
+toHash = fmap coerce . Hash.fromBase32Hex . toText
+
+fromHash :: Coercible h Hash.Hash => Int -> h -> ShortCausalHash
+fromHash len =
+  ShortCausalHash . Text.take len . Hash.base32Hex . coerce
+
+-- abc -> SCH abc
+-- #abc -> SCH abc
+fromText :: Text -> Maybe ShortCausalHash
+fromText (Text.dropWhile (== '#') -> t)
+  | Text.all (`Set.member` Hash.validBase32HexChars) t =
+      Just $
+        ShortCausalHash t
+fromText _ = Nothing
+
+instance Show ShortCausalHash where
+  show (ShortCausalHash h) = '#' : Text.unpack h

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

@@ -27,14 +27,13 @@ import qualified System.Console.ANSI as ANSI
 import qualified System.FilePath as FilePath
 import qualified System.FilePath.Posix as FilePath.Posix
 import qualified U.Codebase.Branch as V2Branch
-import U.Codebase.HashTags (CausalHash (CausalHash))
+import U.Codebase.HashTags (BranchHash, CausalHash (CausalHash))
 import qualified U.Codebase.Reflog as Reflog
 import qualified U.Codebase.Sqlite.Operations as Ops
 import qualified U.Codebase.Sqlite.Queries as Q
 import qualified U.Codebase.Sqlite.Sync22 as Sync22
 import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
 import qualified U.Codebase.Sync as Sync
-import qualified U.Util.Cache as Cache
 import U.Util.Timing (time)
 import Unison.Codebase (Codebase, CodebasePath)
 import qualified Unison.Codebase as Codebase1
@@ -58,7 +57,7 @@ import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
 import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1
 import Unison.Codebase.Patch (Patch)
 import Unison.Codebase.Path (Path)
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
 import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD
 import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
@@ -197,12 +196,9 @@ sqliteCodebase ::
   (Codebase m Symbol Ann -> m r) ->
   m (Either Codebase1.OpenCodebaseError r)
 sqliteCodebase debugName root localOrRemote migrationStrategy action = do
-  termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
-  typeOfTermCache <- Cache.semispaceCache 8192
-  declCache <- Cache.semispaceCache 1024
   rootBranchCache <- newTVarIO Nothing
   branchCache <- newBranchCache
-  getDeclType <- CodebaseOps.mkGetDeclType
+  getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
   -- The v1 codebase interface has operations to read and write individual definitions
   -- whereas the v2 codebase writes them as complete components.  These two fields buffer
   -- the individual definitions until a complete component has been written.
@@ -239,26 +235,19 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
             printBuffer "Terms:" terms
 
       flip finally finalizer do
-        let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann))
-            getTerm id =
-              runTransaction (CodebaseOps.getTerm getDeclType id)
+        getTermTransaction <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTerm getDeclType)
+        let getTerm id = runTransaction (getTermTransaction id)
 
-            getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann))
-            getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined
-            getTypeOfTermImpl id =
-              runTransaction (CodebaseOps.getTypeOfTermImpl id)
+        getTypeOfTermImpl <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTypeOfTermImpl)
+        getTypeDeclaration <- CodebaseOps.makeMaybeCachedTransaction 1024 CodebaseOps.getTypeDeclaration
 
-            getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
+        let getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
             getTermComponentWithTypes =
               CodebaseOps.getTermComponentWithTypes getDeclType
 
-            getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann))
-            getTypeDeclaration id =
-              runTransaction (CodebaseOps.getTypeDeclaration id)
-
-            getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann])
-            getDeclComponent h =
-              runTransaction (CodebaseOps.getDeclComponent h)
+            getDeclComponent :: Hash -> Sqlite.Transaction (Maybe [Decl Symbol Ann])
+            getDeclComponent =
+              CodebaseOps.getDeclComponent
 
             getCycleLength :: Hash -> m (Maybe Reference.CycleSize)
             getCycleLength h =
@@ -271,14 +260,22 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
             -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function
             -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly)
 
-            putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m ()
+            putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> Sqlite.Transaction ()
             putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined
             putTerm id tm tp =
-              runTransaction (CodebaseOps.putTerm termBuffer declBuffer id tm tp)
+              CodebaseOps.putTerm termBuffer declBuffer id tm tp
 
-            putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m ()
-            putTypeDeclaration id decl =
-              runTransaction (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl)
+            putTermComponent :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Sqlite.Transaction ()
+            putTermComponent =
+              CodebaseOps.putTermComponent termBuffer declBuffer
+
+            putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> Sqlite.Transaction ()
+            putTypeDeclaration =
+              CodebaseOps.putTypeDeclaration termBuffer declBuffer
+
+            putTypeDeclarationComponent :: Hash -> [Decl Symbol Ann] -> Sqlite.Transaction ()
+            putTypeDeclarationComponent =
+              CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer
 
             getRootCausalHash :: MonadIO m => m V2Branch.CausalHash
             getRootCausalHash =
@@ -335,9 +332,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
             patchExists h =
               runTransaction (CodebaseOps.patchExists h)
 
-            dependentsImpl :: Q.DependentsSelector -> Reference -> m (Set Reference.Id)
-            dependentsImpl selector r =
-              runTransaction (CodebaseOps.dependentsImpl selector r)
+            dependentsImpl :: Q.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference.Id)
+            dependentsImpl =
+              CodebaseOps.dependentsImpl
 
             dependentsOfComponentImpl :: Hash -> m (Set Reference.Id)
             dependentsOfComponentImpl h =
@@ -409,9 +406,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
             referentsByPrefix sh =
               runTransaction (CodebaseOps.referentsByPrefix getDeclType sh)
 
-            branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash)
-            branchHashesByPrefix sh =
-              runTransaction (CodebaseOps.branchHashesByPrefix sh)
+            causalHashesByPrefix :: ShortCausalHash -> m (Set Branch.CausalHash)
+            causalHashesByPrefix sh =
+              runTransaction (CodebaseOps.causalHashesByPrefix sh)
 
             sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash))
             sqlLca h1 h2 =
@@ -426,21 +423,23 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
             namesAtPath path =
               runTransaction (CodebaseOps.namesAtPath path)
 
-            updateNameLookup :: m ()
+            updateNameLookup :: Path -> Maybe BranchHash -> BranchHash -> Sqlite.Transaction ()
             updateNameLookup =
-              runTransaction (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType)
+              CodebaseOps.updateNameLookupIndex getDeclType
 
         let codebase =
               C.Codebase
-                { getTerm = Cache.applyDefined termCache getTerm,
-                  getTypeOfTermImpl = Cache.applyDefined typeOfTermCache getTypeOfTermImpl,
-                  getTypeDeclaration = Cache.applyDefined declCache getTypeDeclaration,
+                { getTerm,
+                  getTypeOfTermImpl,
+                  getTypeDeclaration,
                   getDeclType =
                     \r ->
                       withConn \conn ->
                         Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r),
                   putTerm,
+                  putTermComponent,
                   putTypeDeclaration,
+                  putTypeDeclarationComponent,
                   getTermComponentWithTypes,
                   getDeclComponent,
                   getComponentLength = getCycleLength,
@@ -473,7 +472,7 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
                   typeReferencesByPrefix = declReferencesByPrefix,
                   termReferentsByPrefix = referentsByPrefix,
                   branchHashLength,
-                  branchHashesByPrefix,
+                  causalHashesByPrefix,
                   lcaImpl = Just sqlLca,
                   beforeImpl,
                   namesAtPath,
@@ -662,7 +661,7 @@ viewRemoteBranch' ::
   Git.GitBranchBehavior ->
   ((Branch m, CodebasePath) -> m r) ->
   m (Either C.GitError r)
-viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior action = UnliftIO.try $ do
+viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do
   -- set up the cache dir
   time "Git fetch" $
     throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do
@@ -685,19 +684,19 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act
 
       result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote MigrateAfterPrompt \codebase -> do
         -- try to load the requested branch from it
-        branch <- time "Git fetch (sbh)" $ case sbh of
+        branch <- time "Git fetch (sch)" $ case sch of
           -- no sub-branch was specified, so use the root.
           Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase
-          -- load from a specific `ShortBranchHash`
-          Just sbh -> do
-            branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh
+          -- load from a specific `ShortCausalHash`
+          Just sch -> do
+            branchCompletions <- Codebase1.causalHashesByPrefix codebase sch
             case toList branchCompletions of
-              [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
+              [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
               [h] ->
                 (Codebase1.getBranchForHash codebase h) >>= \case
                   Just b -> pure b
-                  Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
-              _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
+                  Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
+              _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions
         case Branch.getAt path branch of
           Just b -> action (b, remotePath)
           Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path

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

@@ -28,7 +28,7 @@ import qualified Unison.Codebase.Branch as V1.Branch
 import qualified Unison.Codebase.Causal.Type as V1.Causal
 import qualified Unison.Codebase.Metadata as V1.Metadata
 import qualified Unison.Codebase.Patch as V1
-import qualified Unison.Codebase.ShortBranchHash as V1
+import qualified Unison.Codebase.ShortCausalHash as V1
 import Unison.Codebase.SqliteCodebase.Branch.Cache
 import qualified Unison.Codebase.TermEdit as V1.TermEdit
 import qualified Unison.Codebase.TypeEdit as V1.TypeEdit
@@ -57,8 +57,8 @@ import qualified Unison.Util.Star3 as V1.Star3
 import qualified Unison.Var as Var
 import qualified Unison.WatchKind as V1.WK
 
-sbh1to2 :: V1.ShortBranchHash -> V2.ShortBranchHash
-sbh1to2 (V1.ShortBranchHash b32) = V2.ShortBranchHash b32
+sch1to2 :: V1.ShortCausalHash -> V2.ShortCausalHash
+sch1to2 (V1.ShortCausalHash b32) = V2.ShortCausalHash b32
 
 decltype2to1 :: V2.Decl.DeclType -> CT.ConstructorType
 decltype2to1 = \case
@@ -204,6 +204,13 @@ term2to1 h lookupCT =
           V2.Term.PConcat -> V1.Pattern.Concat
         a = Ann.External
 
+termComponent1to2 ::
+  Hash ->
+  [(V1.Term.Term V1.Symbol Ann, V1.Type.Type V1.Symbol a)] ->
+  [(V2.Term.Term V2.Symbol, V2.Type.TypeT V2.Symbol)]
+termComponent1to2 h =
+  map (bimap (term1to2 h) ttype1to2)
+
 decl2to1 :: Hash -> V2.Decl.Decl V2.Symbol -> V1.Decl.Decl V1.Symbol Ann
 decl2to1 h (V2.Decl.DataDeclaration dt m bound cts) =
   goCT dt $

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

@@ -8,7 +8,7 @@
 module Unison.Codebase.SqliteCodebase.Operations where
 
 import Control.Lens (ifor)
-import Data.Bifunctor (Bifunctor (bimap), second)
+import Data.Bifunctor (second)
 import Data.Bitraversable (bitraverse)
 import Data.Either.Extra ()
 import qualified Data.List as List
@@ -18,8 +18,9 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified U.Codebase.Branch as V2Branch
+import qualified U.Codebase.Branch.Diff as BranchDiff
 import qualified U.Codebase.Causal as V2Causal
-import U.Codebase.HashTags (CausalHash (unCausalHash))
+import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash))
 import qualified U.Codebase.Reference as C.Reference
 import qualified U.Codebase.Referent as C.Referent
 import U.Codebase.Sqlite.DbId (ObjectId)
@@ -41,7 +42,7 @@ import qualified Unison.Codebase.Causal.Type as Causal
 import Unison.Codebase.Patch (Patch)
 import Unison.Codebase.Path (Path)
 import qualified Unison.Codebase.Path as Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
 import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
 import Unison.ConstructorReference (GConstructorReference (..))
@@ -232,6 +233,19 @@ getDeclComponent h =
     decl2 <- Ops.loadDeclComponent h
     pure (map (Cv.decl2to1 h) decl2)
 
+putTermComponent ::
+  TVar (Map Hash TermBufferEntry) ->
+  TVar (Map Hash DeclBufferEntry) ->
+  -- | The hash of the term component.
+  Hash ->
+  [(Term Symbol Ann, Type Symbol Ann)] ->
+  Transaction ()
+putTermComponent termBuffer declBuffer h component =
+  unlessM (Ops.objectExistsForHash h) do
+    for_ (Reference.componentFor h component) \(ref, (tm, tp)) -> do
+      putTerm_ termBuffer declBuffer ref tm tp
+      tryFlushTermBuffer termBuffer h
+
 putTerm ::
   TVar (Map Hash TermBufferEntry) ->
   TVar (Map Hash DeclBufferEntry) ->
@@ -239,46 +253,50 @@ putTerm ::
   Term Symbol Ann ->
   Type Symbol Ann ->
   Transaction ()
-putTerm termBuffer declBuffer (Reference.Id h i) tm tp =
+putTerm termBuffer declBuffer ref@(Reference.Id h _) tm tp =
   unlessM (Ops.objectExistsForHash h) do
-    BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer termBuffer h)
-    let termDependencies = Set.toList $ Term.termDependencies tm
-    -- update the component target size if we encounter any higher self-references
-    let size' = max size (Just $ biggestSelfReference + 1)
-          where
-            biggestSelfReference =
-              maximum1 $
-                i :| [i' | Reference.Derived h' i' <- termDependencies, h == h']
-    let comp' = Map.insert i (tm, tp) comp
-    -- for the component element that's been passed in, add its dependencies to missing'
-    missingTerms' <-
-      filterM
-        (fmap not . Ops.objectExistsForHash)
-        [h | Reference.Derived h _i <- termDependencies]
-    missingTypes' <-
-      filterM (fmap not . Ops.objectExistsForHash) $
-        [h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm]
-          ++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp]
-    let missing' = missing <> Set.fromList (missingTerms' <> missingTypes')
-    Sqlite.unsafeIO do
-      -- notify each of the dependencies that h depends on them.
-      traverse_ (addBufferDependent h termBuffer) missingTerms'
-      traverse_ (addBufferDependent h declBuffer) missingTypes'
-      putBuffer termBuffer h (BufferEntry size' comp' missing' waiting)
+    putTerm_ termBuffer declBuffer ref tm tp
     tryFlushTermBuffer termBuffer h
 
+putTerm_ ::
+  TVar (Map Hash TermBufferEntry) ->
+  TVar (Map Hash DeclBufferEntry) ->
+  Reference.Id ->
+  Term Symbol Ann ->
+  Type Symbol Ann ->
+  Transaction ()
+putTerm_ termBuffer declBuffer (Reference.Id h i) tm tp = do
+  BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer termBuffer h)
+  let termDependencies = Set.toList $ Term.termDependencies tm
+  -- update the component target size if we encounter any higher self-references
+  let size' = max size (Just $ biggestSelfReference + 1)
+        where
+          biggestSelfReference =
+            maximum1 $
+              i :| [i' | Reference.Derived h' i' <- termDependencies, h == h']
+  let comp' = Map.insert i (tm, tp) comp
+  -- for the component element that's been passed in, add its dependencies to missing'
+  missingTerms' <-
+    filterM
+      (fmap not . Ops.objectExistsForHash)
+      [h | Reference.Derived h _i <- termDependencies]
+  missingTypes' <-
+    filterM (fmap not . Ops.objectExistsForHash) $
+      [h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm]
+        ++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp]
+  let missing' = missing <> Set.fromList (missingTerms' <> missingTypes')
+  Sqlite.unsafeIO do
+    -- notify each of the dependencies that h depends on them.
+    traverse_ (addBufferDependent h termBuffer) missingTerms'
+    traverse_ (addBufferDependent h declBuffer) missingTypes'
+    putBuffer termBuffer h (BufferEntry size' comp' missing' waiting)
+
 tryFlushTermBuffer :: TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
 tryFlushTermBuffer termBuffer =
   let loop h =
         tryFlushBuffer
           termBuffer
-          ( \h2 component ->
-              void $
-                saveTermComponent
-                  Nothing
-                  h2
-                  (fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component)
-          )
+          (\h2 component -> void $ saveTermComponent Nothing h2 (Cv.termComponent1to2 h component))
           loop
           h
    in loop
@@ -293,31 +311,51 @@ addDeclComponentTypeIndex oId ctorss =
       Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing)
       Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing)
 
+putTypeDeclarationComponent ::
+  TVar (Map Hash TermBufferEntry) ->
+  TVar (Map Hash DeclBufferEntry) ->
+  Hash ->
+  [Decl Symbol Ann] ->
+  Transaction ()
+putTypeDeclarationComponent termBuffer declBuffer h decls =
+  unlessM (Ops.objectExistsForHash h) do
+    for_ (Reference.componentFor h decls) \(ref, decl) ->
+      putTypeDeclaration_ declBuffer ref decl
+    tryFlushDeclBuffer termBuffer declBuffer h
+
 putTypeDeclaration ::
   TVar (Map Hash TermBufferEntry) ->
   TVar (Map Hash DeclBufferEntry) ->
   Reference.Id ->
   Decl Symbol Ann ->
   Transaction ()
-putTypeDeclaration termBuffer declBuffer (Reference.Id h i) decl =
+putTypeDeclaration termBuffer declBuffer ref@(Reference.Id h _) decl = do
   unlessM (Ops.objectExistsForHash h) do
-    BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer declBuffer h)
-    let declDependencies = Set.toList $ Decl.declDependencies decl
-    let size' = max size (Just $ biggestSelfReference + 1)
-          where
-            biggestSelfReference =
-              maximum1 $
-                i :| [i' | Reference.Derived h' i' <- declDependencies, h == h']
-    let comp' = Map.insert i decl comp
-    moreMissing <-
-      filterM (fmap not . Ops.objectExistsForHash) $
-        [h | Reference.Derived h _i <- declDependencies]
-    let missing' = missing <> Set.fromList moreMissing
-    Sqlite.unsafeIO do
-      traverse_ (addBufferDependent h declBuffer) moreMissing
-      putBuffer declBuffer h (BufferEntry size' comp' missing' waiting)
+    putTypeDeclaration_ declBuffer ref decl
     tryFlushDeclBuffer termBuffer declBuffer h
 
+putTypeDeclaration_ ::
+  TVar (Map Hash DeclBufferEntry) ->
+  Reference.Id ->
+  Decl Symbol Ann ->
+  Transaction ()
+putTypeDeclaration_ declBuffer (Reference.Id h i) decl = do
+  BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer declBuffer h)
+  let declDependencies = Set.toList $ Decl.declDependencies decl
+  let size' = max size (Just $ biggestSelfReference + 1)
+        where
+          biggestSelfReference =
+            maximum1 $
+              i :| [i' | Reference.Derived h' i' <- declDependencies, h == h']
+  let comp' = Map.insert i decl comp
+  moreMissing <-
+    filterM (fmap not . Ops.objectExistsForHash) $
+      [h | Reference.Derived h _i <- declDependencies]
+  let missing' = missing <> Set.fromList moreMissing
+  Sqlite.unsafeIO do
+    traverse_ (addBufferDependent h declBuffer) moreMissing
+    putBuffer declBuffer h (BufferEntry size' comp' missing' waiting)
+
 tryFlushDeclBuffer ::
   TVar (Map Hash TermBufferEntry) ->
   TVar (Map Hash DeclBufferEntry) ->
@@ -516,7 +554,13 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to
   termReferents <-
     Ops.termReferentsByPrefix prefix cycle
       >>= traverse (Cv.referentid2to1 doGetDeclType)
-  declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid)
+  cid' <- case cid of
+    Nothing -> pure Nothing
+    Just c ->
+      case readMaybe (Text.unpack c) of
+        Nothing -> error $ reportBug "994787297" "cid of ShortHash must be an integer but got: " <> show cid
+        Just cInt -> pure $ Just cInt
+  declReferents' <- Ops.declReferentsByPrefix prefix cycle cid'
   let declReferents =
         [ Referent.ConId (ConstructorReference (Reference.Id h pos) (fromIntegral cid)) (Cv.decltype2to1 ct)
           | (h, pos, ct, cids) <- declReferents',
@@ -524,12 +568,12 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to
         ]
   pure . Set.fromList $ termReferents <> declReferents
 
-branchHashesByPrefix :: ShortBranchHash -> Transaction (Set Branch.CausalHash)
-branchHashesByPrefix sh = do
+causalHashesByPrefix :: ShortCausalHash -> Transaction (Set Branch.CausalHash)
+causalHashesByPrefix sh = do
   -- given that a Branch is shallow, it's really `CausalHash` that you'd
   -- refer to to specify a full namespace w/ history.
   -- but do we want to be able to refer to a namespace without its history?
-  cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh)
+  cs <- Ops.causalHashesByPrefix (Cv.sch1to2 sh)
   pure $ Set.map (Causal.CausalHash . unCausalHash) cs
 
 sqlLca :: Branch.CausalHash -> Branch.CausalHash -> Transaction (Maybe Branch.CausalHash)
@@ -601,11 +645,49 @@ namesAtPath path = do
 
 -- | Update the root namespace names index which is used by the share server for serving api
 -- requests.
+updateNameLookupIndex ::
+  (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
+  Path ->
+  -- | "from" branch, if 'Nothing' use the empty branch
+  Maybe BranchHash ->
+  -- | "to" branch
+  BranchHash ->
+  Sqlite.Transaction ()
+updateNameLookupIndex getDeclType pathPrefix mayFromBranchHash toBranchHash = do
+  fromBranch <- case mayFromBranchHash of
+    Nothing -> pure V2Branch.empty
+    Just fromBH -> Ops.expectBranchByBranchHash fromBH
+  toBranch <- Ops.expectBranchByBranchHash toBranchHash
+  treeDiff <- BranchDiff.diffBranches fromBranch toBranch
+  let namePrefix = case pathPrefix of
+        Path.Empty -> Nothing
+        (p Path.:< ps) -> Just $ Name.fromSegments (p :| Path.toList ps)
+  let BranchDiff.NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} = BranchDiff.nameChanges namePrefix treeDiff
+  termNameAddsWithCT <- do
+    for termNameAdds \(name, ref) -> do
+      refWithCT <- addReferentCT ref
+      pure $ toNamedRef (name, refWithCT)
+  Ops.updateNameIndex (termNameAddsWithCT, toNamedRef <$> termNameRemovals) (toNamedRef <$> typeNameAdds, toNamedRef <$> typeNameRemovals)
+  where
+    toNamedRef :: (Name, ref) -> S.NamedRef ref
+    toNamedRef (name, ref) = S.NamedRef {reversedSegments = coerce $ Name.reverseSegments name, ref = ref}
+    addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
+    addReferentCT referent = case referent of
+      C.Referent.Ref {} -> pure (referent, Nothing)
+      C.Referent.Con ref _conId -> do
+        ct <- getDeclType ref
+        pure (referent, Just $ Cv.constructorType1to2 ct)
+
+-- | Compute the root namespace names index which is used by the share server for serving api
+-- requests. Using 'updateNameLookupIndex' is preferred whenever possible, since it's
+-- considerably faster. This can be used to reset the index if it ever gets out of sync due to
+-- a bug.
 --
--- This version should be used if you've already got the root Branch pre-loaded, otherwise
--- it's faster to use 'updateNameLookupIndexFromV2Branch'
-updateNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction ()
-updateNameLookupIndexFromV1Branch root = do
+-- This version can be used if you've already got the root Branch pre-loaded, otherwise
+-- it's faster to use 'initializeNameLookupIndexFromV2Root'
+initializeNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction ()
+initializeNameLookupIndexFromV1Branch root = do
+  Q.dropNameLookupTables
   saveRootNamesIndexV1 (V1Branch.toNames . Branch.head $ root)
   where
     saveRootNamesIndexV1 :: Names -> Transaction ()
@@ -618,7 +700,7 @@ updateNameLookupIndexFromV1Branch root = do
               <&> ( \(name, ref) ->
                       S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref}
                   )
-      Ops.rebuildNameIndex termNames typeNames
+      Ops.updateNameIndex (termNames, []) (typeNames, [])
       where
         nameSegments :: Name -> NonEmpty Text
         nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments
@@ -627,13 +709,16 @@ updateNameLookupIndexFromV1Branch root = do
           Referent.Ref {} -> (Cv.referent1to2 referent, Nothing)
           Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct))
 
--- | Update the root namespace names index which is used by the share server for serving api
--- requests.
+-- | Compute the root namespace names index which is used by the share server for serving api
+-- requests. Using 'updateNameLookupIndex' is preferred whenever possible, since it's
+-- considerably faster. This can be used to reset the index if it ever gets out of sync due to
+-- a bug.
 --
 -- This version should be used if you don't already have the root Branch pre-loaded,
--- If you do, use 'updateNameLookupIndexFromV2Branch' instead.
-updateNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction ()
-updateNameLookupIndexFromV2Root getDeclType = do
+-- If you do, use 'initializeNameLookupIndexFromV1Branch' instead.
+initializeNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction ()
+initializeNameLookupIndexFromV2Root getDeclType = do
+  Q.dropNameLookupTables
   rootHash <- Ops.expectRootCausalHash
   causalBranch <- Ops.expectCausalBranchByCausalHash rootHash
   (termNameMap, typeNameMap) <- nameMapsFromV2Branch [] causalBranch
@@ -646,7 +731,7 @@ updateNameLookupIndexFromV2Root getDeclType = do
         (name, refs) <- Map.toList typeNameMap
         ref <- Set.toList refs
         pure $ S.NamedRef {S.reversedSegments = coerce name, S.ref = ref}
-  Ops.rebuildNameIndex termNameList typeNameList
+  Ops.updateNameIndex (termNameList, []) (typeNameList, [])
   where
     addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
     addReferentCT referent = case referent of
@@ -667,9 +752,24 @@ updateNameLookupIndexFromV2Root getDeclType = do
         fold <$> (ifor (V2Branch.children b) $ \nameSegment cb -> (nameMapsFromV2Branch (nameSegment : reversedNamePrefix) cb))
       pure (Map.mapKeys (NEList.:| reversedNamePrefix) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| reversedNamePrefix) shallowTypeNames <> prefixedChildTypes)
 
-mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType)
-mkGetDeclType = do
-  declTypeCache <- Cache.semispaceCache 2048
-  pure $ \ref -> do
+-- | Given a transaction, return a transaction that first checks a semispace cache of the given size.
+--
+-- The transaction should probably be read-only, as we (of course) don't hit SQLite on a cache hit.
+makeCachedTransaction :: (Ord a, MonadIO m) => Word -> (a -> Sqlite.Transaction b) -> m (a -> Sqlite.Transaction b)
+makeCachedTransaction size action = do
+  cache <- Cache.semispaceCache size
+  pure \x -> do
     conn <- Sqlite.unsafeGetConnection
-    Sqlite.unsafeIO $ Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (getDeclType ref) conn) ref
+    Sqlite.unsafeIO (Cache.apply cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
+
+-- | Like 'makeCachedTransaction', but for when the transaction returns a Maybe; only cache the Justs.
+makeMaybeCachedTransaction ::
+  (Ord a, MonadIO m) =>
+  Word ->
+  (a -> Sqlite.Transaction (Maybe b)) ->
+  m (a -> Sqlite.Transaction (Maybe b))
+makeMaybeCachedTransaction size action = do
+  cache <- Cache.semispaceCache size
+  pure \x -> do
+    conn <- Sqlite.unsafeGetConnection
+    Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)

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

@@ -14,6 +14,7 @@ module Unison.Codebase.Type
 where
 
 import qualified U.Codebase.Branch as V2
+import U.Codebase.HashTags (BranchHash)
 import qualified U.Codebase.Reference as V2
 import qualified U.Codebase.Reflog as Reflog
 import qualified U.Codebase.Sqlite.Queries as Queries
@@ -25,7 +26,7 @@ import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
 import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
 import Unison.Codebase.Patch (Patch)
 import Unison.Codebase.Path (Path)
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
 import Unison.Codebase.SyncMode (SyncMode)
 import Unison.CodebasePath (CodebasePath)
@@ -60,24 +61,26 @@ data Codebase m v a = Codebase
     --
     -- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of
     -- 'putTerm'.
-    getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)),
+    getTypeOfTermImpl :: Reference.Id -> Sqlite.Transaction (Maybe (Type v a)),
     -- | Get a type declaration.
     --
     -- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the
     -- semantics of 'putTypeDeclaration'.
-    getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)),
+    getTypeDeclaration :: Reference.Id -> Sqlite.Transaction (Maybe (Decl v a)),
     -- | Get the type of a given decl.
     getDeclType :: V2.Reference -> m CT.ConstructorType,
     -- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The
     -- implementation may choose to delay the put until all of the term's (and its type's) references are stored as
     -- well.
-    putTerm :: Reference.Id -> Term v a -> Type v a -> m (),
+    putTerm :: Reference.Id -> Term v a -> Type v a -> Sqlite.Transaction (),
+    putTermComponent :: Hash -> [(Term v a, Type v a)] -> Sqlite.Transaction (),
     -- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may
     -- choose to delay the put until all of the type declaration's references are stored as well.
-    putTypeDeclaration :: Reference.Id -> Decl v a -> m (),
+    putTypeDeclaration :: Reference.Id -> Decl v a -> Sqlite.Transaction (),
+    putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
     -- getTermComponent :: Hash -> m (Maybe [Term v a]),
     getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]),
-    getDeclComponent :: Hash -> m (Maybe [Decl v a]),
+    getDeclComponent :: Hash -> Sqlite.Transaction (Maybe [Decl v a]),
     getComponentLength :: Hash -> m (Maybe Reference.CycleSize),
     -- | Get the root causal Hash.
     getRootCausalHash :: m V2.CausalHash,
@@ -109,7 +112,7 @@ data Codebase m v a = Codebase
     patchExists :: Branch.EditHash -> m Bool,
     -- | Get the set of user-defined terms and type declarations that depend on the given term, type declaration, or
     -- builtin type.
-    dependentsImpl :: Queries.DependentsSelector -> Reference -> m (Set Reference.Id),
+    dependentsImpl :: Queries.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference.Id),
     dependentsOfComponentImpl :: Hash -> m (Set Reference.Id),
     -- | Copy a branch and all of its dependencies from the given codebase into this one.
     syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
@@ -153,7 +156,7 @@ data Codebase m v a = Codebase
     -- | The number of base32 characters needed to distinguish any two branch in the codebase.
     branchHashLength :: m Int,
     -- | Get the set of branches whose hash matches the given prefix.
-    branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash),
+    causalHashesByPrefix :: ShortCausalHash -> m (Set Branch.CausalHash),
     -- returns `Nothing` to not implemented, fallback to in-memory
     --    also `Nothing` if no LCA
     -- The result is undefined if the two hashes are not in the codebase.
@@ -169,9 +172,21 @@ data Codebase m v a = Codebase
     -- NOTE: this method requires an up-to-date name lookup index, which is
     -- currently not kept up-to-date automatically (because it's slow to do so).
     namesAtPath :: Path -> m ScopedNames,
-    -- Updates the root namespace names index.
+    -- Updates the root namespace names index from an old BranchHash to a new one.
     -- This isn't run automatically because it can be a bit slow.
-    updateNameLookup :: m (),
+    updateNameLookup ::
+      -- Path to the root of the _changes_.
+      -- E.g. if you know that all the changes occur at "base.List", you can pass "base.List"
+      -- here, and pass the old and new branch hashes for the branch as "base.List".
+      -- This allows us to avoid searching for changes in areas where it's impossible for it
+      -- to have occurred.
+      Path ->
+      -- The branch hash at 'Path' which the existing index was built from.
+      -- Pass 'Nothing' to build the index from scratch (i.e. compute a diff from an empty branch).
+      Maybe BranchHash ->
+      -- The new branch
+      BranchHash ->
+      Sqlite.Transaction (),
     -- | Acquire a new connection to the same underlying database file this codebase object connects to.
     withConnection :: forall x. (Sqlite.Connection -> m x) -> m x,
     -- | Acquire a new connection to the same underlying database file this codebase object connects to.

parser-typechecker/src/Unison/FileParsers.hs

@@ -185,9 +185,8 @@ synthesizeFile ambient tl fqnsByShortName uf term = do
        in -- use tlcsFromTypechecker to inform annotation-stripping decisions
           traverse (traverse strippedTopLevelBinding) tlcsFromTypechecker
     let doTdnr = applyTdnrDecisions infos
-        doTdnrInComponent (v, t, tp) = (\t -> (v, t, tp)) <$> doTdnr t
-    _ <- doTdnr tdnrTerm
-    tdnredTlcs <- (traverse . traverse) doTdnrInComponent topLevelComponents
+    let doTdnrInComponent (v, t, tp) = (v, doTdnr t, tp)
+    let tdnredTlcs = (fmap . fmap) doTdnrInComponent topLevelComponents
     let (watches', terms') = partition isWatch tdnredTlcs
         isWatch = all (\(v, _, _) -> Set.member v watchedVars)
         watchedVars = Set.fromList [v | (v, _) <- UF.allWatches uf]
@@ -208,19 +207,15 @@ synthesizeFile ambient tl fqnsByShortName uf term = do
     applyTdnrDecisions ::
       [Context.InfoNote v Ann] ->
       Term v ->
-      Result' v (Term v)
-    applyTdnrDecisions infos tdnrTerm = foldM go tdnrTerm decisions
+      Term v
+    applyTdnrDecisions infos tdnrTerm = ABT.visitPure resolve tdnrTerm
       where
-        -- UF data/effect ctors + builtins + TLC Term.vars
-        go term _decision@(shortv, loc, replacement) =
-          ABT.visit (resolve shortv loc replacement) term
-        decisions =
-          [(v, loc, replacement) | Context.Decision v loc replacement <- infos]
+        decisions = Map.fromList [((Var.nameStr v, loc), replacement) | Context.Decision v loc replacement <- infos]
         -- resolve (v,loc) in a matching Blank to whatever `fqn` maps to in `names`
-        resolve shortv loc replacement t = case t of
+        resolve t = case t of
           Term.Blank' (Blank.Recorded (Blank.Resolve loc' name))
-            | loc' == loc && Var.nameStr shortv == name ->
-                -- loc of replacement already chosen correctly by whatever made the
-                -- Decision
-                pure . pure $ replacement
+            | Just replacement <- Map.lookup (name, loc') decisions ->
+              -- loc of replacement already chosen correctly by whatever made the
+              -- Decision
+              Just $ replacement
           _ -> Nothing

parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE ConstraintKinds #-}
+
+module Unison.PrettyPrintEnv.MonadPretty where
+
+import Control.Lens (over, set, view, views, _1, _2)
+import Control.Monad.Reader (MonadReader, Reader, local, runReader)
+import qualified Data.Set as Set
+import Unison.Prelude (Set)
+import Unison.PrettyPrintEnv (PrettyPrintEnv)
+import Unison.Var (Var)
+
+type MonadPretty v m = (Var v, MonadReader (PrettyPrintEnv, Set v) m)
+
+getPPE :: MonadPretty v m => m PrettyPrintEnv
+getPPE = view _1
+
+-- | Run a computation with a modified PrettyPrintEnv, restoring the original
+withPPE :: MonadPretty v m => PrettyPrintEnv -> m a -> m a
+withPPE p = local (set _1 p)
+
+applyPPE :: MonadPretty v m => (PrettyPrintEnv -> a) -> m a
+applyPPE = views _1
+
+applyPPE2 :: MonadPretty v m => (PrettyPrintEnv -> a -> b) -> a -> m b
+applyPPE2 f a = views _1 (`f` a)
+
+applyPPE3 :: MonadPretty v m => (PrettyPrintEnv -> a -> b -> c) -> a -> b -> m c
+applyPPE3 f a b = views _1 (\ppe -> f ppe a b)
+
+-- | Run a computation with a modified PrettyPrintEnv, restoring the original
+modifyPPE :: MonadPretty v m => (PrettyPrintEnv -> PrettyPrintEnv) -> m a -> m a
+modifyPPE = local . over _1
+
+modifyTypeVars :: MonadPretty v m => (Set v -> Set v) -> m a -> m a
+modifyTypeVars = local . over _2
+
+-- | Add type variables to the set of variables that need to be avoided
+addTypeVars :: MonadPretty v m => [v] -> m a -> m a
+addTypeVars = modifyTypeVars . Set.union . Set.fromList
+
+-- | Check if a list of type variables contains any variables that need to be
+-- avoided
+willCapture :: MonadPretty v m => [v] -> m Bool
+willCapture vs = views _2 (not . Set.null . Set.intersection (Set.fromList vs))
+
+runPretty :: Var v => PrettyPrintEnv -> Reader (PrettyPrintEnv, Set v) a -> a
+runPretty ppe m = runReader m (ppe, mempty)

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

@@ -223,6 +223,108 @@ enclose keep rec t@(Handle' h body)
       | otherwise = lam' a evs lbody
 enclose _ _ _ = Nothing
 
+newtype Prefix v x = Pfx (Map v [v]) deriving (Show)
+
+instance Functor (Prefix v) where
+  fmap _ (Pfx m) = Pfx m
+instance Ord v => Applicative (Prefix v) where
+  pure _ = Pfx Map.empty
+  Pfx ml <*> Pfx mr = Pfx $ Map.unionWith common ml mr
+
+common :: Eq v => [v] -> [v] -> [v]
+common (u:us) (v:vs)
+  | u == v = u : common us vs
+common _ _ = []
+
+splitPfx :: v -> [Term v a] -> (Prefix v x, [Term v a])
+splitPfx v = first (Pfx . Map.singleton v) . split
+  where
+    split (Var' u : as) = first (u :) $ split as
+    split rest = ([], rest)
+
+-- Finds the common variable prefixes that function variables are
+-- applied to, so that they can be reduced.
+prefix :: Ord v => Term v a -> Prefix v (Term v a)
+prefix = ABT.visit \case
+  Apps' (Var' u) as -> case splitPfx u as of
+    (pf, rest) -> Just $ traverse prefix rest *> pf
+  _ -> Nothing
+
+appPfx :: Ord v => Prefix v a -> v -> [v] -> [v]
+appPfx (Pfx m) v = maybe id common $ Map.lookup v m
+
+-- Rewrites a term by dropping the first n arguments to every
+-- application of `v`. This just assumes such a thing makes sense, as
+-- in `beta`, where we've calculated how many arguments to drop by
+-- looking at every occurrence of `v`.
+dropPrefix :: Ord v => Semigroup a => v -> Int -> Term v a -> Term v a
+dropPrefix _ 0 = id
+dropPrefix v n = ABT.visitPure rw
+  where
+    rw (Apps' f@(Var' u) as)
+      | v == u = Just (apps' (var (ABT.annotation f) u) (drop n as))
+    rw _ = Nothing
+
+dropPrefixes
+  :: Ord v => Semigroup a => Map v Int -> Term v a -> Term v a
+dropPrefixes m = ABT.visitPure rw
+  where
+    rw (Apps' f@(Var' u) as)
+      | Just n <- Map.lookup u m =
+        Just (apps' (var (ABT.annotation f) u) (drop n as))
+    rw _ = Nothing
+
+-- Performs opposite transformations to those in enclose. Named after
+-- the lambda case, which is beta reduction.
+beta :: Var v => Monoid a => (Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
+beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
+  Just $ letRec' top lvbs lbd
+  where
+  -- Avoid completely reducing a lambda expression, because recursive
+  -- lets must be guarded.
+  args (v, LamsNamed' vs Ann'{}) = (v, vs)
+  args (v, LamsNamed' vs _) = (v, init vs)
+  args (v, _) = (v, [])
+
+  Pfx m0 = traverse_ (prefix . snd) vbs *> prefix bd
+
+  f ls rs = case common ls rs of
+    [] -> Nothing
+    vs -> Just vs
+
+  m = Map.map length $ Map.differenceWith f (Map.fromList $ map args vbs) m0
+  lvbs = vbs <&> \(v, b0) -> (,) v $ case b0 of
+    LamsNamed' vs b | Just n <- Map.lookup v m ->
+      lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
+    -- shouldn't happen
+    b -> dropPrefixes m b
+
+  lbd = dropPrefixes m bd
+
+beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
+  | n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e)
+  | otherwise = Nothing
+  where
+    lamb = lam' al (drop n vs) (bd)
+    al = ABT.annotation l
+    -- Calculate a maximum number of arguments to drop.
+    -- Enclosing doesn't create let-bound lambdas, so we
+    -- should never reduce a lambda to a non-lambda, as that
+    -- could affect evaluation order.
+    m | Ann' _ _ <- bd = length vs
+      | otherwise = length vs - 1
+    n = min m . length $ appPfx (prefix e) v vs
+
+beta rec (Apps' l@(LamsNamed' vs body) as)
+  | n <- matchVars 0 vs as
+  , n > 0 = Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as)
+  | otherwise = Nothing
+  where
+    al = ABT.annotation l
+    matchVars !n (u:us) (Var' v : as) | u == v = matchVars (1+n) us as
+    matchVars n _ _ = n
+beta _ _ = Nothing
+
 isStructured :: Var v => Term v a -> Bool
 isStructured (Var' _) = False
 isStructured (Lam' _) = False
@@ -242,6 +344,10 @@ isStructured _ = True
 close :: (Var v, Monoid a) => Set v -> Term v a -> Term v a
 close keep tm = ABT.visitPure (enclose keep close) tm
 
+-- Attempts to undo what was done in `close`. Useful for decompiling.
+open :: (Var v, Monoid a) => Term v a -> Term v a
+open x = ABT.visitPure (beta open) x
+
 type FloatM v a r = State (Set v, [(v, Term v a)], [(v, Term v a)]) r
 
 freshFloat :: Var v => Set v -> v -> v
@@ -365,7 +471,7 @@ float tm = case runState go0 (Set.empty, [], []) of
         subm = Map.fromList subvs
      in ( letRec' True [] . ABT.substs subs . deannotate $ bd,
           fmap (first DerivedId) tops,
-          dcmp <&> \(v, tm) -> (DerivedId $ subm Map.! v, tm)
+          dcmp <&> \(v, tm) -> (DerivedId $ subm Map.! v, open tm)
         )
   where
     go0 = fromMaybe (go tm) (floater True go tm)

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

@@ -2696,7 +2696,7 @@ declareForeigns = do
   declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray
   declareForeign Untracked "Scope.bytearrayOf" natNatToBox
     . mkForeign
-    $ \(sz, init) -> do
+    $ \(init, sz) -> do
       arr <- PA.newByteArray sz
       PA.fillByteArray arr 0 sz init
       pure arr

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

@@ -6,10 +6,11 @@ import Data.Text
 import GHC.Stack
 import Unison.Runtime.Stack
 import Unison.Util.Pretty as P
+import Unison.Reference (Reference)
 
 data RuntimeExn
   = PE CallStack (P.Pretty P.ColorText)
-  | BU Text Closure
+  | BU [(Reference,Int)] Text Closure
   deriving (Show)
 
 instance Exception RuntimeExn

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

@@ -92,6 +92,7 @@ import Unison.Runtime.Pattern
 import Unison.Runtime.Serialize as SER
 import Unison.Runtime.Stack
 import Unison.Symbol (Symbol)
+import Unison.Syntax.NamePrinter (prettyHashQualified)
 import Unison.Syntax.TermPrinter
 import qualified Unison.Term as Tm
 import Unison.Util.EnumContainers as EC
@@ -361,7 +362,7 @@ evalInContext ppe ctx activeThreads w = do
       decom = decompile (backReferenceTm crs (decompTm ctx))
 
       prettyError (PE _ p) = p
-      prettyError (BU nm c) = either id (bugMsg ppe nm) $ decom c
+      prettyError (BU tr nm c) = either id (bugMsg ppe tr nm) $ decom c
 
       tr tx c = case decom c of
         Right dv -> do
@@ -394,13 +395,18 @@ executeMainComb init cc = do
     Right () -> pure (Right ())
   where
     formatErr (PE _ msg) = pure msg
-    formatErr (BU nm c) = do
+    formatErr (BU tr nm c) = do
       crs <- readTVarIO (combRefs cc)
       let decom = decompile (backReferenceTm crs (decompTm $ cacheContext cc))
-      pure . either id (bugMsg PPE.empty nm) $ decom c
+      pure . either id (bugMsg PPE.empty tr nm) $ decom c
 
-bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText
-bugMsg ppe name tm
+bugMsg
+  :: PrettyPrintEnv
+  -> [(Reference, Int)]
+  -> Text
+  -> Term Symbol
+  -> Pretty ColorText
+bugMsg ppe tr name tm
   | name == "blank expression" =
       P.callout icon . P.lines $
         [ P.wrap
@@ -409,8 +415,8 @@ bugMsg ppe name tm
             ),
           "",
           P.indentN 2 $ pretty ppe tm,
-          "",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
         ]
   | "pattern match failure" `isPrefixOf` name =
       P.callout icon . P.lines $
@@ -423,13 +429,16 @@ bugMsg ppe name tm
           "",
           "This happens when calling a function that doesn't handle all \
           \possible inputs",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
         ]
   | name == "builtin.raise" =
       P.callout icon . P.lines $
         [ P.wrap ("The program halted with an unhandled exception:"),
           "",
-          P.indentN 2 $ pretty ppe tm
+          P.indentN 2 $ pretty ppe tm,
+          "\n",
+          stackTrace ppe tr
         ]
   | name == "builtin.bug",
     RF.TupleTerm' [Tm.Text' msg, x] <- tm,
@@ -444,9 +453,10 @@ bugMsg ppe name tm
           "",
           "This happens when calling a function that doesn't handle all \
           \possible inputs",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
         ]
-bugMsg ppe name tm =
+bugMsg ppe tr name tm =
   P.callout icon . P.lines $
     [ P.wrap
         ( "I've encountered a call to" <> P.red (P.text name)
@@ -454,18 +464,26 @@ bugMsg ppe name tm =
         ),
       "",
       P.indentN 2 $ pretty ppe tm,
-      "",
-      sorryMsg
+      "\n",
+      stackTrace ppe tr
     ]
-  where
 
-icon, sorryMsg :: Pretty ColorText
+stackTrace :: PrettyPrintEnv -> [(Reference, Int)] -> Pretty ColorText
+stackTrace ppe tr = "Stack trace:\n" <> P.indentN 2 (P.lines $ f <$> tr)
+  where
+    f (rf, n) = name <> count
+      where
+        count
+          | n > 1 = " (" <> fromString (show n) <> " copies)"
+          | otherwise = ""
+        name =
+          syntaxToColor .
+            prettyHashQualified .
+            PPE.termName ppe .
+            RF.Ref $ rf
+
+icon :: Pretty ColorText
 icon = "💔💥"
-sorryMsg =
-  P.wrap $
-    "I'm sorry this message doesn't have more detail about"
-      <> "the location of the failure."
-      <> "My makers plan to fix this in a future release. 😢"
 
 catchInternalErrors ::
   IO (Either Error a) ->
@@ -536,7 +554,7 @@ tryM :: IO () -> IO (Maybe Error)
 tryM = fmap (either (Just . extract) (const Nothing)) . try
   where
     extract (PE _ e) = e
-    extract (BU _ _) = "impossible"
+    extract (BU _ _ _) = "impossible"
 
 runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ())
 runStandalone sc init =

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

@@ -28,6 +28,7 @@ module Unison.Runtime.MCode
     emitComb,
     emptyRNs,
     argsToLists,
+    combRef,
     combDeps,
     combTypes,
     prettyCombs,
@@ -543,6 +544,9 @@ data CombIx
       !Word64 -- section
   deriving (Eq, Ord, Show)
 
+combRef :: CombIx -> Reference
+combRef (CIx r _ _) = r
+
 data RefNums = RN
   { dnum :: Reference -> Word64,
     cnum :: Reference -> Word64

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

@@ -152,7 +152,7 @@ eval0 !env !activeThreads !co = do
   bstk <- alloc
   (denv, k) <-
     topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env)
-  eval env denv activeThreads ustk bstk (k KE) co
+  eval env denv activeThreads ustk bstk (k KE) dummyRef co
 
 topDEnv ::
   M.Map Reference Word64 ->
@@ -241,31 +241,32 @@ exec ::
   Stack 'UN ->
   Stack 'BX ->
   K ->
+  Reference ->
   Instr ->
   IO (DEnv, Stack 'UN, Stack 'BX, K)
-exec !_ !denv !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !ustk !bstk !k (Capture p) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Capture p) = do
   (cap, denv, ustk, bstk, k) <- splitCont denv ustk bstk k p
   bstk <- bump bstk
   poke bstk cap
   pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !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 !_activeThreads !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 !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 MISS i)
   | sandboxed env = die "attempted to use sandboxed operation: isMissing"
   | otherwise = do
       clink <- peekOff bstk i
@@ -274,7 +275,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
       ustk <- bump ustk
       if (link `M.member` m) then poke ustk 1 else poke ustk 0
       pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CACH i)
   | sandboxed env = die "attempted to use sandboxed operation: cache"
   | otherwise = do
       arg <- peekOffS bstk i
@@ -285,7 +286,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
         bstk
         (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown)
       pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CVLD i)
   | sandboxed env = die "attempted to use sandboxed operation: validate"
   | otherwise = do
       arg <- peekOffS bstk i
@@ -303,7 +304,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
           pokeOffBi bstk 1 msg
           pokeOff bstk 2 clo
           pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LKUP i)
   | sandboxed env = die "attempted to use sandboxed operation: lookup"
   | otherwise = do
       clink <- peekOff bstk i
@@ -323,14 +324,14 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
           bstk <- bump bstk
           bstk <$ pokeBi bstk sg
       pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !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 !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LOAD i)
   | sandboxed env = die "attempted to use sandboxed operation: load"
   | otherwise = do
       v <- peekOffBi bstk i
@@ -345,16 +346,16 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
           poke ustk 1
           poke bstk x
       pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !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 !_activeThreads !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 !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 SDBX i j) = do
   s <- peekOffS bstk i
   c <- peekOff bstk j
   l <- decodeSandboxArgument s
@@ -362,92 +363,96 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
   ustk <- bump ustk
   poke ustk $ if b then 1 else 0
   pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !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 !_activeThreads !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 !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j)
+exec !_   !_    !_activeThreads !_    !bstk !k r (BPrim2 THRO i j) = do
+  name <- peekOffBi @Util.Text.Text bstk i
+  x <- peekOff bstk j
+  throwIO (BU (traceK r k) (Util.Text.toText name) x)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 TRCE i j)
   | sandboxed env = die "attempted to use sandboxed operation: trace"
   | otherwise = do
       tx <- peekOffBi bstk i
       clo <- peekOff bstk j
       tracer env tx clo
       pure (denv, ustk, bstk, k)
-exec !_ !denv !_trackThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !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 !_activeThreads !ustk !bstk !k (Reset ps) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Reset ps) = do
   (ustk, ua) <- saveArgs ustk
   (bstk, ba) <- saveArgs bstk
   pure (denv, ustk, bstk, Mark ua ba ps clos k)
   where
     clos = EC.restrictKeys denv ps
-exec !_ !denv !_activeThreads !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 !_activeThreads !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 !activeThreads !ustk !bstk !k (Fork i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (Fork i)
   | sandboxed env = die "attempted to use sandboxed operation: fork"
   | otherwise = 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 !activeThreads !ustk !bstk !k (Atomically i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (Atomically i)
   | sandboxed env = die $ "attempted to use sandboxed operation: atomically"
   | otherwise = do
       c <- peekOff bstk i
       bstk <- bump bstk
       atomicEval env activeThreads (poke bstk) c
       pure (denv, ustk, bstk, k)
-exec !env !denv !activeThreads !ustk !bstk !k (TryForce i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (TryForce i)
   | sandboxed env = die $ "attempted to use sandboxed operation: tryForce"
   | otherwise = do
       c <- peekOff bstk i
@@ -478,7 +483,7 @@ encodeExn ustk bstk (Left exn) = do
       | Just re <- fromException exn = case re of
           PE _stk msg ->
             (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue)
-          BU tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
+          BU _ tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
       | Just (ae :: ArithException) <- fromException exn =
           (Rf.arithmeticFailureRef, disp ae, unitValue)
       | Just (nae :: NestedAtomically) <- fromException exn =
@@ -496,15 +501,16 @@ eval ::
   Stack 'UN ->
   Stack 'BX ->
   K ->
+  Reference ->
   Section ->
   IO ()
-eval !env !denv !activeThreads !ustk !bstk !k (Match i (TestT df cs)) = do
+eval !env !denv !activeThreads !ustk !bstk !k r (Match i (TestT df cs)) = do
   t <- peekOffBi bstk i
-  eval env denv activeThreads ustk bstk k $ selectTextBranch t df cs
-eval !env !denv !activeThreads !ustk !bstk !k (Match i br) = do
+  eval env denv activeThreads ustk bstk k r $ selectTextBranch t df cs
+eval !env !denv !activeThreads !ustk !bstk !k r (Match i br) = do
   n <- peekOffN ustk i
-  eval env denv activeThreads ustk bstk k $ selectBranch n br
-eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
+  eval env denv activeThreads ustk bstk k r $ selectBranch n br
+eval !env !denv !activeThreads !ustk !bstk !k _ (Yield args)
   | asize ustk + asize bstk > 0,
     BArg1 i <- args =
       peekOff bstk i >>= apply env denv activeThreads ustk bstk k False ZArgs
@@ -513,23 +519,23 @@ eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
       ustk <- frameArgs ustk
       bstk <- frameArgs bstk
       yield env denv activeThreads ustk bstk k
-eval !env !denv !activeThreads !ustk !bstk !k (App ck r args) =
+eval !env !denv !activeThreads !ustk !bstk !k _ (App ck r args) =
   resolve env denv bstk r
     >>= apply env denv activeThreads ustk bstk k ck args
-eval !env !denv !activeThreads !ustk !bstk !k (Call ck n args) =
+eval !env !denv !activeThreads !ustk !bstk !k _ (Call ck n args) =
   combSection env (CIx dummyRef n 0)
     >>= enter env denv activeThreads ustk bstk k ck args
-eval !env !denv !activeThreads !ustk !bstk !k (Jump i 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
+eval !env !denv !activeThreads !ustk !bstk !k r (Let nw cix) = do
   (ustk, ufsz, uasz) <- saveFrame ustk
   (bstk, bfsz, basz) <- saveFrame bstk
-  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
+  eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) r nw
+eval !env !denv !activeThreads !ustk !bstk !k r (Ins i nx) = do
+  (denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k r i
+  eval env denv activeThreads ustk bstk k r nx
+eval !_ !_ !_ !_activeThreads !_ !_ _ Exit = pure ()
+eval !_ !_ !_ !_activeThreads !_ !_ _ (Die s) = die s
 {-# NOINLINE eval #-}
 
 forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId
@@ -587,7 +593,9 @@ enter !env !denv !activeThreads !ustk !bstk !k !ck !args !comb = do
   (ustk, bstk) <- moveArgs ustk bstk args
   ustk <- acceptArgs ustk ua
   bstk <- acceptArgs bstk ba
-  eval env denv activeThreads ustk bstk k entry
+  -- TODO: start putting references in `Call` if we ever start
+  -- detecting saturated calls.
+  eval env denv activeThreads ustk bstk k dummyRef entry
   where
     Lam ua ba uf bf entry = comb
 {-# INLINE enter #-}
@@ -626,7 +634,7 @@ apply !env !denv !activeThreads !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 activeThreads ustk bstk k entry
+          eval env denv activeThreads ustk bstk k (combRef comb) entry
       | otherwise -> do
           (useg, bseg) <- closeArgs C ustk bstk useg bseg args
           ustk <- discardFrame =<< frameArgs ustk
@@ -1594,10 +1602,7 @@ bprim2 !ustk !bstk CATB i j = do
   bstk <- bump bstk
   pokeBi bstk (l <> r :: By.Bytes)
   pure (ustk, bstk)
-bprim2 !_ !bstk THRO i j = do
-  name <- peekOffBi @Util.Text.Text bstk i
-  x <- peekOff bstk j
-  throwIO (BU (Util.Text.toText name) x)
+bprim2 !ustk !bstk THRO _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk TRCE _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk CMPU _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk SDBX _ _ = pure (ustk, bstk) -- impossible
@@ -1626,7 +1631,7 @@ yield !env !denv !activeThreads !ustk !bstk !k = leap denv k
       bstk <- restoreFrame bstk bfsz basz
       ustk <- ensure ustk uf
       bstk <- ensure bstk bf
-      eval env denv activeThreads ustk bstk k nx
+      eval env denv activeThreads ustk bstk k (combRef cix) nx
     leap _ (CB (Hook f)) = f ustk bstk
     leap _ KE = pure ()
 {-# INLINE yield #-}
@@ -1713,7 +1718,7 @@ resolve env _ _ (Env n i) =
 resolve _ _ bstk (Stk i) = peekOff bstk i
 resolve _ denv _ (Dyn i) = case EC.lookup i denv of
   Just clo -> pure clo
-  _ -> die $ "resolve: looked up bad dynamic: " ++ show i
+  _ -> die $ "resolve: unhandled ability request: " ++ show i
 
 combSection :: HasCallStack => CCache -> CombIx -> IO Comb
 combSection env (CIx _ n i) =
@@ -2157,7 +2162,8 @@ universalCompare frn = cmpc False
     cmpc tyEq (Foreign fl) (Foreign fr)
       | Just sl <- maybeUnwrapForeign Rf.listRef fl,
         Just sr <- maybeUnwrapForeign Rf.listRef fr =
-          comparing Sq.length sl sr <> fold (Sq.zipWith (cmpc tyEq) sl sr)
+          fold (Sq.zipWith (cmpc tyEq) sl sr)
+            <> compare (length sl) (length sr)
       | Just al <- maybeUnwrapForeign Rf.iarrayRef fl,
         Just ar <- maybeUnwrapForeign Rf.iarrayRef fr =
           arrayCmp (cmpc tyEq) al ar

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

@@ -17,6 +17,7 @@ module Unison.Runtime.Stack
     Off,
     SZ,
     FP,
+    traceK,
     frameDataSize,
     marshalToForeign,
     unull,
@@ -109,6 +110,14 @@ data Closure
   | BlackHole
   deriving (Show, Eq, Ord)
 
+traceK :: Reference -> K -> [(Reference, Int)]
+traceK begin = dedup (begin, 1) where
+  dedup p (Mark _ _ _ _ k) = dedup p k
+  dedup p@(cur,n) (Push _ _ _ _ (CIx r _ _) k)
+    | cur == r = dedup (cur,1+n) k
+    | otherwise = p : dedup (r,1) k
+  dedup p _ = [p]
+
 splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure])
 splitData (Enum r t) = Just (r, t, [], [])
 splitData (DataU1 r t i) = Just (r, t, [i], [])

parser-typechecker/src/Unison/Syntax/DeclPrinter.hs

@@ -22,6 +22,7 @@ import Unison.Reference (Reference (DerivedId))
 import qualified Unison.Referent as Referent
 import qualified Unison.Result as Result
 import Unison.Syntax.NamePrinter (styleHashQualified'')
+import Unison.Syntax.TypePrinter (runPretty)
 import qualified Unison.Syntax.TypePrinter as TypePrinter
 import qualified Unison.Term as Term
 import qualified Unison.Type as Type
@@ -73,9 +74,9 @@ prettyGADT env ctorType r name dd =
   where
     constructor (n, (_, _, t)) =
       prettyPattern env ctorType name (ConstructorReference r n)
-        <> (fmt S.TypeAscriptionColon " :")
-        `P.hang` TypePrinter.pretty0 env Map.empty (-1) t
-    header = prettyEffectHeader name (DD.EffectDeclaration dd) <> (fmt S.ControlKeyword " where")
+        <> fmt S.TypeAscriptionColon " :"
+        `P.hang` TypePrinter.prettySyntax env t
+    header = prettyEffectHeader name (DD.EffectDeclaration dd) <> fmt S.ControlKeyword " where"
 
 prettyPattern ::
   PrettyPrintEnv ->
@@ -86,7 +87,7 @@ prettyPattern ::
 prettyPattern env ctorType namespace ref =
   styleHashQualified''
     (fmt (S.TermReference conRef))
-    ( HQ.stripNamespace (fromMaybe "" $ Name.toText <$> HQ.toName namespace) $
+    ( HQ.stripNamespace (maybe "" Name.toText (HQ.toName namespace)) $
         PPE.termName env conRef
     )
   where
@@ -106,26 +107,26 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
         [0 ..]
         (DD.constructors' dd)
   where
-    constructor (n, (_, _, (Type.ForallsNamed' _ t))) = constructor' n t
+    constructor (n, (_, _, Type.ForallsNamed' _ t)) = constructor' n t
     constructor (n, (_, _, t)) = constructor' n t
     constructor' n t = case Type.unArrows t of
       Nothing -> prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)
       Just ts -> case fieldNames unsuffixifiedPPE r name dd of
         Nothing ->
           P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)) "      " $
-            P.spaced (TypePrinter.prettyRaw suffixifiedPPE Map.empty 10 <$> init ts)
+            P.spaced (runPretty suffixifiedPPE (traverse (TypePrinter.prettyRaw Map.empty 10) (init ts)))
         Just fs ->
           P.group $
-            (fmt S.DelimiterChar "{ ")
+            fmt S.DelimiterChar "{ "
               <> P.sep
-                ((fmt S.DelimiterChar ",") <> " " `P.orElse` "\n      ")
+                (fmt S.DelimiterChar "," <> " " `P.orElse` "\n      ")
                 (field <$> zip fs (init ts))
-              <> (fmt S.DelimiterChar " }")
+              <> fmt S.DelimiterChar " }"
     field (fname, typ) =
       P.group $
         styleHashQualified'' (fmt (S.TypeReference r)) fname
-          <> (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw suffixifiedPPE Map.empty (-1) typ
-    header = prettyDataHeader name dd <> (fmt S.DelimiterChar (" = " `P.orElse` "\n  = "))
+          <> fmt S.TypeAscriptionColon " :" `P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
+    header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n  = ")
 
 -- Comes up with field names for a data declaration which has the form of a
 -- record, like `type Pt = { x : Int, y : Int }`. Works by generating the

parser-typechecker/src/Unison/Syntax/TypePrinter.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Unison.Syntax.TypePrinter
   ( pretty,
@@ -12,6 +13,7 @@ module Unison.Syntax.TypePrinter
     prettySignaturesCTCollapsed,
     prettySignaturesAlt,
     prettySignaturesAlt',
+    runPretty,
   )
 where
 
@@ -23,6 +25,7 @@ import Unison.Prelude
 import Unison.PrettyPrintEnv (PrettyPrintEnv)
 import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
 import Unison.PrettyPrintEnv.FQN (Imports, elideFQN)
+import Unison.PrettyPrintEnv.MonadPretty (MonadPretty, getPPE, runPretty, willCapture)
 import Unison.Reference (Reference, pattern Builtin)
 import Unison.Referent (Referent)
 import Unison.Syntax.NamePrinter (styleHashQualified'')
@@ -36,17 +39,17 @@ import qualified Unison.Var as Var
 
 type SyntaxText = S.SyntaxText' Reference
 
-pretty :: forall v a. (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText
-pretty ppe = PP.syntaxToColor . prettySyntax ppe
+pretty :: Var v => PrettyPrintEnv -> Type v a -> Pretty ColorText
+pretty ppe t = PP.syntaxToColor $ prettySyntax ppe t
 
-prettySyntax :: forall v a. (Var v) => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
-prettySyntax ppe = pretty0 ppe mempty (-1)
+prettySyntax :: Var v => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
+prettySyntax ppe = runPretty ppe . pretty0 Map.empty (-1)
 
 prettyStr :: Var v => Maybe Width -> PrettyPrintEnv -> Type v a -> String
-prettyStr (Just width) n t =
-  toPlain $ PP.render width $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
-prettyStr Nothing n t =
-  toPlain $ PP.render maxBound $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
+prettyStr (Just width) ppe t =
+  toPlain . PP.render width . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
+prettyStr Nothing ppe t =
+  toPlain . PP.render maxBound . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
 
 {- Explanation of precedence handling
 
@@ -71,90 +74,103 @@ prettyStr Nothing n t =
 -}
 
 pretty0 ::
-  forall v a.
-  (Var v) =>
-  PrettyPrintEnv ->
+  forall v a m.
+  MonadPretty v m =>
   Imports ->
   Int ->
   Type v a ->
-  Pretty SyntaxText
-pretty0 n im p tp = prettyRaw n im p (cleanup (removePureEffects tp))
+  m (Pretty SyntaxText)
+pretty0 im p tp = prettyRaw im p (cleanup (removePureEffects tp))
 
 prettyRaw ::
-  forall v a.
-  (Var v) =>
-  PrettyPrintEnv ->
+  forall v a m.
+  MonadPretty v m =>
   Imports ->
   Int ->
   Type v a ->
-  Pretty SyntaxText
+  m (Pretty SyntaxText)
 -- p is the operator precedence of the enclosing context (a number from 0 to
 -- 11, or -1 to avoid outer parentheses unconditionally).  Function
 -- application has precedence 10.
-prettyRaw n im p tp = go n im p tp
+prettyRaw im p tp = go im p tp
   where
-    go :: PrettyPrintEnv -> Imports -> Int -> Type v a -> Pretty SyntaxText
-    go n im p tp = case stripIntroOuters tp of
-      Var' v -> fmt S.Var $ PP.text (Var.name v)
-      DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas $ map (go n im 0) xs
+    go :: Imports -> Int -> Type v a -> m (Pretty SyntaxText)
+    go im p tp = case stripIntroOuters tp of
+      Var' v -> pure . fmt S.Var $ PP.text (Var.name v)
+      DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas <$> traverse (go im 0) xs
       -- Would be nice to use a different SyntaxHighlights color if the reference is an ability.
-      Ref' r -> styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r)
-      Cycle' _ _ -> fromString "error: TypeParser does not currently emit Cycle"
-      Abs' _ -> fromString "error: TypeParser does not currently emit Abs"
-      Ann' _ _ -> fromString "error: TypeParser does not currently emit Ann"
-      App' (Ref' (Builtin "Sequence")) x ->
-        PP.group $ (fmt S.DelimiterChar "[") <> go n im 0 x <> (fmt S.DelimiterChar "]")
+      Ref' r -> do
+        n <- getPPE
+        pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r)
+      Cycle' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Cycle"
+      Abs' _ -> pure $ fromString "bug: TypeParser does not currently emit Abs"
+      Ann' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Ann"
+      App' (Ref' (Builtin "Sequence")) x -> do
+        x' <- go im (-1) x
+        pure $ PP.group $ fmt S.DelimiterChar "[" <> x' <> fmt S.DelimiterChar "]"
       Apps' f xs ->
-        PP.parenthesizeIf (p >= 10) $
-          go n im 9 f
-            `PP.hang` PP.spaced
-              (go n im 10 <$> xs)
+        PP.parenthesizeIf (p >= 10)
+          <$> ( PP.hang <$> go im 9 f <*> (PP.spaced <$> traverse (go im 10) xs)
+              )
       Effect1' e t ->
-        PP.parenthesizeIf (p >= 10) $ go n im 9 e <> " " <> go n im 10 t
+        PP.parenthesizeIf (p >= 10) <$> ((\x y -> x <> " " <> y) <$> go im 9 e <*> go im 10 t)
       Effects' es -> effects (Just es)
       ForallsNamed' vs' body ->
         let vs = filter (\v -> Var.name v /= "()") vs'
-         in if p < 0 && all Var.universallyQuantifyIfFree vs
-              then go n im p body
-              else
-                paren (p >= 0) $
-                  let vformatted = PP.sep " " (fmt S.Var . PP.text . Var.name <$> vs)
-                   in (fmt S.TypeOperator "∀ " <> vformatted <> fmt S.TypeOperator ".")
-                        `PP.hang` go n im (-1) body
+            prettyForall p = do
+              let vformatted = PP.sep " " (fmt S.Var . PP.text . Var.name <$> vs)
+              PP.hang (fmt S.TypeOperator "∀ " <> vformatted <> fmt S.TypeOperator ".") <$> go im p body
+         in -- if we're printing a type signature, and all the type variables
+            -- are universally quantified, then we can omit the `forall` keyword
+            -- only if the type variables are not bound in an outer scope
+            if p < 0 && all Var.universallyQuantifyIfFree vs
+              then ifM (willCapture vs) (prettyForall p) (go im p body)
+              else paren (p >= 0) <$> prettyForall (-1)
       t@(Arrow' _ _) -> case t of
         EffectfulArrows' (Ref' DD.UnitRef) rest ->
-          PP.parenthesizeIf (p >= 10) $ arrows True True rest
+          PP.parenthesizeIf (p >= 10) <$> arrows True True rest
         EffectfulArrows' fst rest ->
           case fst of
             Var' v
               | Var.name v == "()" ->
-                  PP.parenthesizeIf (p >= 10) $ arrows True True rest
+                PP.parenthesizeIf (p >= 10) <$> arrows True True rest
             _ ->
-              PP.parenthesizeIf (p >= 0) $
-                go n im 0 fst <> arrows False False rest
-        _ -> "error"
-      _ -> "error"
-    effects Nothing = mempty
-    effects (Just es) = PP.group $ fmt S.AbilityBraces "{" <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}")
+              PP.parenthesizeIf (p >= 0)
+                <$> ((<>) <$> go im 0 fst <*> arrows False False rest)
+        _ -> pure . fromString $ "bug: unexpected Arrow form in prettyRaw: " <> show t
+      _ -> pure . fromString $ "bug: unexpected form in prettyRaw: " <> show tp
+    effects Nothing = pure mempty
+    effects (Just es) =
+      PP.group . (fmt S.AbilityBraces "{" <>) . (<> fmt S.AbilityBraces "}")
+        <$> (PP.commas <$> traverse (go im 0) es)
     -- `first`: is this the first argument?
     -- `mes`: list of effects
-    arrow delay first mes =
-      (if first then mempty else PP.softbreak <> fmt S.TypeOperator "->")
-        <> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty)
-        <> effects mes
-        <> if isJust mes || not delay && not first then " " else mempty
+    arrow delay first mes = do
+      es <- effects mes
+      pure $
+        (if first then mempty else PP.softbreak <> fmt S.TypeOperator "->")
+          <> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty)
+          <> es
+          <> if isJust mes || not delay && not first then " " else mempty
 
-    arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> fmt S.Unit "()"
-    arrows delay first ((mes, Ref' DD.UnitRef) : rest) =
-      arrow delay first mes <> parenNoGroup delay (arrows True True rest)
-    arrows delay first ((mes, arg) : rest) =
-      arrow delay first mes
-        <> parenNoGroup
-          (delay && not (null rest))
-          (go n im 0 arg <> arrows False False rest)
-    arrows False False [] = mempty
-    arrows False True [] = mempty -- not reachable
-    arrows True _ [] = mempty -- not reachable
+    arrows ::
+      Bool ->
+      Bool ->
+      [(Maybe [Type v a], Type v a)] ->
+      m (Pretty SyntaxText)
+    arrows delay first [(mes, Ref' DD.UnitRef)] = (<> fmt S.Unit "()") <$> arrow delay first mes
+    arrows delay first ((mes, Ref' DD.UnitRef) : rest) = do
+      es <- arrow delay first mes
+      rest' <- arrows True True rest
+      pure $ es <> parenNoGroup delay rest'
+    arrows delay first ((mes, arg) : rest) = do
+      es <- arrow delay first mes
+      arg' <- go im 0 arg
+      rest' <- arrows False False rest
+      pure $ es <> parenNoGroup (delay && not (null rest)) (arg' <> rest')
+    arrows False False [] = pure mempty
+    arrows False True [] = pure mempty -- not reachable
+    arrows True _ [] = pure mempty -- not reachable
     paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")"
     paren False s = PP.group s
 
@@ -170,30 +186,32 @@ prettySignaturesCT ::
   PrettyPrintEnv ->
   [(Referent, HashQualified Name, Type v a)] ->
   [Pretty ColorText]
-prettySignaturesCT env ts = map PP.syntaxToColor $ prettySignaturesST env ts
+prettySignaturesCT ppe ts = map PP.syntaxToColor $ prettySignaturesST ppe ts
 
 prettySignaturesCTCollapsed ::
   Var v =>
   PrettyPrintEnv ->
   [(Referent, HashQualified Name, Type v a)] ->
   Pretty ColorText
-prettySignaturesCTCollapsed env ts =
-  PP.lines $
-    PP.group <$> prettySignaturesCT env ts
+prettySignaturesCTCollapsed ppe ts =
+  PP.lines
+    . map PP.group
+    $ prettySignaturesCT ppe ts
 
 prettySignaturesST ::
   Var v =>
   PrettyPrintEnv ->
   [(Referent, HashQualified Name, Type v a)] ->
   [Pretty SyntaxText]
-prettySignaturesST env ts =
-  PP.align [(name r hq, sig typ) | (r, hq, typ) <- ts]
+prettySignaturesST ppe ts =
+  PP.align . runPretty ppe $ traverse (\(r, hq, typ) -> (name r hq,) <$> sig typ) ts
   where
     name r hq =
       styleHashQualified'' (fmt $ S.TermReference r) hq
-    sig typ =
-      (fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
-        `PP.orElse` (fmt S.TypeAscriptionColon ": " <> PP.indentNAfterNewline 2 (pretty0 env Map.empty (-1) typ))
+    sig typ = do
+      t <- pretty0 Map.empty (-1) typ
+      let col = fmt S.TypeAscriptionColon ": "
+      pure $ (col <> t) `PP.orElse` (col <> PP.indentNAfterNewline 2 t)
 
 -- todo: provide sample output in comment; different from prettySignatures'
 prettySignaturesAlt' ::
@@ -201,19 +219,21 @@ prettySignaturesAlt' ::
   PrettyPrintEnv ->
   [([HashQualified Name], Type v a)] ->
   [Pretty ColorText]
-prettySignaturesAlt' env ts =
-  map PP.syntaxToColor $
-    PP.align
-      [ ( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names,
-          (fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
-            `PP.orElse` ( fmt S.TypeAscriptionColon ": "
-                            <> PP.indentNAfterNewline 2 (pretty0 env Map.empty (-1) typ)
-                        )
+prettySignaturesAlt' ppe ts = runPretty ppe $
+  do
+    ts' <- traverse f ts
+    pure $ map PP.syntaxToColor $ PP.align ts'
+  where
+    f :: MonadPretty v m => ([HashQualified Name], Type v a) -> m (Pretty SyntaxText, Pretty SyntaxText)
+    f (names, typ) = do
+      typ' <- pretty0 Map.empty (-1) typ
+      let col = fmt S.TypeAscriptionColon ": "
+      pure
+        ( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names,
+          (col <> typ') `PP.orElse` (col <> PP.indentNAfterNewline 2 typ')
         )
-        | (names, typ) <- ts
-      ]
 
--- prettySignatures'' :: Var v => PrettyPrintEnv -> [(Name, Type v a)] -> [Pretty ColorText]
+-- prettySignatures'' :: Var v => [(Name, Type v a)] -> [Pretty ColorText]
 -- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts)
 
 prettySignaturesAlt ::
@@ -221,6 +241,7 @@ prettySignaturesAlt ::
   PrettyPrintEnv ->
   [([HashQualified Name], Type v a)] ->
   Pretty ColorText
-prettySignaturesAlt env ts =
-  PP.lines $
-    PP.group <$> prettySignaturesAlt' env ts
+prettySignaturesAlt ppe ts =
+  PP.lines
+    . map PP.group
+    $ prettySignaturesAlt' ppe ts

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

@@ -1,7 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
 
 module Unison.UnisonFile.Type where
 
@@ -10,6 +7,7 @@ import Data.Bifunctor (first)
 import qualified Unison.ABT as ABT
 import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
 import Unison.Prelude
+import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
 import qualified Unison.Reference as Reference
 import Unison.Term (Term)
 import qualified Unison.Term as Term
@@ -18,16 +16,16 @@ import qualified Unison.Type as Type
 import Unison.WatchKind (WatchKind)
 
 data UnisonFile v a = UnisonFileId
-  { dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a),
-    effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a),
+  { dataDeclarationsId :: Map v (TermReferenceId, DataDeclaration v a),
+    effectDeclarationsId :: Map v (TermReferenceId, EffectDeclaration v a),
     terms :: [(v, Term v a)],
     watches :: Map WatchKind [(v, Term v a)]
   }
   deriving (Show)
 
 pattern UnisonFile ::
-  Map v (Reference.Reference, DataDeclaration v a) ->
-  Map v (Reference.Reference, EffectDeclaration v a) ->
+  Map v (TypeReference, DataDeclaration v a) ->
+  Map v (TypeReference, EffectDeclaration v a) ->
   [(v, Term v a)] ->
   Map WatchKind [(v, Term v a)] ->
   UnisonFile v a
@@ -43,24 +41,24 @@ pattern UnisonFile ds es tms ws <-
 -- | A UnisonFile after typechecking. Terms are split into groups by
 --  cycle and the type of each term is known.
 data TypecheckedUnisonFile v a = TypecheckedUnisonFileId
-  { dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a),
-    effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a),
+  { dataDeclarationsId' :: Map v (TypeReferenceId, DataDeclaration v a),
+    effectDeclarationsId' :: Map v (TypeReferenceId, EffectDeclaration v a),
     topLevelComponents' :: [[(v, Term v a, Type v a)]],
     watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])],
-    hashTermsId :: Map v (Reference.Id, Maybe WatchKind, Term v a, Type v a)
+    hashTermsId :: Map v (TermReferenceId, Maybe WatchKind, Term v a, Type v a)
   }
   deriving stock (Generic, Show)
 
 {-# COMPLETE TypecheckedUnisonFile #-}
 
 pattern TypecheckedUnisonFile ::
-  Map v (Reference.Reference, DataDeclaration v a) ->
-  Map v (Reference.Reference, EffectDeclaration v a) ->
+  Map v (TypeReference, DataDeclaration v a) ->
+  Map v (TypeReference, EffectDeclaration v a) ->
   [[(v, Term v a, Type v a)]] ->
   [(WatchKind, [(v, Term v a, Type v a)])] ->
   Map
     v
-    ( Reference.Reference,
+    ( TermReference,
       Maybe WatchKind,
       ABT.Term (Term.F v a a) v a,
       ABT.Term Type.F v a

parser-typechecker/src/Unison/Util/Pretty/MegaParsec.hs

@@ -0,0 +1,63 @@
+module Unison.Util.Pretty.MegaParsec where
+
+import qualified Data.List.NonEmpty as NE
+import Data.Proxy
+import Data.Void
+import qualified Text.Megaparsec as Parser
+import Unison.Prelude
+import qualified Unison.Util.Pretty as P
+
+prettyPrintParseError :: String -> Parser.ParseErrorBundle Text Void -> P.Pretty P.ColorText
+prettyPrintParseError input errBundle =
+  let (firstError, sp) = NE.head . fst $ Parser.attachSourcePos Parser.errorOffset (Parser.bundleErrors errBundle) (Parser.bundlePosState errBundle)
+   in case firstError of
+        Parser.TrivialError _errorOffset ue ee ->
+          P.lines
+            [ printLocation sp,
+              P.newline,
+              printTrivial ue ee
+            ]
+        Parser.FancyError _errorOffset ee ->
+          let errors = foldMap (P.string . mappend "\n" . showErrorFancy) ee
+           in P.lines
+                [ printLocation sp,
+                  errors
+                ]
+  where
+    printLocation :: Parser.SourcePos -> P.Pretty P.ColorText
+    printLocation sp =
+      let col = (Parser.unPos $ Parser.sourceColumn sp) - 1
+          row = (Parser.unPos $ Parser.sourceLine sp) - 1
+          errorLine = lines input !! row
+       in P.lines
+            [ P.newline,
+              P.string errorLine,
+              P.string $ Prelude.replicate col ' ' <> "^-- This is where I gave up."
+            ]
+
+    printTrivial :: (Maybe (Parser.ErrorItem Char)) -> (Set (Parser.ErrorItem Char)) -> P.Pretty P.ColorText
+    printTrivial ue ee =
+      let expected = "I expected " <> foldMap (P.singleQuoted . P.string . showErrorItem) ee
+          found = P.string . mappend "I found " . showErrorItem <$> ue
+          message = [expected] <> catMaybes [found]
+       in P.oxfordCommasWith "." message
+
+showErrorFancy :: Parser.ShowErrorComponent e => Parser.ErrorFancy e -> String
+showErrorFancy (Parser.ErrorFail msg) = msg
+showErrorFancy (Parser.ErrorIndentation ord ref actual) =
+  "incorrect indentation (got " <> show (Parser.unPos actual)
+    <> ", should be "
+    <> p
+    <> show (Parser.unPos ref)
+    <> ")"
+  where
+    p = case ord of
+      LT -> "less than "
+      EQ -> "equal to "
+      GT -> "greater than "
+showErrorFancy (Parser.ErrorCustom a) = Parser.showErrorComponent a
+
+showErrorItem :: Parser.ErrorItem (Parser.Token Text) -> String
+showErrorItem (Parser.Tokens ts) = Parser.showTokens (Proxy @Text) ts
+showErrorItem (Parser.Label label) = NE.toList label
+showErrorItem Parser.EndOfInput = "end of input"

parser-typechecker/src/Unison/Util/Text/Pattern.hs

@@ -47,11 +47,47 @@ cpattern p = CP p (run p)
 
 run :: Pattern -> Text -> Maybe ([Text], Text)
 run p =
-  let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem))
-   in \t -> cp [] t
+  let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (s acc, rem))
+      s = reverse . capturesToList . stackCaptures
+   in \t -> cp (Empty emptyCaptures) t
 
--- Pattern a -> ([a] -> a -> r) -> ... -- might need a takeable and droppable interface if go this route
-compile :: Pattern -> ([Text] -> Text -> r) -> ([Text] -> Text -> r) -> [Text] -> Text -> r
+-- Stack used to track captures and to support backtracking.
+-- A `try` will push a `Mark` that allows the old state
+-- (both the list of captures and the current remainder)
+-- to be restored on failure.
+data Stack = Empty !Captures | Mark !Captures !Text !Stack
+
+-- A difference list for representing the captures of a pattern.
+-- So that capture lists can be appended in O(1).
+type Captures = [Text] -> [Text]
+
+stackCaptures :: Stack -> Captures
+stackCaptures (Mark cs _ _) = cs
+stackCaptures (Empty cs) = cs
+{-# INLINE stackCaptures #-}
+
+pushCaptures :: Captures -> Stack -> Stack
+pushCaptures c (Empty cs) = Empty (appendCaptures c cs)
+pushCaptures c (Mark cs t s) = Mark (appendCaptures c cs) t s
+{-# INLINE pushCaptures #-}
+
+pushCapture :: Text -> Stack -> Stack
+pushCapture txt = pushCaptures (txt :)
+{-# INLINE pushCapture #-}
+
+appendCaptures :: Captures -> Captures -> Captures
+appendCaptures c1 c2 = c1 . c2
+{-# INLINE appendCaptures #-}
+
+emptyCaptures :: Captures
+emptyCaptures = id
+
+capturesToList :: Captures -> [Text]
+capturesToList c = c []
+
+type Compiled r = (Stack -> Text -> r) -> (Stack -> Text -> r) -> Stack -> Text -> r
+
+compile :: Pattern -> Compiled r
 compile !Eof !err !success = go
   where
     go acc t
@@ -68,17 +104,17 @@ compile AnyChar !err !success = go
       rem
         | Text.size t > Text.size rem -> success acc rem
         | otherwise -> err acc rem
-compile (Capture (Many AnyChar)) !_ !success = \acc t -> success (t : acc) Text.empty
+compile (Capture (Many AnyChar)) !_ !success = \acc t -> success (pushCapture t acc) Text.empty
 compile (Capture c) !err !success = go
   where
     err' _ _ acc0 t0 = err acc0 t0
-    success' _ rem acc0 t0 = success (Text.take (Text.size t0 - Text.size rem) t0 : acc0) rem
+    success' _ rem acc0 t0 = success (pushCapture (Text.take (Text.size t0 - Text.size rem) t0) acc0) rem
     compiled = compile c err' success'
     go acc t = compiled acc t acc t
 compile (Or p1 p2) err success = cp1
   where
     cp2 = compile p2 err success
-    cp1 = compile p1 cp2 success
+    cp1 = try "Or" (compile p1) cp2 success
 compile (Join ps) !err !success = go ps
   where
     go [] = success
@@ -112,6 +148,8 @@ compile (Many p) !_ !success = case p of
   AnyChar -> (\acc _ -> success acc Text.empty)
   CharIn cs -> walker (charInPred cs)
   NotCharIn cs -> walker (charNotInPred cs)
+  CharRange c1 c2 -> walker (\ch -> ch >= c1 && c1 <= c2)
+  NotCharRange c1 c2 -> walker (\ch -> ch < c1 || ch > c2)
   Digit -> walker isDigit
   Letter -> walker isLetter
   Punctuation -> walker isPunctuation
@@ -144,16 +182,18 @@ compile (Replicate m n p) !err !success = case p of
       else success acc (Text.drop n t)
   CharIn cs -> dropper (charInPred cs)
   NotCharIn cs -> dropper (charNotInPred cs)
+  CharRange c1 c2 -> dropper (\ch -> ch >= c1 && c1 <= c2)
+  NotCharRange c1 c2 -> dropper (\ch -> ch < c1 || ch > c2)
   Digit -> dropper isDigit
   Letter -> dropper isLetter
   Punctuation -> dropper isPunctuation
   Space -> dropper isSpace
-  _ -> go1 m
+  _ -> try "Replicate" (go1 m) err (go2 (n - m))
   where
-    go1 0 = go2 (n - m)
-    go1 n = compile p err (go1 (n - 1))
+    go1 0 = \_err success stk rem -> success stk rem
+    go1 n = \err success -> compile p err (go1 (n - 1) err success)
     go2 0 = success
-    go2 n = compile p success (go2 (n - 1))
+    go2 n = try "Replicate" (compile p) success (go2 (n - 1))
 
     dropper ok acc t
       | (i, rest) <- Text.dropWhileMax ok n t, i >= m = success acc rest
@@ -184,3 +224,16 @@ charInPred [] = const False
 charInPred (c : chs) = let ok = charInPred chs in \ci -> ci == c || ok ci
 charNotInPred [] = const True
 charNotInPred (c : chs) = let ok = charNotInPred chs in (\ci -> ci /= c && ok ci)
+
+-- runs c and if it fails, restores state to what it was before
+try :: String -> Compiled r -> Compiled r
+try msg c err success stk rem =
+  c err' success' (Mark id rem stk) rem
+  where
+    success' stk rem = case stk of
+      Mark caps _ stk -> success (pushCaptures caps stk) rem
+      _ -> error $ "Pattern compiler error in: " <> msg
+    err' stk _ = case stk of
+      Mark _ rem stk -> err stk rem
+      _ -> error $ "Pattern compiler error in: " <> msg
+{-# INLINE try #-}

parser-typechecker/tests/Suite.hs

@@ -19,7 +19,6 @@ import qualified Unison.Test.DataDeclaration as DataDeclaration
 import qualified Unison.Test.MCode as MCode
 import qualified Unison.Test.Referent as Referent
 import qualified Unison.Test.Syntax.FileParser as FileParser
-import qualified Unison.Test.Syntax.Lexer as Lexer
 import qualified Unison.Test.Syntax.TermParser as TermParser
 import qualified Unison.Test.Syntax.TermPrinter as TermPrinter
 import qualified Unison.Test.Syntax.TypePrinter as TypePrinter
@@ -29,7 +28,6 @@ import qualified Unison.Test.Typechecker as Typechecker
 import qualified Unison.Test.Typechecker.Context as Context
 import qualified Unison.Test.Typechecker.TypeError as TypeError
 import qualified Unison.Test.UnisonSources as UnisonSources
-import qualified Unison.Test.Util.Bytes as Bytes
 import qualified Unison.Test.Util.PinBoard as PinBoard
 import qualified Unison.Test.Util.Relation as Relation
 import qualified Unison.Test.Util.Text as Text
@@ -39,7 +37,6 @@ test :: Test ()
 test =
   tests
     [ Cache.test,
-      Lexer.test,
       Term.test,
       TermParser.test,
       TermPrinter.test,
@@ -49,7 +46,6 @@ test =
       UnisonSources.test,
       FileParser.test,
       DataDeclaration.test,
-      Bytes.test,
       Text.test,
       Relation.test,
       Path.test,

parser-typechecker/tests/Unison/Test/Syntax/Lexer.hs

@@ -1,214 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Unison.Test.Syntax.Lexer where
-
-import EasyTest
-import qualified Unison.ShortHash as ShortHash
-import Unison.Syntax.Lexer
-
-test :: Test ()
-test =
-  scope "lexer"
-    . tests
-    $ [ t "1" [Numeric "1"],
-        t "+1" [Numeric "+1"],
-        t "-1" [Numeric "-1"],
-        t "-1.0" [Numeric "-1.0"],
-        t "+1.0" [Numeric "+1.0"],
-        t "1e3" [Numeric "1e3"],
-        t "1e+3" [Numeric "1e+3"],
-        t "1e-3" [Numeric "1e-3"],
-        t "+1e3" [Numeric "+1e3"],
-        t "+1e+3" [Numeric "+1e+3"],
-        t "+1e-3" [Numeric "+1e-3"],
-        t "-1e3" [Numeric "-1e3"],
-        t "-1e+3" [Numeric "-1e+3"],
-        t "-1e-3" [Numeric "-1e-3"],
-        t "1.2e3" [Numeric "1.2e3"],
-        t "1.2e+3" [Numeric "1.2e+3"],
-        t "1.2e-3" [Numeric "1.2e-3"],
-        t "+1.2e3" [Numeric "+1.2e3"],
-        t "+1.2e+3" [Numeric "+1.2e+3"],
-        t "+1.2e-3" [Numeric "+1.2e-3"],
-        t "-1.2e3" [Numeric "-1.2e3"],
-        t "-1.2e+3" [Numeric "-1.2e+3"],
-        t "-1.2e-3" [Numeric "-1.2e-3"],
-        t "1E3" [Numeric "1e3"],
-        t "1E+3" [Numeric "1e+3"],
-        t "1E-3" [Numeric "1e-3"],
-        t "+1E3" [Numeric "+1e3"],
-        t "+1E+3" [Numeric "+1e+3"],
-        t "+1E-3" [Numeric "+1e-3"],
-        t "-1E3" [Numeric "-1e3"],
-        t "-1E+3" [Numeric "-1e+3"],
-        t "-1E-3" [Numeric "-1e-3"],
-        t "1.2E3" [Numeric "1.2e3"],
-        t "1.2E+3" [Numeric "1.2e+3"],
-        t "1.2E-3" [Numeric "1.2e-3"],
-        t "+1.2E3" [Numeric "+1.2e3"],
-        t "+1.2E+3" [Numeric "+1.2e+3"],
-        t "+1.2E-3" [Numeric "+1.2e-3"],
-        t "-1.2E3" [Numeric "-1.2e3"],
-        t "-1.2E+3" [Numeric "-1.2e+3"],
-        t "-1.2E-3" [Numeric "-1.2e-3"],
-        t "1-1" [Numeric "1", simpleSymbolyId "-", Numeric "1"],
-        t "1+1" [Numeric "1", simpleSymbolyId "+", Numeric "1"],
-        t "1 +1" [Numeric "1", Numeric "+1"],
-        t "1+ 1" [Numeric "1", simpleSymbolyId "+", Numeric "1"],
-        t "x+y" [simpleWordyId "x", simpleSymbolyId "+", simpleWordyId "y"],
-        t "++;++" [simpleSymbolyId "++", Semi False, simpleSymbolyId "++"],
-        t "++; woot" [simpleSymbolyId "++", Semi False, simpleWordyId "woot"],
-        t "woot;woot" [simpleWordyId "woot", Semi False, simpleWordyId "woot"],
-        t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close],
-        t
-          "[+1,+1]"
-          [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close],
-        t
-          "[ +1 , +1 ]"
-          [Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close],
-        t "-- a comment 1.0" [],
-        t "\"woot\" -- a comment 1.0" [Textual "woot"],
-        t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"],
-        t "0 : Int" [Numeric "0", Reserved ":", simpleWordyId "Int"],
-        t
-          ".Foo Foo . .foo.bar.baz"
-          [ simpleWordyId ".Foo",
-            simpleWordyId "Foo",
-            simpleSymbolyId ".",
-            simpleWordyId ".foo.bar.baz"
-          ],
-        t ".Foo.Bar.+" [simpleSymbolyId ".Foo.Bar.+"],
-        -- idents with hashes
-        t "foo#bar" [WordyId "foo" (Just (ShortHash.unsafeFromText "#bar"))],
-        t "+#bar" [SymbolyId "+" (Just (ShortHash.unsafeFromText "#bar"))],
-        -- note - these are all the same, just with different spacing
-        let ex1 = "if x then y else z"
-            ex2 = unlines ["if", "  x", "then", "  y", "else z"]
-            ex3 = unlines ["if", "  x", "  then", "    y", "else z"]
-            ex4 = unlines ["if", "  x", "  then", "  y", "else z"]
-            expected =
-              [ Open "if",
-                simpleWordyId "x",
-                Close,
-                Open "then",
-                simpleWordyId "y",
-                Close,
-                Open "else",
-                simpleWordyId "z",
-                Close
-              ]
-         in -- directly close empty = block
-            tests $ map (`t` expected) [ex1, ex2, ex3, ex4],
-        let ex = unlines ["test =", "", "x = 1"]
-         in -- directly close nested empty blocks
-            t
-              ex
-              [ simpleWordyId "test",
-                Open "=",
-                Close,
-                (Semi True),
-                simpleWordyId "x",
-                Open "=",
-                Numeric "1",
-                Close
-              ],
-        let ex = unlines ["test =", "  test2 =", "", "x = 1"]
-         in t
-              ex
-              [ simpleWordyId "test",
-                Open "=",
-                simpleWordyId "test2",
-                Open "=",
-                Close,
-                Close,
-                (Semi True),
-                simpleWordyId "x",
-                Open "=",
-                Numeric "1",
-                Close
-              ],
-        let ex =
-              unlines
-                ["if a then b", "else if c then d", "else if e then f", "else g"] -- close of the three `else` blocks
-         in -- In an empty `then` clause, the `else` is interpreted as a `Reserved` token
-            t
-              ex
-              [ Open "if",
-                simpleWordyId "a",
-                Close,
-                Open "then",
-                simpleWordyId "b",
-                Close,
-                Open "else",
-                Open "if",
-                simpleWordyId "c",
-                Close,
-                Open "then",
-                simpleWordyId "d",
-                Close,
-                Open "else",
-                Open "if",
-                simpleWordyId "e",
-                Close,
-                Open "then",
-                simpleWordyId "f",
-                Close,
-                Open "else",
-                simpleWordyId "g",
-                Close,
-                Close,
-                Close
-              ],
-        t
-          "if x then else"
-          [ Open "if",
-            simpleWordyId "x",
-            Close,
-            Open "then",
-            Close,
-            Open "else",
-            Close
-          ],
-        -- Empty `else` clause
-        t
-          "if x then 1 else"
-          [ Open "if",
-            simpleWordyId "x",
-            Close,
-            Open "then",
-            Numeric "1",
-            Close,
-            Open "else",
-            Close
-          ],
-        -- shouldn't be too eager to find keywords at the front of identifiers,
-        -- particularly for block-closing keywords (see #2727)
-        tests $ do
-          kw <- ["if", "then", "else"]
-          suffix <- ["0", "x", "!", "'"] -- examples of wordyIdChar
-          let i = kw ++ suffix
-          -- a keyword at the front of an identifier should still be an identifier
-          pure $ t i [simpleWordyId i],
-        -- Test string literals
-        t
-          "\"simple string without escape characters\""
-          [Textual "simple string without escape characters"],
-        t
-          "\"test escaped quotes \\\"in quotes\\\"\""
-          [Textual "test escaped quotes \"in quotes\""],
-        t "\"\\n \\t \\b \\a\"" [Textual "\n \t \b \a"],
-        -- Delayed string
-        t "'\"\"" [Reserved "'", Textual ""]
-      ]
-
-t :: String -> [Lexeme] -> Test ()
-t s expected =
-  let actual0 = payload <$> lexer "ignored filename" s
-      actual = take (length actual0 - 2) . drop 1 $ actual0
-   in scope s $
-        if actual == expected
-          then ok
-          else do
-            note $ "expected: " ++ show expected
-            note $ "actual  : " ++ show actual
-            crash "actual != expected"

parser-typechecker/tests/Unison/Test/Syntax/TermPrinter.hs

@@ -234,7 +234,7 @@ test =
           \else c) with\n\
           \  112 -> x", -- dodgy layout.  note #517
         tc "handle bar with Pair 1 1",
-        tc "handle bar with x -> foo",
+        tcDiff "handle bar with x -> foo" "handle bar with 'foo",
         tcDiffRtt
           True
           "let\n\
@@ -399,8 +399,8 @@ test =
         tcDiff "'('bar)" "''bar",
         tcDiff "!('bar)" "!'bar",
         tcDiff "'(!foo)" "'!foo",
-        tc "x -> '(y -> 'z)",
-        tc "'(x -> '(y -> z))",
+        tcDiff "x -> '(y -> 'z)" "''''z",
+        tcDiff "'(x -> '(y -> z))" "''''z",
         tc "(\"a\", 2)",
         tc "(\"a\", 2, 2.0)",
         tcDiff "(2)" "2",
@@ -463,6 +463,12 @@ test =
         tcBinding 50 "+" Nothing "a b -> foo a b" "a + b = foo a b",
         tcBinding 50 "+" Nothing "a b c -> foo a b c" "(+) a b c = foo a b c",
         tcBinding 50 "." Nothing "f g x -> f (g x)" "(.) f g x = f (g x)",
+        tcBinding
+          50
+          "foo"
+          (Just "forall a. a -> a")
+          "x -> let\n  bar : forall a. a -> a\n  bar x = x\n  bar 10\n  x"
+          "foo : a -> a\nfoo x =\n  bar : \8704 a. a -> a\n  bar x = x\n  bar 10\n  x",
         tcBreaks
           32
           "let\n\

parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs

@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use camelCase" #-}
+
 module Unison.Test.Syntax.TypePrinter where
 
 import qualified Data.Map as Map
@@ -18,7 +22,7 @@ tc_diff_rtt :: Bool -> String -> String -> PP.Width -> Test ()
 tc_diff_rtt rtt s expected width =
   let input_type = Common.t s
       get_names = PPE.fromNames Common.hqLength Unison.Builtin.names
-      prettied = fmap toPlain $ PP.syntaxToColor $ prettyRaw get_names Map.empty (-1) input_type
+      prettied = fmap toPlain $ PP.syntaxToColor . runPretty get_names $ prettyRaw Map.empty (-1) input_type
       actual =
         if width == 0
           then PP.renderUnbroken $ prettied
@@ -26,26 +30,24 @@ tc_diff_rtt rtt s expected width =
       actual_reparsed = Common.t actual
    in scope s $
         tests
-          [ ( if actual == expected
-                then ok
-                else do
-                  note $ "expected: " ++ show expected
-                  note $ "actual  : " ++ show actual
-                  note $ "expectedS:\n" ++ expected
-                  note $ "actualS:\n" ++ actual
-                  note $ "show(input)  : " ++ show input_type
-                  note $ "prettyprint  : " ++ show prettied
-                  crash "actual != expected"
-            ),
-            ( if (not rtt) || (input_type == actual_reparsed)
-                then ok
-                else do
-                  note $ "round trip test..."
-                  note $ "single parse: " ++ show input_type
-                  note $ "double parse: " ++ show actual_reparsed
-                  note $ "prettyprint  : " ++ show prettied
-                  crash "single parse != double parse"
-            )
+          [ if actual == expected
+              then ok
+              else do
+                note $ "expected: " ++ show expected
+                note $ "actual  : " ++ show actual
+                note $ "expectedS:\n" ++ expected
+                note $ "actualS:\n" ++ actual
+                note $ "show(input)  : " ++ show input_type
+                note $ "prettyprint  : " ++ show prettied
+                crash "actual != expected",
+            if not rtt || (input_type == actual_reparsed)
+              then ok
+              else do
+                note $ "round trip test..."
+                note $ "single parse: " ++ show input_type
+                note $ "double parse: " ++ show actual_reparsed
+                note $ "prettyprint  : " ++ show prettied
+                crash "single parse != double parse"
           ]
 
 -- As above, but do the round-trip test unconditionally.
@@ -87,6 +89,9 @@ test =
       tc "Pair (a -> b) (c -> d)",
       tc "Pair a b ->{e1, e2} Pair a b ->{} Pair (a -> b) d -> Pair c d",
       tc "[Pair a a]",
+      tc "[a]",
+      tc "[a -> b]",
+      tc "[a ->{g} b]",
       tc "'a",
       tc "'Pair a a",
       tc "a -> 'b",

parser-typechecker/tests/Unison/Test/Util/Text.hs

@@ -124,6 +124,57 @@ test =
               dpart = P.Join [P.Literal ".", part]
               ip = P.Join [part, P.Replicate 3 3 dpart, P.Eof]
            in P.run ip "127.0.0.1" == Just (["127", "0", "0", "1"], "")
+        expect' $
+          let p = P.Replicate 5 8 (P.Capture P.Digit)
+           in P.run p "12345" == Just (["1", "2", "3", "4", "5"], "")
+        expect' $
+          let p = P.Replicate 5 8 (P.Capture P.Digit) `P.Or` P.Join []
+           in P.run p "1234" == Just ([], "1234")
+        expect' $
+          let p = P.Replicate 5 8 (P.Capture (P.Join [P.Digit, P.Literal "z"])) `P.Or` P.Join []
+           in P.run p "1z2z3z4z5z6a" == Just (["1z", "2z", "3z", "4z", "5z"], "6a")
+        -- https://github.com/unisonweb/unison/issues/3530
+        expectEqual Nothing $
+          let p =
+                P.Or
+                  (P.Join [P.Literal "a", P.Literal "b"])
+                  (P.Join [P.Literal "a", P.Literal "c"])
+           in P.run p "aac"
+        expectEqual (Just ([], "")) $
+          let p =
+                P.Or
+                  ( P.Capture $
+                      ( P.Or
+                          (P.Join [P.Literal "a", P.Literal "b"])
+                          (P.Join [P.Literal "a", P.Literal "c"])
+                      )
+                  )
+                  (P.Join [P.Literal "aa", P.Literal "cd"])
+           in P.run p "aacd"
+        -- this is just making sure we don't duplicate captures to our left
+        -- when entering an `Or` node
+        expectEqual (Just (["@"], "")) $
+          let p = P.Join [P.Capture P.AnyChar, P.Or (P.Literal "c") (P.Join []), P.Literal "d"]
+           in P.run p "@cd"
+        expectEqual (Just (["%", "c"], "")) $
+          let p = P.Join [P.Capture P.AnyChar, (P.Or (P.Capture (P.Literal "c")) (P.Join [])), P.Literal "d"]
+           in P.run p "%cd"
+        expectEqual (Just ([""], "ac")) $
+          let p = P.Capture (P.Or (P.Join [P.Literal "a", P.Literal "b"]) (P.Join []))
+           in P.run p "ac"
+        expectEqual (Just ([""], "ac")) $
+          let p = P.Capture (P.Replicate 0 1 (P.Join [P.Literal "a", P.Literal "b"]))
+           in P.run p "ac"
+        -- nested or tests
+        expectEqual (Just (["zzzaaa", "!"], "!!")) $
+          let p =
+                P.Or
+                  ( P.Or
+                      (P.Literal "a")
+                      (P.Join [P.Literal "z", P.Replicate 3 5 (P.Literal "z")])
+                  )
+                  (P.Join [P.Capture (P.Literal "zzzaaa"), P.Capture (P.Literal "!")])
+           in P.run p "zzzaaa!!!"
         ok
     ]
   where

parser-typechecker/unison-parser-typechecker.cabal

@@ -23,6 +23,7 @@ flag optimized
 
 library
   exposed-modules:
+      U.Codebase.Branch.Diff
       Unison.Builtin
       Unison.Builtin.Decls
       Unison.Builtin.Terms
@@ -60,7 +61,7 @@ library
       Unison.Codebase.PushBehavior
       Unison.Codebase.Runtime
       Unison.Codebase.Serialization
-      Unison.Codebase.ShortBranchHash
+      Unison.Codebase.ShortCausalHash
       Unison.Codebase.SqliteCodebase
       Unison.Codebase.SqliteCodebase.Branch.Cache
       Unison.Codebase.SqliteCodebase.Branch.Dependencies
@@ -88,10 +89,10 @@ library
       Unison.CodebasePath
       Unison.FileParsers
       Unison.Hashing.V2.Convert
-      Unison.Parser.Ann
       Unison.Parsers
       Unison.PrettyPrintEnv
       Unison.PrettyPrintEnv.FQN
+      Unison.PrettyPrintEnv.MonadPretty
       Unison.PrettyPrintEnv.Names
       Unison.PrettyPrintEnv.Util
       Unison.PrettyPrintEnvDecl
@@ -119,9 +120,7 @@ library
       Unison.Share.Types
       Unison.Syntax.DeclPrinter
       Unison.Syntax.FileParser
-      Unison.Syntax.Lexer
       Unison.Syntax.NamePrinter
-      Unison.Syntax.Parser
       Unison.Syntax.TermParser
       Unison.Syntax.TermPrinter
       Unison.Syntax.TypeParser
@@ -135,10 +134,8 @@ library
       Unison.Typechecker.TypeVar
       Unison.UnisonFile
       Unison.UnisonFile.Env
-      Unison.UnisonFile.Error
       Unison.UnisonFile.Names
       Unison.UnisonFile.Type
-      Unison.Util.Bytes
       Unison.Util.Convert
       Unison.Util.CycleTable
       Unison.Util.CyclicEq
@@ -147,7 +144,7 @@ library
       Unison.Util.Exception
       Unison.Util.Logger
       Unison.Util.PinBoard
-      Unison.Util.Rope
+      Unison.Util.Pretty.MegaParsec
       Unison.Util.Star3
       Unison.Util.Text
       Unison.Util.Text.Pattern
@@ -213,6 +210,7 @@ library
     , extra
     , filepath
     , fingertree
+    , free
     , fsnotify
     , fuzzyfind
     , generic-lens
@@ -281,9 +279,12 @@ library
     , unison-prelude
     , unison-pretty-printer
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
+    , unison-util-bytes
     , unison-util-relation
+    , unison-util-rope
     , unison-util-serialization
     , unliftio
     , uri-encode
@@ -317,7 +318,6 @@ test-suite parser-typechecker-tests
       Unison.Test.MCode
       Unison.Test.Referent
       Unison.Test.Syntax.FileParser
-      Unison.Test.Syntax.Lexer
       Unison.Test.Syntax.TermParser
       Unison.Test.Syntax.TermPrinter
       Unison.Test.Syntax.TypePrinter
@@ -328,7 +328,6 @@ test-suite parser-typechecker-tests
       Unison.Test.Typechecker.Context
       Unison.Test.Typechecker.TypeError
       Unison.Test.UnisonSources
-      Unison.Test.Util.Bytes
       Unison.Test.Util.PinBoard
       Unison.Test.Util.Pretty
       Unison.Test.Util.Relation
@@ -397,6 +396,7 @@ test-suite parser-typechecker-tests
     , filemanip
     , filepath
     , fingertree
+    , free
     , fsnotify
     , fuzzyfind
     , generic-lens
@@ -467,9 +467,12 @@ test-suite parser-typechecker-tests
     , unison-prelude
     , unison-pretty-printer
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
+    , unison-util-bytes
     , unison-util-relation
+    , unison-util-rope
     , unison-util-serialization
     , unliftio
     , uri-encode

scripts/make-release.sh

@@ -9,15 +9,16 @@ fi
 
 usage() {
     echo "NOTE: must be run from the root of the project."
-    echo "Usage: $0 VERSION [TARGET]"
+    echo "Usage: $0 VERSION SHARE_BASE_PATH [TARGET]"
     echo "VERSION: The version you're releasing, e.g. M4a"
+    echo "SHARE_BASE_PATH: Which base version to pull from share, e.g. 'unison.public.base.releases.M4'"
     echo "TARGET: The revision to make the release from, defaults to 'trunk'"
     echo ""
     echo "E.g."
     echo "$0 M4a"
 }
 
-if [[ -z "$1"  ]] ; then
+if [[ -z "$1" || -z "$2" ]] ; then
   usage
   exit 1
 fi
@@ -35,7 +36,8 @@ fi
 
 version="${1}"
 prev_version=$(./scripts/previous-tag.sh "$version")
-target=${2:-trunk}
+share_base_path=${2}
+target=${3:-trunk}
 tag="release/${version}"
 
 echo "Creating release in unison-local-ui..."
@@ -44,7 +46,7 @@ gh release create "release/${version}" --repo unisonweb/unison-local-ui --target
 echo "Kicking off release workflow in unisonweb/unison"
 git tag "${tag}" "${target}"
 git push origin "${tag}"
-gh workflow run release --repo unisonweb/unison --field "version=${version}"
+gh workflow run release --repo unisonweb/unison --field "version=${version}" --field "share_base_path=${share_base_path}"
 
 echo "Kicking off Homebrew update task"
 gh workflow run release --repo unisonweb/homebrew-unison --field "version=${version}"

stack.yaml

@@ -16,6 +16,7 @@ packages:
 - unison-cli
 - unison-hashing-v2
 - unison-share-api
+- unison-syntax
 - codebase2/codebase
 - codebase2/codebase-sqlite
 - codebase2/codebase-sqlite-hashing-v2
@@ -29,7 +30,9 @@ packages:
 - lib/unison-util-base32hex
 - lib/unison-util-base32hex-orphans-aeson
 - lib/unison-util-base32hex-orphans-sqlite
+- lib/unison-util-bytes
 - lib/unison-util-relation
+- lib/unison-util-rope
 - lib/unison-pretty-printer
 
 #compiler-check: match-exact

unison-cli/package.yaml

@@ -28,6 +28,7 @@ dependencies:
   - exceptions
   - extra
   - filepath
+  - free
   - fuzzyfind
   - friendly-time
   - generic-lens
@@ -75,6 +76,7 @@ dependencies:
   - unison-pretty-printer
   - unison-share-api
   - unison-sqlite
+  - unison-syntax
   - unison-util
   - unison-util-base32hex
   - unison-util-relation

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

@@ -36,6 +36,9 @@ module Unison.Cli.Monad
     -- * Debug-timing actions
     time,
 
+    -- * Running transactions
+    runTransaction,
+
     -- * Misc types
     LoadSourceResult (..),
   )
@@ -61,6 +64,7 @@ import qualified U.Codebase.Branch as V2Branch
 import Unison.Auth.CredentialManager (CredentialManager)
 import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
 import Unison.Codebase (Codebase)
+import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch)
 import Unison.Codebase.Editor.Input (Input)
 import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
@@ -71,6 +75,7 @@ import qualified Unison.Debug as Debug
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.Server.CodebaseServer as Server
+import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
 import qualified Unison.Syntax.Parser as Parser
 import Unison.Term (Term)
@@ -322,7 +327,7 @@ time label action =
     then Cli \env k s -> do
       systemStart <- getSystemTime
       cpuPicoStart <- getCPUTime
-      r <- unCli action env k s
+      a <- unCli action env (\a loopState -> pure (Success a, loopState)) s
       cpuPicoEnd <- getCPUTime
       systemEnd <- getSystemTime
       let systemDiff =
@@ -330,7 +335,7 @@ time label action =
               (diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart))
       let cpuDiff = picosToNanos (cpuPicoEnd - cpuPicoStart)
       printf "%s: %s (cpu), %s (system)\n" label (renderNanos cpuDiff) (renderNanos systemDiff)
-      pure r
+      feed k a
     else action
   where
     diffTimeToNanos :: DiffTime -> Double
@@ -371,3 +376,8 @@ respondNumbered output = do
   args <- liftIO (notifyNumbered output)
   unless (null args) do
     #numberedArgs .= args
+
+runTransaction :: Sqlite.Transaction a -> Cli a
+runTransaction action = do
+  Env {codebase} <- ask
+  liftIO (Codebase.runTransaction codebase action)

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

@@ -13,7 +13,7 @@ module Unison.Cli.MonadUtils
 
     -- ** Resolving branch identifiers
     resolveAbsBranchId,
-    resolveShortBranchHash,
+    resolveShortCausalHash,
 
     -- ** Getting/setting branches
     getRootBranch,
@@ -92,8 +92,8 @@ import Unison.Codebase.Patch (Patch (..))
 import qualified Unison.Codebase.Patch as Patch
 import Unison.Codebase.Path (Path, Path' (..))
 import qualified Unison.Codebase.Path as Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
+import qualified Unison.Codebase.ShortCausalHash as SCH
 import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
 import qualified Unison.HashQualified' as HQ'
 import Unison.NameSegment (NameSegment)
@@ -141,22 +141,22 @@ resolveSplit' =
 -- branches by path are OK - the empty branch will be returned).
 resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO)
 resolveAbsBranchId = \case
-  Left hash -> resolveShortBranchHash hash
+  Left hash -> resolveShortCausalHash hash
   Right path -> getBranchAt path
 
--- | Resolve a @ShortBranchHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
-resolveShortBranchHash :: ShortBranchHash -> Cli (Branch IO)
-resolveShortBranchHash hash = do
-  Cli.time "resolveShortBranchHash" do
+-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
+resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
+resolveShortCausalHash hash = do
+  Cli.time "resolveShortCausalHash" do
     Cli.Env {codebase} <- ask
-    hashSet <- liftIO (Codebase.branchHashesByPrefix codebase hash)
+    hashSet <- liftIO (Codebase.causalHashesByPrefix codebase hash)
     len <- liftIO (Codebase.branchHashLength codebase)
     h <-
       Set.asSingleton hashSet & onNothing do
         Cli.returnEarly
           if Set.null hashSet
             then Output.NoBranchWithHash hash
-            else Output.BranchHashAmbiguous hash (Set.map (SBH.fromHash len) hashSet)
+            else Output.BranchHashAmbiguous hash (Set.map (SCH.fromHash len) hashSet)
     branch <- liftIO (Codebase.getBranchForHash codebase h)
     pure (fromMaybe Branch.empty branch)
 
@@ -249,11 +249,10 @@ branchExistsAtPath' :: Path' -> Cli Bool
 branchExistsAtPath' path' = do
   absPath <- resolvePath' path'
   Cli.Env {codebase} <- ask
-  liftIO $ do
-    causal <- Codebase.getShallowCausalFromRoot codebase Nothing (Path.unabsolute absPath)
-    branch <- V2Causal.value causal
-    isEmpty <- Codebase.runTransaction codebase $ V2Branch.isEmpty branch
-    pure (not isEmpty)
+  causal <- liftIO $ Codebase.getShallowCausalFromRoot codebase Nothing (Path.unabsolute absPath)
+  branch <- liftIO $ V2Causal.value causal
+  isEmpty <- Cli.runTransaction $ V2Branch.isEmpty branch
+  pure (not isEmpty)
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Updating branches

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

@@ -20,6 +20,7 @@ import Unison.NamesWithHistory (NamesWithHistory (..))
 import Unison.Parser.Ann (Ann (..))
 import Unison.Prelude
 import qualified Unison.Result as Result
+import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol(Symbol))
 import qualified Unison.Syntax.Lexer as L
 import qualified Unison.Syntax.Parser as Parser
@@ -42,7 +43,7 @@ typecheck ambient names sourceName source =
   Cli.time "typecheck" do
     Cli.Env {codebase, generateUniqueName} <- ask
     uniqueName <- liftIO generateUniqueName
-    (liftIO . Result.getResult) $
+    (Cli.runTransaction . Result.getResult) $
       parseAndSynthesizeFile
         ambient
         (((<> Builtin.typeLookup) <$>) . Codebase.typeLookupForDependencies codebase)
@@ -65,7 +66,7 @@ typecheckHelper ::
     )
 typecheckHelper codebase generateUniqueName ambient names sourceName source = do
   uniqueName <- liftIO generateUniqueName
-  (liftIO . Result.getResult) $
+  (liftIO . Codebase.runTransaction codebase . Result.getResult) $
     parseAndSynthesizeFile
       ambient
       (((<> Builtin.typeLookup) <$>) . Codebase.typeLookupForDependencies codebase)
@@ -80,37 +81,38 @@ typecheckTerm ::
         (Seq (Result.Note Symbol Ann))
         (Type Symbol Ann))
 typecheckTerm tm = do
-  Cli.Env { generateUniqueName } <- ask
+  Cli.Env { codebase, generateUniqueName } <- ask
   un <- liftIO generateUniqueName
   let v = Symbol 0 (Var.Inference Var.Other)
-  fmap extract <$>
-    typecheckFile' [] (UF.UnisonFileId mempty mempty [(v, tm)] mempty)
+  liftIO $ fmap extract <$>
+    Codebase.runTransaction codebase (typecheckFile' codebase [] (UF.UnisonFileId mempty mempty [(v, tm)] mempty))
   where
     extract tuf
       | [[(_,_,ty)]] <- UF.topLevelComponents' tuf = ty
       | otherwise = error "internal error: typecheckTerm"
 
 typecheckFile' ::
+  Codebase m Symbol Ann ->
   [Type Symbol Ann] ->
   UF.UnisonFile Symbol Ann ->
-  Cli
+  Sqlite.Transaction
     ( Result.Result
         (Seq (Result.Note Symbol Ann))
         (UF.TypecheckedUnisonFile Symbol Ann))
-typecheckFile' ambient file = do
-  Cli.Env {codebase} <- ask
+typecheckFile' codebase ambient file = do
   typeLookup <-
-    liftIO $
-      (<> Builtin.typeLookup)
-        <$> Codebase.typeLookupForDependencies codebase (UF.dependencies file)
+    (<> Builtin.typeLookup)
+      <$> Codebase.typeLookupForDependencies codebase (UF.dependencies file)
   pure $ synthesizeFile' ambient typeLookup file
 
 typecheckFile ::
+  Codebase m Symbol Ann ->
   [Type Symbol Ann] ->
   UF.UnisonFile Symbol Ann ->
-  Cli
+  Sqlite.Transaction
     ( Result.Result
         (Seq (Result.Note Symbol Ann))
         (Either Names (UF.TypecheckedUnisonFile Symbol Ann))
     )
-typecheckFile ambient file = fmap Right <$> typecheckFile' ambient file
+typecheckFile codebase ambient file =
+  fmap Right <$> typecheckFile' codebase ambient file

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

@@ -40,6 +40,8 @@ import System.Directory
   )
 import System.FilePath ((</>))
 import qualified Text.Megaparsec as P
+import qualified U.Codebase.Branch.Diff as V2Branch
+import qualified U.Codebase.Causal as V2Causal
 import U.Codebase.HashTags (CausalHash (..))
 import qualified U.Codebase.Reflog as Reflog
 import qualified U.Codebase.Sqlite.Operations as Ops
@@ -55,6 +57,7 @@ import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
 import qualified Unison.Cli.MonadUtils as Cli
 import Unison.Cli.NamesUtils (basicParseNames, basicPrettyPrintNamesA, displayNames, findHistoricalHQs, getBasicPrettyPrintNames, makeHistoricalParsingNames, makePrintNamesFromLabeled', makeShadowedPrintNamesFromHQ)
+import Unison.Cli.TypeCheck (typecheck)
 import Unison.Cli.UnisonConfigUtils (gitUrlKey, remoteMappingKey)
 import Unison.Codebase (Codebase, Preprocessing (..), PushGitBranchOpts (..))
 import qualified Unison.Codebase as Codebase
@@ -111,7 +114,7 @@ import qualified Unison.Codebase.Path.Parse as Path
 import Unison.Codebase.PushBehavior (PushBehavior)
 import qualified Unison.Codebase.PushBehavior as PushBehavior
 import qualified Unison.Codebase.Runtime as Runtime
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import qualified Unison.Codebase.ShortCausalHash as SCH
 import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
 import qualified Unison.Codebase.SyncMode as SyncMode
 import qualified Unison.Syntax.TermPrinter as TP
@@ -171,6 +174,7 @@ import qualified Unison.Share.Sync as Share
 import qualified Unison.Share.Sync.Types as Share
 import Unison.Share.Types (codeserverBaseURL)
 import qualified Unison.ShortHash as SH
+import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
 import qualified Unison.Sync.Types as Share (Path (..), hashJWTHash)
 import qualified Unison.Syntax.Lexer as L
@@ -276,15 +280,15 @@ loop e = do
         #latestTypecheckedFile .= (Just unisonFile)
 
   case e of
-    Left (IncomingRootBranch hashes) -> do
+    Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do
       Cli.Env {codebase} <- ask
-      sbhLength <- liftIO (Codebase.branchHashLength codebase)
+      schLength <- liftIO (Codebase.branchHashLength codebase)
       rootBranch <- Cli.getRootBranch
       Cli.respond $
         WarnIncomingRootBranch
-          (SBH.fromHash sbhLength $ Branch.headHash rootBranch)
-          (Set.map (SBH.fromHash sbhLength) hashes)
-    Left (UnisonFileChanged sourceName text) ->
+          (SCH.fromHash schLength $ Branch.headHash rootBranch)
+          (Set.map (SCH.fromHash schLength) hashes)
+    Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do
       -- We skip this update if it was programmatically generated
       Cli.getLatestFile >>= \case
         Just (_, True) -> (#latestFile . _Just . _2) .= False
@@ -354,6 +358,7 @@ loop e = do
             Path.HQSplit' ->
             Cli ()
           delete getTerms getTypes hq' = do
+            Cli.Env {codebase} <- ask
             hq <- Cli.resolveSplit' hq'
             terms <- getTerms hq
             types <- getTypes hq
@@ -366,7 +371,7 @@ loop e = do
                 toRel = R.fromList . fmap (name,) . toList
                 -- these names are relative to the root
                 toDelete = Names (toRel terms) (toRel types)
-            endangerments <- getEndangeredDependents toDelete rootNames
+            endangerments <- Cli.runTransaction (getEndangeredDependents codebase toDelete rootNames)
             if null endangerments
               then do
                 let makeDeleteTermNames = map (BranchUtil.makeDeleteTermName resolvedPath) . Set.toList $ terms
@@ -380,7 +385,7 @@ loop e = do
               else do
                 ppeDecl <- currentPrettyPrintEnvDecl Backend.Within
                 Cli.respondNumbered (CantDeleteDefinitions ppeDecl endangerments)
-       in case input of
+       in Cli.time "InputPattern" case input of
             ApiI -> do
               Cli.Env {serverBaseUrl} <- ask
               whenJust serverBaseUrl \baseUrl ->
@@ -397,18 +402,18 @@ loop e = do
               Cli.respond $ PrintMessage pretty
             ShowReflogI -> do
               Cli.Env {codebase} <- ask
-              sbhLength <- liftIO (Codebase.branchHashLength codebase)
+              schLength <- liftIO (Codebase.branchHashLength codebase)
               let numEntriesToShow = 500
-              entries <- liftIO (Codebase.getReflog codebase numEntriesToShow) <&> fmap (first $ SBH.fromHash sbhLength)
+              entries <- liftIO (Codebase.getReflog codebase numEntriesToShow) <&> fmap (first $ SCH.fromHash schLength)
               let moreEntriesToLoad = length entries == numEntriesToShow
               let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad)
-              let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SBH.toString hash
+              let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash
               #numberedArgs .= numberedEntries
               Cli.respond $ ShowReflog expandedEntries
               where
                 expandEntries ::
-                  ([Reflog.Entry SBH.ShortBranchHash Text], Maybe SBH.ShortBranchHash, Bool) ->
-                  Maybe ((Maybe UTCTime, SBH.ShortBranchHash, Text), ([Reflog.Entry SBH.ShortBranchHash Text], Maybe SBH.ShortBranchHash, Bool))
+                  ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) ->
+                  Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool))
                 expandEntries ([], Just expectedHash, moreEntriesToLoad) =
                   if moreEntriesToLoad
                     then Nothing
@@ -428,7 +433,7 @@ loop e = do
               Cli.time "reset-root" do
                 newRoot <-
                   case src0 of
-                    Left hash -> Cli.resolveShortBranchHash hash
+                    Left hash -> Cli.resolveShortCausalHash hash
                     Right path' -> Cli.expectBranchAtPath' path'
                 description <- inputDescription input
                 Cli.updateRoot newRoot description
@@ -436,7 +441,7 @@ loop e = do
             ForkLocalBranchI src0 dest0 -> do
               srcb <-
                 case src0 of
-                  Left hash -> Cli.resolveShortBranchHash hash
+                  Left hash -> Cli.resolveShortCausalHash hash
                   Right path' -> Cli.expectBranchAtPath' path'
               Cli.assertNoBranchAtPath' dest0
               description <- inputDescription input
@@ -549,6 +554,7 @@ loop e = do
                   Cli.respond DeletedEverything
                 else Cli.respond DeleteEverythingConfirmation
             DeleteBranchI insistence (Just p) -> do
+              Cli.Env {codebase} <- ask
               branch <- Cli.expectBranchAtPath' (Path.unsplit' p)
               description <- inputDescription input
               absPath <- Cli.resolveSplit' p
@@ -558,7 +564,7 @@ loop e = do
                       (Branch.toNames (Branch.head branch))
               afterDelete <- do
                 rootNames <- Branch.toNames <$> Cli.getRootBranch0
-                endangerments <- getEndangeredDependents toDelete rootNames
+                endangerments <- Cli.runTransaction (getEndangeredDependents codebase toDelete rootNames)
                 case (null endangerments, insistence) of
                   (True, _) -> pure (Cli.respond Success)
                   (False, Force) -> do
@@ -598,27 +604,27 @@ loop e = do
             HistoryI resultsCap diffCap from -> do
               branch <-
                 case from of
-                  Left hash -> Cli.resolveShortBranchHash hash
+                  Left hash -> Cli.resolveShortCausalHash hash
                   Right path' -> do
                     path <- Cli.resolvePath' path'
                     Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
               Cli.Env {codebase} <- ask
-              sbhLength <- liftIO (Codebase.branchHashLength codebase)
-              history <- liftIO (doHistory sbhLength 0 branch [])
+              schLength <- liftIO (Codebase.branchHashLength codebase)
+              history <- liftIO (doHistory schLength 0 branch [])
               Cli.respondNumbered history
               where
                 doHistory :: Int -> Int -> Branch IO -> [(Causal.CausalHash, NamesWithHistory.Diff)] -> IO NumberedOutput
-                doHistory sbhLength !n b acc =
+                doHistory schLength !n b acc =
                   if maybe False (n >=) resultsCap
-                    then pure (History diffCap sbhLength acc (PageEnd (Branch.headHash b) n))
+                    then pure (History diffCap schLength acc (PageEnd (Branch.headHash b) n))
                     else case Branch._history b of
-                      Causal.One {} -> pure (History diffCap sbhLength acc (EndOfLog $ Branch.headHash b))
+                      Causal.One {} -> pure (History diffCap schLength acc (EndOfLog $ Branch.headHash b))
                       Causal.Merge _ _ _ tails ->
-                        pure (History diffCap sbhLength acc (MergeTail (Branch.headHash b) $ Map.keys tails))
+                        pure (History diffCap schLength acc (MergeTail (Branch.headHash b) $ Map.keys tails))
                       Causal.Cons _ _ _ tail -> do
                         b' <- fmap Branch.Branch $ snd tail
                         let elem = (Branch.headHash b, Branch.namesDiff b' b)
-                        doHistory sbhLength (n + 1) b' (elem : acc)
+                        doHistory schLength (n + 1) b' (elem : acc)
             UndoI -> do
               rootBranch <- Cli.getRootBranch
               (_, prev) <-
@@ -840,7 +846,7 @@ loop e = do
                 AuthorInfo.createAuthorInfo Ann.External authorFullName
               description <- inputDescription input
               -- add the new definitions to the codebase and to the namespace
-              traverse_ (liftIO . uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder]
+              Cli.runTransaction (traverse_ (uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder])
               authorPath <- Cli.resolveSplit' authorPath'
               copyrightHolderPath <- Cli.resolveSplit' (base |> "copyrightHolders" |> authorNameSegment)
               guidPath <- Cli.resolveSplit' (authorPath' |> "guid")
@@ -950,11 +956,11 @@ loop e = do
               #numberedArgs .= fmap entryToHQString entries
               getRoot <- atomically . STM.readTMVar <$> use #root
               let buildPPE = do
-                    sbhLength <- liftIO (Codebase.branchHashLength codebase)
+                    schLength <- liftIO (Codebase.branchHashLength codebase)
                     rootBranch <- getRoot
                     pure $
                       Backend.basicSuffixifiedNames
-                        sbhLength
+                        schLength
                         rootBranch
                         (Backend.AllNames (Path.unabsolute pathArgAbs))
               Cli.respond $ ListShallow buildPPE entries
@@ -1042,8 +1048,11 @@ loop e = do
 
                   replaceTerms :: Reference -> Reference -> Cli ()
                   replaceTerms fr tr = do
-                    mft <- liftIO (Codebase.getTypeOfTerm codebase fr)
-                    mtt <- liftIO (Codebase.getTypeOfTerm codebase tr)
+                    (mft, mtt) <-
+                      Cli.runTransaction do
+                        mft <- Codebase.getTypeOfTerm codebase fr
+                        mtt <- Codebase.getTypeOfTerm codebase tr
+                        pure (mft, mtt)
                     let termNotFound =
                           Cli.returnEarly
                             . TermNotFound'
@@ -1119,7 +1128,7 @@ loop e = do
               let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
               let adds = SlurpResult.adds sr
               Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
-              liftIO . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
+              Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
               ppe <- prettyPrintEnvDecl =<< displayNames uf
               Cli.respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
               addDefaultMetadata adds
@@ -1134,7 +1143,7 @@ loop e = do
               let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
               let adds = SlurpResult.adds sr
               Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
-              liftIO . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
+              Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
               ppe <- prettyPrintEnvDecl =<< displayNames uf
               Cli.returnEarly $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
               addDefaultMetadata adds
@@ -1219,7 +1228,7 @@ loop e = do
                 let noMain = Cli.returnEarly $ NoMainFunction (HQ.toString main) ppe [testType]
                 case toList results of
                   [Referent.Ref ref] -> do
-                    liftIO (loadTypeOfTerm codebase (Referent.Ref ref)) >>= \case
+                    Cli.runTransaction (loadTypeOfTerm codebase (Referent.Ref ref)) >>= \case
                       Just typ | Typechecker.isSubtype typ testType -> pure ref
                       _ -> noMain
                   _ -> noMain
@@ -1244,7 +1253,7 @@ loop e = do
                       (Map.fromList Builtin.builtinEffectDecls)
                       [Builtin.builtinTermsSrc Intrinsic]
                       mempty
-              liftIO (Codebase.addDefsToCodebase codebase uf)
+              Cli.runTransaction (Codebase.addDefsToCodebase codebase uf)
               -- add the names; note, there are more names than definitions
               -- due to builtin terms; so we don't just reuse `uf` above.
               let srcb = BranchUtil.fromNames Builtin.names0
@@ -1263,9 +1272,10 @@ loop e = do
                       (Map.fromList Builtin.builtinEffectDecls)
                       [Builtin.builtinTermsSrc Intrinsic]
                       mempty
-              liftIO (Codebase.addDefsToCodebase codebase uf)
-              -- these have not necessarily been added yet
-              liftIO (Codebase.addDefsToCodebase codebase IOSource.typecheckedFile')
+              Cli.runTransaction do
+                Codebase.addDefsToCodebase codebase uf
+                -- these have not necessarily been added yet
+                Codebase.addDefsToCodebase codebase IOSource.typecheckedFile'
 
               -- add the names; note, there are more names than definitions
               -- due to builtin terms; so we don't just reuse `uf` above.
@@ -1295,7 +1305,7 @@ loop e = do
               for_ lds \ld -> do
                 dependencies :: Set Reference <-
                   let tp r@(Reference.DerivedId i) =
-                        liftIO (Codebase.getTypeDeclaration codebase i) <&> \case
+                        Codebase.getTypeDeclaration codebase i <&> \case
                           Nothing -> error $ "What happened to " ++ show i ++ "?"
                           Just decl -> Set.delete r . DD.dependencies $ DD.asDataDecl decl
                       tp _ = pure mempty
@@ -1304,13 +1314,13 @@ loop e = do
                           Nothing -> error $ "What happened to " ++ show i ++ "?"
                           Just tm -> Set.delete r $ Term.dependencies tm
                       tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
-                        liftIO (Codebase.getTypeDeclaration codebase i) <&> \case
+                        Cli.runTransaction (Codebase.getTypeDeclaration codebase i) <&> \case
                           Nothing -> error $ "What happened to " ++ show i ++ "?"
                           Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
                             Nothing -> error $ "What happened to " ++ show con ++ "?"
                             Just tp -> Type.dependencies tp
                       tm _ = pure mempty
-                   in LD.fold tp tm ld
+                   in LD.fold (Cli.runTransaction . tp) tm ld
                 (missing, names0) <- liftIO (Branch.findHistoricalRefs' dependencies rootBranch)
                 let types = R.toList $ Names.types names0
                 let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
@@ -1357,7 +1367,7 @@ loop e = do
                         Causal.Merge h _bh b (Map.toList -> tails) -> goBranch h b (map fst tails) (tails ++ queue)
                   goBranch :: forall m. Monad m => Branch.CausalHash -> Branch0 m -> [Branch.CausalHash] -> [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m ()
                   goBranch h b (Set.fromList -> causalParents) queue = case b of
-                    Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ ->
+                    Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ _ ->
                       let wrangleMetadata :: (Ord r, Ord n) => Metadata.Star r n -> r -> (r, (Set n, Set Metadata.Value))
                           wrangleMetadata s r =
                             (r, (R.lookupDom r $ Star3.d1 s, Set.map snd . R.lookupDom r $ Star3.d3 s))
@@ -1399,9 +1409,26 @@ loop e = do
               Cli.Env {codebase} <- ask
               liftIO (Codebase.clearWatches codebase)
             DebugDoctorI {} -> do
-              Cli.Env {codebase} <- ask
-              r <- liftIO (Codebase.runTransaction codebase IntegrityCheck.integrityCheckFullCodebase)
+              r <- Cli.runTransaction IntegrityCheck.integrityCheckFullCodebase
               Cli.respond (IntegrityCheck r)
+            DebugNameDiffI fromSCH toSCH -> do
+              Cli.Env {codebase} <- ask
+              schLen <- liftIO $ Codebase.branchHashLength codebase
+              fromCHs <- liftIO $ Codebase.causalHashesByPrefix codebase fromSCH
+              toCHs <- liftIO $ Codebase.causalHashesByPrefix codebase toSCH
+              (fromCH, toCH) <- case (Set.toList fromCHs, Set.toList toCHs) of
+                ((_ : _ : _), _) -> Cli.returnEarly $ Output.BranchHashAmbiguous fromSCH (Set.map (SCH.fromHash schLen) fromCHs)
+                ([], _) -> Cli.returnEarly $ Output.NoBranchWithHash fromSCH
+                (_, []) -> Cli.returnEarly $ Output.NoBranchWithHash toSCH
+                (_, (_ : _ : _)) -> Cli.returnEarly $ Output.BranchHashAmbiguous toSCH (Set.map (SCH.fromHash schLen) toCHs)
+                ([fromCH], [toCH]) -> pure (fromCH, toCH)
+              output <- liftIO do
+                fromBranch <- (Codebase.getShallowCausalForHash codebase $ Cv.causalHash1to2 fromCH) >>= V2Causal.value
+                toBranch <- (Codebase.getShallowCausalForHash codebase $ Cv.causalHash1to2 toCH) >>= V2Causal.value
+                treeDiff <- V2Branch.diffBranches fromBranch toBranch
+                let nameChanges = V2Branch.nameChanges Nothing treeDiff
+                pure (DisplayDebugNameDiff nameChanges)
+              Cli.respond output
             DeprecateTermI {} -> Cli.respond NotImplemented
             DeprecateTypeI {} -> Cli.respond NotImplemented
             RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True
@@ -1587,6 +1614,7 @@ inputDescription input =
     CreatePullRequestI {} -> wat
     DebugClearWatchI {} -> wat
     DebugDoctorI {} -> wat
+    DebugNameDiffI {} -> wat
     DebugDumpNamespaceSimpleI {} -> wat
     DebugDumpNamespacesI {} -> wat
     DebugNumberedArgsI {} -> wat
@@ -1626,7 +1654,7 @@ inputDescription input =
     VersionI -> wat
     DebugTabCompletionI _input -> wat
   where
-    hp' :: Either SBH.ShortBranchHash Path' -> Cli Text
+    hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
     hp' = either (pure . Text.pack . show) p'
     p' :: Path' -> Cli Text
     p' = fmap tShow . Cli.resolvePath'
@@ -1727,7 +1755,7 @@ handleFindI isVerbose fscope ws input = do
             pure $ uniqueBy SR.toReferent srs
   let respondResults results = do
         #numberedArgs .= fmap searchResultToHQString results
-        results' <- liftIO (Backend.loadSearchResults codebase results)
+        results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
         ppe <-
           suffixifiedPPE
             =<< makePrintNamesFromLabeled'
@@ -1753,12 +1781,12 @@ handleDependents hq = do
   for_ lds \ld -> do
     -- The full set of dependent references, any number of which may not have names in the current namespace.
     dependents <-
-      let tp r = liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
+      let tp r = Codebase.dependents codebase Queries.ExcludeOwnComponent r
           tm = \case
-            Referent.Ref r -> liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
+            Referent.Ref r -> Codebase.dependents codebase Queries.ExcludeOwnComponent r
             Referent.Con (ConstructorReference r _cid) _ct ->
-              liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
-       in LD.fold tp tm ld
+              Codebase.dependents codebase Queries.ExcludeOwnComponent r
+       in Cli.runTransaction (LD.fold tp tm ld)
     -- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
     -- unambiguous name.
     ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within
@@ -1849,13 +1877,13 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do
         Cli.ioE (Codebase.pushGitBranch codebase repo opts (\_remoteRoot -> pure (Right sourceBranch))) \err ->
           Cli.returnEarly (Output.GitError err)
       _branch <- result & onLeft Cli.returnEarly
-      sbhLength <- liftIO (Codebase.branchHashLength codebase)
+      schLength <- liftIO (Codebase.branchHashLength codebase)
       Cli.respond $
         GistCreated
           ( ReadRemoteNamespaceGit
               ReadGitRemoteNamespace
                 { repo = writeToReadGit repo,
-                  sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)),
+                  sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)),
                   path = Path.empty
                 }
           )
@@ -1883,7 +1911,7 @@ handlePushToUnisonShare remote@WriteShareRemotePath {server, repo, path = remote
 
   -- doesn't handle the case where a non-existent path is supplied
   localCausalHash <-
-    liftIO (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath)))) & onNothingM do
+    Cli.runTransaction (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) & onNothingM do
       Cli.returnEarly (EmptyPush . Path.absoluteToPath' $ localPath)
 
   let checkAndSetPush :: Maybe Hash32 -> IO (Either (Share.SyncError Share.CheckAndSetPushError) ())
@@ -2243,13 +2271,20 @@ doDisplay outputLoc names tm = do
         Just (tm, _) -> pure (Just $ Term.unannotate tm)
       loadTerm _ = pure Nothing
       loadDecl (Reference.DerivedId r) = case Map.lookup r typs of
-        Nothing -> fmap (fmap $ DD.amap (const ())) $ liftIO (Codebase.getTypeDeclaration codebase r)
+        Nothing -> fmap (fmap $ DD.amap (const ())) $ Codebase.getTypeDeclaration codebase r
         Just decl -> pure (Just $ DD.amap (const ()) decl)
       loadDecl _ = pure Nothing
       loadTypeOfTerm' (Referent.Ref (Reference.DerivedId r))
         | Just (_, ty) <- Map.lookup r tms = pure $ Just (void ty)
       loadTypeOfTerm' r = fmap (fmap void) . loadTypeOfTerm codebase $ r
-  rendered <- DisplayValues.displayTerm ppe (liftIO . loadTerm) (liftIO . loadTypeOfTerm') evalTerm loadDecl tm
+  rendered <-
+    DisplayValues.displayTerm
+      ppe
+      (liftIO . loadTerm)
+      (Cli.runTransaction . loadTypeOfTerm')
+      evalTerm
+      (Cli.runTransaction . loadDecl)
+      tm
   Cli.respond $ DisplayRendered loc rendered
 
 getLinks ::
@@ -2288,7 +2323,7 @@ getLinks' src selection0 = do
       allMd' = maybe allMd (`R.restrictDom` allMd) selection0
       -- then list the values after filtering by type
       allRefs :: Set Reference = R.ran allMd'
-  sigs <- for (toList allRefs) (liftIO . loadTypeOfTerm codebase . Referent.Ref)
+  sigs <- Cli.runTransaction (for (toList allRefs) (loadTypeOfTerm codebase . Referent.Ref))
   let deps =
         Set.map LD.termRef allRefs
           <> Set.unions [Set.map LD.typeRef . Type.dependencies $ t | Just t <- sigs]
@@ -2313,8 +2348,9 @@ propagatePatch inputDescription patch scopePath = do
 -- | Show todo output if there are any conflicts or edits.
 doShowTodoOutput :: Patch -> Path.Absolute -> Cli ()
 doShowTodoOutput patch scopePath = do
+  Cli.Env {codebase} <- ask
   names0 <- Branch.toNames <$> Cli.getBranch0At scopePath
-  todo <- checkTodo patch names0
+  todo <- Cli.runTransaction (checkTodo codebase patch names0)
   if TO.noConflicts todo && TO.noEdits todo
     then Cli.respond NoConflictsOrEdits
     else do
@@ -2328,22 +2364,21 @@ doShowTodoOutput patch scopePath = do
         prettyPrintEnvDecl names
       Cli.respondNumbered $ TodoOutput ppe todo
 
-checkTodo :: Patch -> Names -> Cli (TO.TodoOutput Symbol Ann)
-checkTodo patch names0 = do
-  Cli.Env {codebase} <- ask
+checkTodo :: Codebase m Symbol Ann -> Patch -> Names -> Sqlite.Transaction (TO.TodoOutput Symbol Ann)
+checkTodo codebase patch names0 = do
   let -- Get the dependents of a reference which:
       --   1. Don't appear on the LHS of this patch
       --   2. Have a name in this namespace
-      getDependents :: Reference -> IO (Set Reference)
+      getDependents :: Reference -> Sqlite.Transaction (Set Reference)
       getDependents ref = do
         dependents <- Codebase.dependents codebase Queries.ExcludeSelf ref
         pure (dependents & removeEditedThings & removeNamelessThings)
   -- (r,r2) ∈ dependsOn if r depends on r2, excluding self-references (i.e. (r,r))
-  dependsOn <- liftIO (Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited)
+  dependsOn <- Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited
   let dirty = R.dom dependsOn
-  transitiveDirty <- liftIO (transitiveClosure getDependents dirty)
-  (frontierTerms, frontierTypes) <- loadDisplayInfo (R.ran dependsOn)
-  (dirtyTerms, dirtyTypes) <- loadDisplayInfo dirty
+  transitiveDirty <- transitiveClosure getDependents dirty
+  (frontierTerms, frontierTypes) <- loadDisplayInfo codebase (R.ran dependsOn)
+  (dirtyTerms, dirtyTypes) <- loadDisplayInfo codebase dirty
   pure $
     TO.TodoOutput
       (Set.size transitiveDirty)
@@ -2744,27 +2779,27 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
 -- definition is going "extinct"). In this case we may wish to take some action or warn the
 -- user about these "endangered" definitions which would now contain unnamed references.
 getEndangeredDependents ::
+  Codebase m v a ->
   -- | Which names we want to delete
   Names ->
   -- | All names from the root branch
   Names ->
   -- | map from references going extinct to the set of endangered dependents
-  Cli (Map LabeledDependency (NESet LabeledDependency))
-getEndangeredDependents namesToDelete rootNames = do
-  Cli.Env {codebase} <- ask
+  Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency))
+getEndangeredDependents codebase namesToDelete rootNames = do
   let remainingNames :: Names
       remainingNames = rootNames `Names.difference` namesToDelete
       refsToDelete, remainingRefs, extinct :: Set LabeledDependency
       refsToDelete = Names.labeledReferences namesToDelete
       remainingRefs = Names.labeledReferences remainingNames -- left over after delete
       extinct = refsToDelete `Set.difference` remainingRefs -- deleting and not left over
-      accumulateDependents :: LabeledDependency -> IO (Map LabeledDependency (Set LabeledDependency))
+      accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency))
       accumulateDependents ld =
         let ref = LD.fold id Referent.toReference ld
          in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents codebase Queries.ExcludeOwnComponent ref
   -- All dependents of extinct, including terms which might themselves be in the process of being deleted.
   allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <-
-    liftIO (Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents)
+    Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents
 
   -- Filtered to only include dependencies which are not being deleted, but depend one which
   -- is going extinct.
@@ -2863,26 +2898,25 @@ docsI srcLoc prettyPrintNames src =
           | otherwise -> Cli.respond $ ListOfLinks PPE.empty []
 
 loadDisplayInfo ::
+  Codebase m Symbol Ann ->
   Set Reference ->
-  Cli
+  Sqlite.Transaction
     ( [(Reference, Maybe (Type Symbol Ann))],
       [(Reference, DisplayObject () (DD.Decl Symbol Ann))]
     )
-loadDisplayInfo refs = do
-  Cli.Env {codebase} <- ask
-  termRefs <- filterM (liftIO . Codebase.isTerm codebase) (toList refs)
-  typeRefs <- filterM (liftIO . Codebase.isType codebase) (toList refs)
-  terms <- forM termRefs $ \r -> (r,) <$> liftIO (Codebase.getTypeOfTerm codebase r)
-  types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject r
+loadDisplayInfo codebase refs = do
+  termRefs <- filterM (Codebase.isTerm codebase) (toList refs)
+  typeRefs <- filterM (Codebase.isType codebase) (toList refs)
+  terms <- forM termRefs $ \r -> (r,) <$> Codebase.getTypeOfTerm codebase r
+  types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject codebase r
   pure (terms, types)
 
-loadTypeDisplayObject :: Reference -> Cli (DisplayObject () (DD.Decl Symbol Ann))
-loadTypeDisplayObject = \case
+loadTypeDisplayObject :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (DisplayObject () (DD.Decl Symbol Ann))
+loadTypeDisplayObject codebase = \case
   Reference.Builtin _ -> pure (BuiltinObject ())
-  Reference.DerivedId id -> do
-    Cli.Env {codebase} <- ask
+  Reference.DerivedId id ->
     maybe (MissingObject $ Reference.idToShortHash id) UserObject
-      <$> liftIO (Codebase.getTypeDeclaration codebase id)
+      <$> Codebase.getTypeDeclaration codebase id
 
 lexedSource :: Text -> Text -> Cli (NamesWithHistory, (Text, [L.Token L.Lexeme]))
 lexedSource name src = do
@@ -3013,7 +3047,7 @@ getTerm' mainName =
         Cli.Env {codebase, runtime} <- ask
 
         parseNames <- basicParseNames
-        let loadTypeOfTerm ref = liftIO (Codebase.getTypeOfTerm codebase ref)
+        let loadTypeOfTerm ref = Cli.runTransaction (Codebase.getTypeOfTerm codebase ref)
         mainToFile
           =<< MainTerm.getMainTerm loadTypeOfTerm parseNames mainName (Runtime.mainType runtime)
         where
@@ -3068,7 +3102,7 @@ executePPE ::
 executePPE unisonFile =
   suffixifiedPPE =<< displayNames unisonFile
 
-loadTypeOfTerm :: Monad m => Codebase m Symbol Ann -> Referent -> m (Maybe (Type Symbol Ann))
+loadTypeOfTerm :: Codebase m Symbol Ann -> Referent -> Sqlite.Transaction (Maybe (Type Symbol Ann))
 loadTypeOfTerm codebase (Referent.Ref r) = Codebase.getTypeOfTerm codebase r
 loadTypeOfTerm codebase (Referent.Con (ConstructorReference (Reference.DerivedId r) cid) _) = do
   decl <- Codebase.getTypeDeclaration codebase r

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

@@ -32,7 +32,6 @@ import qualified Unison.PrettyPrintEnv as PPE
 import Unison.Referent (Referent)
 import qualified Unison.Referent as Referent
 import qualified Unison.Server.Backend as Backend
-import Unison.Symbol (Symbol)
 import qualified Unison.Util.Monoid as Monoid
 import qualified Unison.Util.Relation as R
 import qualified Unison.Util.Set as Set
@@ -40,7 +39,7 @@ import qualified Unison.Util.Set as Set
 -- Add default metadata to all added types and terms in a slurp component.
 --
 -- No-op if the slurp component is empty.
-addDefaultMetadata :: SlurpComponent Symbol -> Cli ()
+addDefaultMetadata :: SlurpComponent -> Cli ()
 addDefaultMetadata adds =
   when (not (SC.isEmpty adds)) do
     Cli.time "add-default-metadata" do
@@ -125,11 +124,11 @@ resolveMetadata name = do
   Cli.Env {codebase} <- ask
   root' <- Cli.getRootBranch
   currentPath' <- Cli.getCurrentPath
-  sbhLength <- liftIO (Codebase.branchHashLength codebase)
+  schLength <- liftIO (Codebase.branchHashLength codebase)
 
   let ppe :: PPE.PrettyPrintEnv
       ppe =
-        Backend.basicSuffixifiedNames sbhLength root' (Backend.Within $ Path.unabsolute currentPath')
+        Backend.basicSuffixifiedNames schLength root' (Backend.Within $ Path.unabsolute currentPath')
 
   terms <- getHQTerms name
   ref <-
@@ -137,10 +136,9 @@ resolveMetadata name = do
       Just (Referent.Ref ref) -> pure ref
       -- FIXME: we want a different error message if the given name is associated with a data constructor (`Con`).
       _ -> Cli.returnEarly (MetadataAmbiguous name ppe (Set.toList terms))
-  liftIO (Codebase.getTypeOfTerm codebase ref) >>= \case
-    Just ty -> pure $ Right (Hashing.typeToReference ty, ref)
-    Nothing ->
-      pure (Left (MetadataMissingType ppe (Referent.Ref ref)))
+  Cli.runTransaction ((Codebase.getTypeOfTerm codebase ref)) <&> \case
+    Just ty -> Right (Hashing.typeToReference ty, ref)
+    Nothing -> Left (MetadataMissingType ppe (Referent.Ref ref))
 
 resolveDefaultMetadata :: Path.Absolute -> Cli [String]
 resolveDefaultMetadata path = do

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

@@ -8,6 +8,7 @@ import Control.Monad.Trans.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Unison.Cli.Monad (Cli, Env (..))
+import qualified Unison.Cli.Monad as Cli
 import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch0)
 import qualified Unison.Codebase.Branch as Branch
@@ -41,11 +42,13 @@ namespaceDependencies :: Branch0 m -> Cli (Map LabeledDependency (Set Name))
 namespaceDependencies branch = do
   Env {codebase} <- ask
 
-  typeDeps <- for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
-    refId <- MaybeT . pure $ Reference.toId typeRef
-    decl <- MaybeT $ liftIO (Codebase.getTypeDeclaration codebase refId)
-    let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
-    pure $ foldMap (`Map.singleton` names) typeDeps
+  typeDeps <-
+    Cli.runTransaction do
+      for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
+        refId <- MaybeT . pure $ Reference.toId typeRef
+        decl <- MaybeT $ Codebase.getTypeDeclaration codebase refId
+        let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
+        pure $ foldMap (`Map.singleton` names) typeDeps
 
   termDeps <- for (Map.toList currentBranchTermRefs) $ \(termRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
     refId <- MaybeT . pure $ Referent.toReferenceId termRef

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

@@ -27,6 +27,7 @@ import qualified Unison.PrettyPrintEnvDecl as PPE hiding (biasTo)
 import Unison.Reference (Reference (..))
 import qualified Unison.Reference as Reference
 import qualified Unison.Server.Backend as Backend
+import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
 
 diffHelper ::
@@ -42,18 +43,17 @@ diffHelper before after =
     diff <- liftIO (BranchDiff.diff0 before after)
     let (_parseNames, prettyNames0, _local) = Backend.namesForBranch rootBranch (Backend.AllNames $ Path.unabsolute currentPath)
     ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty)
-    liftIO do
-      fmap (ppe,) do
-        OBranchDiff.toOutput
-          (Codebase.getTypeOfReferent codebase)
-          (declOrBuiltin codebase)
-          hqLength
-          (Branch.toNames before)
-          (Branch.toNames after)
-          ppe
-          diff
+    fmap (ppe,) do
+      OBranchDiff.toOutput
+        (Cli.runTransaction . Codebase.getTypeOfReferent codebase)
+        (Cli.runTransaction . declOrBuiltin codebase)
+        hqLength
+        (Branch.toNames before)
+        (Branch.toNames after)
+        ppe
+        diff
 
-declOrBuiltin :: Applicative m => Codebase m Symbol Ann -> Reference -> m (Maybe (DD.DeclOrBuiltin Symbol Ann))
+declOrBuiltin :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (Maybe (DD.DeclOrBuiltin Symbol Ann))
 declOrBuiltin codebase r = case r of
   Reference.Builtin {} ->
     pure . fmap DD.Builtin $ Map.lookup r Builtin.builtinConstructorType

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

@@ -66,10 +66,14 @@ lookupTermRefWithType
   -> Cli [(Reference,Type Symbol Ann)]
 lookupTermRefWithType codebase name = do
   nms <- basicParseNames
-  fmap catMaybes . traverse annot . fst $ lookupTermRefs name nms
+  liftIO .
+    Codebase.runTransaction codebase .
+    fmap catMaybes .
+    traverse annot .
+    fst $ lookupTermRefs name nms
   where
     annot tm =
-      fmap ((,) tm) <$> liftIO (Codebase.getTypeOfTerm codebase tm)
+      fmap ((,) tm) <$> Codebase.getTypeOfTerm codebase tm
 
 resolveTerm :: HQ.HashQualified Name -> Cli Referent
 resolveTerm name = basicParseNames >>= \nms ->

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

@@ -11,7 +11,7 @@ import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Set.NonEmpty as NESet
-import qualified Data.Tuple as Tuple
+import qualified U.Codebase.Sqlite.Queries as Queries
 import qualified Unison.ABT as ABT
 import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
@@ -40,6 +40,7 @@ import Unison.Codebase.Path (Path)
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.TermEdit as TermEdit
 import qualified Unison.Codebase.TypeEdit as TypeEdit
+import Unison.DataDeclaration (Decl)
 import Unison.Hash (Hash)
 import Unison.Name (Name)
 import qualified Unison.Name as Name
@@ -48,7 +49,7 @@ import qualified Unison.Names as Names
 import Unison.Parser.Ann (Ann (..))
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnvDecl as PPE hiding (biasTo)
-import Unison.Reference (Reference (..), TermReference, TermReferenceId, TypeReference)
+import Unison.Reference (Reference (..), TermReference, TermReferenceId, TypeReference, TypeReferenceId)
 import qualified Unison.Reference as Reference
 import Unison.Referent (Referent)
 import qualified Unison.Referent as Referent
@@ -65,11 +66,10 @@ import Unison.UnisonFile (TypecheckedUnisonFile, UnisonFile)
 import qualified Unison.UnisonFile as UF
 import qualified Unison.UnisonFile.Names as UF
 import Unison.UnisonFile.Type (UnisonFile (UnisonFileId))
-import qualified Unison.Util.Map as Map (remap)
+import qualified Unison.Util.Map as Map (remap, upsert)
 import Unison.Util.Monoid (foldMapM)
 import qualified Unison.Util.Relation as R
 import qualified Unison.Util.Set as Set
-import Unison.Var (Var)
 import qualified Unison.Var as Var
 import Unison.WatchKind (WatchKind)
 import qualified Unison.WatchKind as WK
@@ -86,7 +86,7 @@ handleUpdate input optionalPatch requestedNames = do
           UsePatch p -> Just p
   slurpCheckNames <- Branch.toNames <$> Cli.getCurrentBranch0
   sr <- getSlurpResultForUpdate requestedNames slurpCheckNames
-  let addsAndUpdates :: SlurpComponent Symbol
+  let addsAndUpdates :: SlurpComponent
       addsAndUpdates = Slurp.updates sr <> Slurp.adds sr
       fileNames :: Names
       fileNames = UF.typecheckedToNames (Slurp.originalFile sr)
@@ -144,9 +144,10 @@ handleUpdate input optionalPatch requestedNames = do
         neededTypes = collectOldForTyping (map (\(_, old, new) -> (old, new)) termEdits) ye'ol'Patch
 
     allTypes :: Map Reference (Type v Ann) <-
-      fmap Map.fromList . for (toList neededTypes) $ \r ->
-        (r,) . fromMaybe (Type.builtin External "unknown type")
-          <$> (liftIO . Codebase.getTypeOfTerm codebase) r
+      (liftIO . Codebase.runTransaction codebase) do
+        fmap Map.fromList . for (toList neededTypes) $ \r ->
+          (r,) . fromMaybe (Type.builtin External "unknown type")
+            <$> Codebase.getTypeOfTerm codebase r
 
     let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of
           (Just t1, Just t2)
@@ -189,7 +190,10 @@ handleUpdate input optionalPatch requestedNames = do
             Nothing -> []
             Just (_, update, p) -> [(Path.unabsolute p, update)]
       )
-    liftIO . Codebase.addDefsToCodebase codebase . Slurp.filterUnisonFile sr $ Slurp.originalFile sr
+    Cli.runTransaction
+      . Codebase.addDefsToCodebase codebase
+      . Slurp.filterUnisonFile sr
+      $ Slurp.originalFile sr
   ppe <- prettyPrintEnvDecl =<< displayNames (Slurp.originalFile sr)
   Cli.respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
   whenJust patchOps \(updatedPatch, _, _) ->
@@ -202,9 +206,9 @@ handleUpdate input optionalPatch requestedNames = do
         & Path.resolve @_ @_ @Path.Absolute currentPath'
         & tShow
 
-getSlurpResultForUpdate :: Set Name -> Names -> Cli (SlurpResult Symbol)
+getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult
 getSlurpResultForUpdate requestedNames slurpCheckNames = do
-  let slurp :: TypecheckedUnisonFile Symbol Ann -> SlurpResult Symbol
+  let slurp :: TypecheckedUnisonFile Symbol Ann -> SlurpResult
       slurp file =
         Slurp.slurpFile file (Set.map Name.toVar requestedNames) Slurp.UpdateOp slurpCheckNames
 
@@ -243,6 +247,15 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
     -- terms in it fails.
     let slurp0 = slurp unisonFile0
 
+    -- Grab some interim info out of the original slurp.
+    --
+    -- Running example:
+    --
+    --   "ping" => (#newping, Nothing, <#wham + 4>, <Nat>)
+    let nameToInterimInfo :: Map Symbol (TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
+        nameToInterimInfo =
+          UF.hashTermsId (Slurp.originalFile slurp0)
+
     -- Get the set of names that are being updated.
     --
     -- Running example:
@@ -252,14 +265,21 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
         namesBeingUpdated =
           SC.terms (Slurp.updates slurp0)
 
-    -- Associate each such name with the set of "old" references (already in the codebase) that it's associated with.
+    -- Associate each such name with the set of old (already in the codebase) and new (in the scratch file) references
+    -- that it's associated with.
     --
     -- Running example:
     --
-    --   "ping" => { #pingpong.ping }
-    let updatedNameToOldRefs :: Map Symbol (Set TermReference)
-        updatedNameToOldRefs =
-          Map.fromSet nameToTermRefs namesBeingUpdated
+    --   "ping" => ({ #pingpong.ping }, #newping)
+    let updatedNameToRefs :: Map Symbol (Set TermReference, TermReferenceId)
+        updatedNameToRefs =
+          Map.fromSet
+            ( \name ->
+                case Map.lookup name nameToInterimInfo of
+                  Nothing -> error (reportBug "E798907" "no interim ref for name")
+                  Just (interimRef, _, _, _) -> (nameToTermRefs name, interimRef)
+            )
+            namesBeingUpdated
 
     -- Identify all of the implicit terms, which are:
     --
@@ -295,64 +315,126 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
     -- Furthermore, #wham is both a dependent of #pingpong (B), and a dependency of #newping, so it too is an implicit
     -- term.
     --
-    -- FIXME: this currently only looks at old components; doesn't search for new cycles.
-    --
     -- Running example:
     --
     --   #pingpong.pong => (<#pingpong.ping + 2>, "pong")
     --   #wham          => (<#pingpong.pong + 3>, "wham")
     implicitTerms :: Map TermReferenceId (Term Symbol Ann, Symbol) <-
       liftIO do
-        -- Running example:
-        --
-        --
-        --   { #pingpong }
-        let oldHashes :: Set Hash
-            oldHashes =
-              foldMap (Set.mapMaybe Reference.toHash) updatedNameToOldRefs
+        Codebase.withConnection codebase \conn ->
+          Sqlite.runTransaction conn do
+            -- Running example:
+            --
+            --   #pingpong => #newping
+            let oldHashToInterimHash :: Map Hash Hash
+                oldHashToInterimHash =
+                  updatedNameToRefs & foldMap \(oldRefs, interimRef) ->
+                    let interimHash = Reference.idToHash interimRef
+                     in Map.fromList $
+                          oldRefs
+                            & Set.toList
+                            & mapMaybe Reference.toHash
+                            & map (,interimHash)
 
-        oldHashes & foldMapM \oldHash -> do
-          -- Running example:
-          --
-          --   [ (<#pingpong.pong + 1>, <Nat>),
-          --     (<#pingpong.ping + 2>, <Nat>)
-          --   ]
-          terms <-
-            Codebase.withConnection codebase \conn ->
-              Sqlite.runTransaction conn (Codebase.unsafeGetTermComponent codebase oldHash)
-          pure $
-            terms
-              -- Running example:
-              --
-              --   [ (#pingpong.ping, (<#pingpong.pong + 1>, <Nat>)),
-              --     (#pingpong.pong, (<#pingpong.ping + 2>, <Nat>))
-              --   ]
-              & Reference.componentFor oldHash
-              & List.foldl'
-                ( \acc (ref, (term, _typ)) ->
-                    let -- (D) After getting the entire component of `oldHash`, which has at least one member being
-                        -- updated, we want to keep only the members that are *not* being updated (i.e. those who have
-                        -- no name that is being updated).
-                        --
-                        -- Running example, first time through (processing #pingpong.ping):
-                        --
-                        --   Set.disjoint { "ping" } { "ping" } is false, so don't add to the map.
-                        --
-                        -- Running example, second time through (processing #pingpong.pong):
-                        --
-                        --   Set.disjoint { "ping" } { "pong" } is true, so add
-                        --   #pingpong.pong => (<#pingpong.ping + 2>, { "pong" })) to the map.
-                        notBeingUpdated = Set.disjoint namesBeingUpdated
-                        nameIsUnconflicted name = Set.size (nameToTermRefs name) == 1
-                        names = termRefToNames ref
-                     in if notBeingUpdated names
-                          then case Foldable.find nameIsUnconflicted names {- (E) -} of
-                            Nothing -> acc
-                            Just name -> Map.insert ref (term, name) acc
-                          else acc
-                )
-                Map.empty
+            let hashToImplicitTerms :: Hash -> Sqlite.Transaction (Map TermReferenceId (Term Symbol Ann, Symbol))
+                hashToImplicitTerms hash = do
+                  -- Running example (for `oldHash` iteration):
+                  --
+                  --   [ (<#pingpong.pong + 1>, <Nat>),
+                  --     (<#pingpong.ping + 2>, <Nat>)
+                  --   ]
+                  terms <- Codebase.unsafeGetTermComponent codebase hash
+                  let keep :: TermReferenceId -> Maybe Symbol
+                      keep ref =
+                        if notBeingUpdated names
+                          then Foldable.find nameIsUnconflicted names -- (E)
+                          else Nothing
+                        where
+                          -- (D) After getting the entire component of `oldHash`, which has at least one member being
+                          -- updated, we want to keep only the members that are *not* being updated (i.e. those who have
+                          -- no name that is being updated).
+                          --
+                          -- Running example, first time through (processing #pingpong.ping):
+                          --
+                          --   Set.disjoint { "ping" } { "ping" } is false, so don't add to the map.
+                          --
+                          -- Running example, second time through (processing #pingpong.pong):
+                          --
+                          --   Set.disjoint { "ping" } { "pong" } is true, so add
+                          --   #pingpong.pong => (<#pingpong.ping + 2>, { "pong" })) to the map.
+                          notBeingUpdated = Set.disjoint namesBeingUpdated
+                          nameIsUnconflicted name = Set.size (nameToTermRefs name) == 1
+                          names = termRefToNames ref
+                  pure $
+                    terms
+                      -- Running example:
+                      --
+                      --   [ (#pingpong.ping, (<#pingpong.pong + 1>, <Nat>)),
+                      --     (#pingpong.pong, (<#pingpong.ping + 2>, <Nat>))
+                      --   ]
+                      & Reference.componentFor hash
+                      & List.foldl'
+                        ( \acc (ref, (term, _typ)) ->
+                            case keep ref of
+                              Nothing -> acc
+                              Just name -> Map.insert ref (term, name) acc
+                        )
+                        Map.empty
 
+            if Map.null oldHashToInterimHash
+              then pure Map.empty
+              else do
+                Sqlite.savepoint do
+                  -- Compute the actual interim decl/term components in the latest typechecked file. These aren't quite
+                  -- given in the unison file structure itself - in the `topLevelComponents'` field we have the
+                  -- components in some arbitrary order (I *think*), each tagged with its stringy name, and in the
+                  -- `hashTermsId` field we have all of the individual terms organized by reference.
+                  let interimDeclComponents :: [(Hash, [Decl Symbol Ann])]
+                      interimDeclComponents =
+                        decls UF.dataDeclarationsId' Right ++ decls UF.effectDeclarationsId' Left
+                        where
+                          decls ::
+                            (TypecheckedUnisonFile Symbol Ann -> Map Symbol (TypeReferenceId, decl)) ->
+                            (decl -> Decl Symbol Ann) ->
+                            [(Hash, [Decl Symbol Ann])]
+                          decls project inject =
+                            slurp0
+                              & Slurp.originalFile
+                              & project
+                              & Map.elems
+                              & recomponentize
+                              & over (mapped . _2 . mapped) inject
+                      interimTermComponents :: [(Hash, [(Term Symbol Ann, Type Symbol Ann)])]
+                      interimTermComponents =
+                        nameToInterimInfo
+                          & Map.elems
+                          & map (\(ref, _wk, term, typ) -> (ref, (term, typ)))
+                          & componentize
+                          & uncomponentize
+
+                  -- Insert each interim component into the codebase proper. Note: this relies on the codebase interface
+                  -- being smart enough to handle out-of-order components (i.e. inserting a dependent before a
+                  -- dependency). That's currently how the codebase interface works, but maybe in the future it'll grow
+                  -- a precondition that components can only be inserted after their dependencies.
+                  for_ interimDeclComponents \(hash, decls) -> Codebase.putTypeDeclarationComponent codebase hash decls
+                  for_ interimTermComponents \(hash, terms) -> Codebase.putTermComponent codebase hash terms
+
+                  terms <-
+                    let interimHashes :: Set Hash
+                        interimHashes = Set.fromList (map fst interimTermComponents)
+                     in Map.toList oldHashToInterimHash & foldMapM \(oldHash, interimHash) -> do
+                          hashes <-
+                            Queries.loadObjectIdForAnyHash oldHash >>= \case
+                              -- better would be to short-circuit all the way to the user and say, actually we can't
+                              -- perform this update at all, due to some intervening delete (e.g. some sort of
+                              -- hard-reset or garbage collection on the codebase)
+                              Nothing -> pure Set.empty
+                              Just oldOid -> do
+                                interimOid <- Queries.expectObjectIdForPrimaryHash interimHash
+                                betweenOids <- Queries.getDependenciesBetweenTerms interimOid oldOid
+                                (Set.\\ interimHashes) <$> Set.traverse Queries.expectPrimaryHashByObjectId betweenOids
+                          foldMapM hashToImplicitTerms (oldHash : Set.toList hashes)
+                  pure (Left terms) -- left = rollback to savepoint
     if Map.null implicitTerms
       then pure slurp0
       else do
@@ -363,26 +445,6 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
         --
         --   2. Re-typecheck, and if it that succeeds, use the resulting typechecked unison file and slurp.
 
-        -- Grab some interim info out of the original slurp.
-        --
-        -- Running example:
-        --
-        --   "ping" => (#newping, Nothing, <#wham + 4>, <Nat>)
-        let nameToInterimInfo :: Map Symbol (TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
-            nameToInterimInfo =
-              UF.hashTermsId (Slurp.originalFile slurp0)
-
-        -- Associate each term name being updated with its interim reference.
-        --
-        -- Running example:
-        --
-        --   "ping" <=> #newping
-        let nameToInterimRef :: Bij Symbol TermReferenceId
-            nameToInterimRef =
-              nameToInterimInfo
-                & Map.map (\(ref, _wk, _term, _typ) -> ref)
-                & bijFromMap
-
         -- Remap the references contained in each implicit term, then add back in the slurped interim terms and unhash
         -- the collection. The unhashing process will invent a fresh variable name for each term.
         --
@@ -423,21 +485,13 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
                 --   ref            -> ref
                 rewrite :: Term Symbol Ann -> Term Symbol Ann
                 rewrite =
-                  updatedNameToOldRefs
-                    & Map.toList
-                    & foldMap
-                      ( \(name, oldRefs) ->
-                          oldRefs
-                            & Set.toList
-                            & map
-                              ( \oldRef ->
-                                  case bijLookupL name nameToInterimRef of
-                                    Just interimRef -> (oldRef, interimRef)
-                                    Nothing -> error (reportBug "E798907" "no interim ref for name")
-                              )
-                            & Map.fromList
-                      )
-                    & rewriteTermReferences
+                  rewriteTermReferences (foldMap toMapping updatedNameToRefs)
+                  where
+                    toMapping ::
+                      (Set TermReference, TermReferenceId) ->
+                      Map TermReference TermReferenceId
+                    toMapping (oldRefs, interimRef) =
+                      foldMap (\oldRef -> Map.singleton oldRef interimRef) oldRefs
 
         let unisonFile :: UnisonFile Symbol Ann
             unisonFile =
@@ -454,7 +508,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
                   -- irrelevant, so we don't need to copy them over.
                   watches = Map.empty
                 }
-        result <- typecheckFile [] unisonFile
+        result <- liftIO (Codebase.runTransaction codebase (typecheckFile codebase [] unisonFile))
         case runIdentity (Result.toMaybe result) of
           Just (Right file0) -> do
             -- Map each name generated by unhashing back to the name it should have in the Unison file we're going to
@@ -469,13 +523,22 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
                 generatedNameToName =
                   refToGeneratedNameAndTerm & Map.remap \(ref, (generatedName, _term)) ->
                     ( generatedName,
-                      case bijLookupR ref nameToInterimRef of
+                      case Map.lookup ref interimRefToName of
                         Just name -> name
                         Nothing ->
                           case Map.lookup ref implicitTerms of
                             Just (_term, name) -> name
                             Nothing -> error (reportBug "E836680" "ref not interim nor implicit")
                     )
+                  where
+                    -- Associate each term name being updated with its interim reference.
+                    --
+                    -- Running example:
+                    --
+                    --   #newping => "ping"
+                    interimRefToName :: Map TermReferenceId Symbol
+                    interimRefToName =
+                      Map.remap (\(name, (ref, _wk, _term, _typ)) -> (ref, name)) nameToInterimInfo
 
             let renameTerm ::
                   (Symbol, Term Symbol Ann, Type Symbol Ann) ->
@@ -513,10 +576,10 @@ rewriteTermReferences mapping =
 
 -- updates the namespace for adding `slurp`
 doSlurpAdds ::
-  forall m v.
-  (Monad m, Var v) =>
-  SlurpComponent v ->
-  TypecheckedUnisonFile v Ann ->
+  forall m.
+  Monad m =>
+  SlurpComponent ->
+  TypecheckedUnisonFile Symbol Ann ->
   (Branch0 m -> Branch0 m)
 doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
   where
@@ -531,7 +594,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
       if Set.member v tests
         then Metadata.singleton isTestType isTestValue
         else Metadata.empty
-    doTerm :: v -> (Path, Branch0 m -> Branch0 m)
+    doTerm :: Symbol -> (Path, Branch0 m -> Branch0 m)
     doTerm v = case toList (Names.termsNamed names (Name.unsafeFromVar v)) of
       [] -> errorMissingVar v
       [r] ->
@@ -543,7 +606,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
             <> Var.nameStr v
             <> ": "
             <> show wha
-    doType :: v -> (Path, Branch0 m -> Branch0 m)
+    doType :: Symbol -> (Path, Branch0 m -> Branch0 m)
     doType v = case toList (Names.typesNamed names (Name.unsafeFromVar v)) of
       [] -> errorMissingVar v
       [r] ->
@@ -599,23 +662,26 @@ propagatePatchNoSync patch scopePath =
   Cli.time "propagatePatchNoSync" do
     Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
 
-------------------------------------------------------------------------------------------------------------------------
--- Tiny helper bijection type
---
--- This is semantically a set of `(a, b)` tuples, where no `a` nor `b` appears more than once. An `a` can be looked up
--- given its associated `b`, and vice-versa.
+recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])]
+recomponentize =
+  uncomponentize . componentize
 
-data Bij a b
-  = Bij (Map a b) (Map b a)
+-- Misc. helper: convert a component in listy-form to mappy-form.
+componentize :: [(Reference.Id, a)] -> Map Hash (Map Reference.Pos a)
+componentize =
+  foldl' step Map.empty
+  where
+    step :: Map Hash (Map Reference.Pos a) -> (Reference.Id, a) -> Map Hash (Map Reference.Pos a)
+    step acc (Reference.Id hash pos, x) =
+      Map.upsert
+        ( \case
+            Nothing -> Map.singleton pos x
+            Just acc1 -> Map.insert pos x acc1
+        )
+        hash
+        acc
 
-bijFromMap :: Ord b => Map a b -> Bij a b
-bijFromMap m =
-  Bij m (Map.remap Tuple.swap m)
-
-bijLookupL :: Ord a => a -> Bij a b -> Maybe b
-bijLookupL x (Bij m _) =
-  Map.lookup x m
-
-bijLookupR :: Ord b => b -> Bij a b -> Maybe a
-bijLookupR x (Bij _ m) =
-  Map.lookup x m
+-- Misc. helper: convert a component in mappy-form to listy-form.
+uncomponentize :: Map Hash (Map Reference.Pos a) -> [(Hash, [a])]
+uncomponentize =
+  over (mapped . _2) Map.elems . Map.toList

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

@@ -9,6 +9,7 @@ module Unison.Codebase.Editor.Input
     BranchId,
     AbsBranchId,
     parseBranchId,
+    parseShortCausalHash,
     HashOrHQSplit',
     Insistence (..),
     PullMode (..),
@@ -27,8 +28,8 @@ import Unison.Codebase.Path (Path')
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.Path.Parse as Path
 import Unison.Codebase.PushBehavior (PushBehavior)
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
+import qualified Unison.Codebase.ShortCausalHash as SCH
 import Unison.Codebase.SyncMode (SyncMode)
 import Unison.Codebase.Verbosity
 import qualified Unison.HashQualified as HQ
@@ -51,9 +52,9 @@ type PatchPath = Path.Split'
 data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
   deriving (Eq, Ord, Show)
 
-type BranchId = Either ShortBranchHash Path'
+type BranchId = Either ShortCausalHash Path'
 
-type AbsBranchId = Either ShortBranchHash Path.Absolute
+type AbsBranchId = Either ShortCausalHash Path.Absolute
 
 type HashOrHQSplit' = Either ShortHash Path.HQSplit'
 
@@ -62,11 +63,15 @@ data Insistence = Force | Try
   deriving (Show, Eq)
 
 parseBranchId :: String -> Either String BranchId
-parseBranchId ('#' : s) = case SBH.fromText (Text.pack s) of
+parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
   Nothing -> Left "Invalid hash, expected a base32hex string."
   Just h -> pure $ Left h
 parseBranchId s = Right <$> Path.parsePath' s
 
+parseShortCausalHash :: String -> Either String ShortCausalHash
+parseShortCausalHash ('#' : s) | Just sch <- SCH.fromText (Text.pack s) = Right sch
+parseShortCausalHash _ = Left "Invalid hash, expected a base32hex string."
+
 data PullMode
   = PullWithHistory
   | PullWithoutHistory
@@ -79,7 +84,7 @@ data Input
     -- directory ops
     -- `Link` must describe a repo and a source path within that repo.
     -- clone w/o merge, error if would clobber
-    ForkLocalBranchI (Either ShortBranchHash Path') Path'
+    ForkLocalBranchI (Either ShortCausalHash Path') Path'
   | -- merge first causal into destination
     MergeLocalBranchI Path' Path' Branch.MergeMode
   | PreviewMergeLocalBranchI Path' Path'
@@ -88,7 +93,7 @@ data Input
   | PushRemoteBranchI PushRemoteBranchInput
   | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace
   | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path'
-  | ResetRootI (Either ShortBranchHash Path')
+  | ResetRootI (Either ShortCausalHash Path')
   | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
     --          Does it make sense to fork from not-the-root of a Github repo?
     -- used in Welcome module to give directions to user
@@ -194,6 +199,7 @@ data Input
   | DebugDumpNamespaceSimpleI
   | DebugClearWatchI
   | DebugDoctorI
+  | DebugNameDiffI ShortCausalHash ShortCausalHash
   | QuitI
   | ApiI
   | UiI

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

@@ -20,6 +20,7 @@ import Data.Set.NonEmpty (NESet)
 import Data.Time (UTCTime)
 import Network.URI (URI)
 import qualified System.Console.Haskeline as Completion
+import U.Codebase.Branch.Diff (NameChanges)
 import Unison.Auth.Types (CredentialFailure)
 import qualified Unison.Codebase.Branch as Branch
 import Unison.Codebase.Editor.DisplayObject (DisplayObject)
@@ -36,8 +37,8 @@ import Unison.Codebase.Path (Path')
 import qualified Unison.Codebase.Path as Path
 import Unison.Codebase.PushBehavior (PushBehavior)
 import qualified Unison.Codebase.Runtime as Runtime
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
+import qualified Unison.Codebase.ShortCausalHash as SCH
 import Unison.Codebase.Type (GitError)
 import qualified Unison.CommandLine.InputPattern as Input
 import Unison.DataDeclaration (Decl)
@@ -122,7 +123,7 @@ data Output
     NoMainFunction String PPE.PrettyPrintEnv [Type Symbol Ann]
   | -- Main function found, but has improper type
     BadMainFunction String (Type Symbol Ann) PPE.PrettyPrintEnv [Type Symbol Ann]
-  | BranchEmpty (Either ShortBranchHash Path')
+  | BranchEmpty (Either ShortCausalHash Path')
   | BranchNotEmpty Path'
   | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path'
   | CreatedNewBranch Path.Absolute
@@ -140,7 +141,7 @@ data Output
   | DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference)
   | TermAmbiguous (HQ.HashQualified Name) (Set Referent)
   | HashAmbiguous ShortHash (Set Referent)
-  | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash)
+  | BranchHashAmbiguous ShortCausalHash (Set ShortCausalHash)
   | BadNamespace String String
   | BranchNotFound Path'
   | EmptyPush Path'
@@ -186,7 +187,7 @@ data Output
   | ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann]
   | ListOfPatches (Set Name)
   | -- show the result of add/update
-    SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult Symbol)
+    SlurpOutput Input PPE.PrettyPrintEnv SlurpResult
   | -- Original source, followed by the errors:
     ParseErrors Text [Parser.Err Symbol]
   | TypeErrors Path.Absolute Text PPE.PrettyPrintEnv [Context.ErrorNote Symbol Ann]
@@ -199,7 +200,7 @@ data Output
       [(Symbol, Term Symbol ())]
       (Map Symbol (Ann, WK.WatchKind, Term Symbol (), Runtime.IsCacheHit))
   | RunResult PPE.PrettyPrintEnv (Term Symbol ())
-  | Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult Symbol) (UF.TypecheckedUnisonFile Symbol Ann)
+  | Typechecked SourceName PPE.PrettyPrintEnv SlurpResult (UF.TypecheckedUnisonFile Symbol Ann)
   | DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText)
   | -- "display" definitions, possibly to a FilePath on disk (e.g. editing)
     DisplayDefinitions
@@ -234,9 +235,9 @@ data Output
     NothingToPatch PatchPath Path'
   | PatchNeedsToBeConflictFree
   | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference)
-  | WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash)
+  | WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash)
   | StartOfCurrentPathHistory
-  | ShowReflog [(Maybe UTCTime, SBH.ShortBranchHash, Text)]
+  | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)]
   | PullAlreadyUpToDate ReadRemoteNamespace Path'
   | PullSuccessful ReadRemoteNamespace Path'
   | -- | Indicates a trivial merge where the destination was empty and was just replaced.
@@ -246,7 +247,7 @@ data Output
   | -- | No conflicts or edits remain for the current patch.
     NoConflictsOrEdits
   | NotImplemented
-  | NoBranchWithHash ShortBranchHash
+  | NoBranchWithHash ShortCausalHash
   | ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference)
   | -- | List dependents of a type or term.
     ListDependents Int LabeledDependency [(Reference, Maybe Name)]
@@ -274,6 +275,7 @@ data Output
   | CredentialFailureMsg CredentialFailure
   | PrintVersion Text
   | IntegrityCheck IntegrityResult
+  | DisplayDebugNameDiff NameChanges
   | DisplayDebugCompletions [Completion.Completion]
 
 data ShareError
@@ -321,7 +323,8 @@ isFailure o = case o of
   BadMainFunction {} -> True
   CreatedNewBranch {} -> False
   BranchAlreadyExists {} -> True
-  FindNoLocalMatches {} -> True
+  -- we do a global search after finding no local matches, so let's not call this a failure yet
+  FindNoLocalMatches {} -> False
   PatchAlreadyExists {} -> True
   NoExactTypeMatches -> True
   BranchEmpty {} -> True
@@ -420,6 +423,7 @@ isFailure o = case o of
   ShareError {} -> True
   ViewOnShare {} -> False
   DisplayDebugCompletions {} -> False
+  DisplayDebugNameDiff {} -> False
 
 isNumberedFailure :: NumberedOutput -> Bool
 isNumberedFailure = \case

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

@@ -144,9 +144,9 @@ propagateCtorMapping oldComponent newComponent =
 -- If the cycle is size 1 for old and new, then the type names need not be the same,
 -- and if the number of constructors is 1, then the constructor names need not
 -- be the same.
-genInitialCtorMapping :: Codebase IO Symbol Ann -> Names -> Map Reference Reference -> Cli (Map Referent Referent)
+genInitialCtorMapping :: Codebase IO Symbol Ann -> Names -> Map Reference Reference -> Sqlite.Transaction (Map Referent Referent)
 genInitialCtorMapping codebase rootNames initialTypeReplacements = do
-  let mappings :: (Reference, Reference) -> Cli (Map Referent Referent)
+  let mappings :: (Reference, Reference) -> Sqlite.Transaction (Map Referent Referent)
       mappings (old, new) = do
         old <- unhashTypeComponent codebase old
         new <- fmap (over _2 (either Decl.toDataDecl id)) <$> unhashTypeComponent codebase new
@@ -264,19 +264,24 @@ propagate patch b = case validatePatch patch of
           n : _ -> show n
 
     Cli.Env {codebase} <- ask
-    initialDirty <-
-      computeDirty
-        (liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent)
-        patch
-        (Names.contains names0)
 
-    let initialTypeReplacements = Map.mapMaybe TypeEdit.toReference initialTypeEdits
-    -- TODO: once patches can directly contain constructor replacements, this
-    -- line can turn into a pure function that takes the subset of the term replacements
-    -- in the patch which have a `Referent.Con` as their LHS.
-    initialCtorMappings <- genInitialCtorMapping codebase rootNames initialTypeReplacements
+    (initialDirty, initialTypeReplacements, initialCtorMappings, order) <-
+      Cli.runTransaction do
+        initialDirty <-
+          computeDirty
+            (Codebase.dependents codebase Queries.ExcludeOwnComponent)
+            patch
+            (Names.contains names0)
+
+        let initialTypeReplacements = Map.mapMaybe TypeEdit.toReference initialTypeEdits
+        -- TODO: once patches can directly contain constructor replacements, this
+        -- line can turn into a pure function that takes the subset of the term replacements
+        -- in the patch which have a `Referent.Con` as their LHS.
+        initialCtorMappings <- genInitialCtorMapping codebase rootNames initialTypeReplacements
+
+        order <- sortDependentsGraph codebase initialDirty entireBranch
+        pure (initialDirty, initialTypeReplacements, initialCtorMappings, order)
 
-    order <- liftIO (sortDependentsGraph codebase initialDirty entireBranch)
     let getOrdered :: Set Reference -> Map Int Reference
         getOrdered rs =
           Map.fromList [(i, r) | r <- toList rs, Just i <- [Map.lookup r order]]
@@ -302,26 +307,29 @@ propagate patch b = case validatePatch patch of
               if Map.member r termEdits || Set.member r seen || Map.member r typeEdits
                 then collectEdits es seen todo
                 else do
-                  haveType <- liftIO (Codebase.isType codebase r)
-                  haveTerm <- liftIO (Codebase.isTerm codebase r)
-                  let message =
-                        "This reference is not a term nor a type " <> show r
+                  mayEdits <-
+                    Cli.runTransaction do
+                      haveType <- Codebase.isType codebase r
+                      haveTerm <- Codebase.isTerm codebase r
+                      let message =
+                            "This reference is not a term nor a type " <> show r
+                          mmayEdits
+                            | haveTerm = doTerm r
+                            | haveType = doType r
+                            | otherwise = error message
                       mmayEdits
-                        | haveTerm = doTerm r
-                        | haveType = doType r
-                        | otherwise = error message
-                  mayEdits <- mmayEdits
                   case mayEdits of
                     (Nothing, seen') -> collectEdits es seen' todo
                     (Just edits', seen') -> do
                       -- plan to update the dependents of this component too
                       dependents <- case r of
-                        Reference.Builtin {} -> liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
+                        Reference.Builtin {} ->
+                          Cli.runTransaction (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
                         Reference.Derived h _i -> liftIO (Codebase.dependentsOfComponent codebase h)
                       let todo' = todo <> getOrdered dependents
                       collectEdits edits' seen' todo'
 
-            doType :: Reference -> Cli (Maybe (Edits Symbol), Set Reference)
+            doType :: Reference -> Sqlite.Transaction (Maybe (Edits Symbol), Set Reference)
             doType r = do
               when debugMode $ traceM ("Rewriting type: " <> refName r)
               componentMap <- unhashTypeComponent codebase r
@@ -365,7 +373,7 @@ propagate patch b = case validatePatch patch of
                     )
                   seen' = seen <> Set.fromList (view _1 . view _2 <$> joinedStuff)
                   writeTypes = traverse_ $ \case
-                    (Reference.DerivedId id, tp) -> liftIO (Codebase.putTypeDeclaration codebase id tp)
+                    (Reference.DerivedId id, tp) -> Codebase.putTypeDeclaration codebase id tp
                     _ -> error "propagate: Expected DerivedId"
                   !newCtorMappings =
                     let r = propagateCtorMapping componentMap hashedComponents'
@@ -384,17 +392,18 @@ propagate patch b = case validatePatch patch of
                       constructorReplacements',
                   seen'
                 )
-            doTerm :: Reference -> Cli (Maybe (Edits Symbol), Set Reference)
+            doTerm :: Reference -> Sqlite.Transaction (Maybe (Edits Symbol), Set Reference)
             doTerm r = do
               when debugMode (traceM $ "Rewriting term: " <> show r)
-              componentMap <- unhashTermComponent r
-              let componentMap' =
-                    over
-                      _2
-                      (Term.updateDependencies termReplacements typeReplacements)
-                      <$> componentMap
-                  seen' = seen <> Set.fromList (view _1 <$> Map.elems componentMap)
-              mayComponent <- verifyTermComponent componentMap' es
+              componentMap <- unhashTermComponent codebase r
+              let seen' = seen <> Set.fromList (view _1 <$> Map.elems componentMap)
+              mayComponent <- do
+                let componentMap' =
+                      over
+                        _2
+                        (Term.updateDependencies termReplacements typeReplacements)
+                        <$> componentMap
+                verifyTermComponent codebase componentMap' es
               case mayComponent of
                 Nothing -> do
                   when debugMode (traceM $ refName r <> " did not typecheck after substitutions")
@@ -424,7 +433,7 @@ propagate patch b = case validatePatch patch of
                       toNewTerm (_, r', tm, _, tp) = (r', (tm, tp))
                       writeTerms =
                         traverse_ \case
-                          (Reference.DerivedId id, (tm, tp)) -> liftIO (Codebase.putTerm codebase id tm tp)
+                          (Reference.DerivedId id, (tm, tp)) -> Codebase.putTerm codebase id tm tp
                           _ -> error "propagate: Expected DerivedId"
                   writeTerms
                     [(r, (tm, ty)) | (_old, r, tm, _oldTy, ty) <- joinedStuff]
@@ -457,15 +466,15 @@ propagate patch b = case validatePatch patch of
     initialTermReplacements ctors es =
       ctors
         <> (Map.mapKeys Referent.Ref . fmap Referent.Ref . Map.mapMaybe TermEdit.toReference) es
-    sortDependentsGraph :: Codebase IO Symbol Ann -> Set Reference -> Set Reference -> IO (Map Reference Int)
+    sortDependentsGraph :: Codebase IO Symbol Ann -> Set Reference -> Set Reference -> Sqlite.Transaction (Map Reference Int)
     sortDependentsGraph codebase dependencies restrictTo = do
       closure <-
         transitiveClosure
-          (fmap (Set.intersection restrictTo) . liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent)
+          (fmap (Set.intersection restrictTo) . Codebase.dependents codebase Queries.ExcludeOwnComponent)
           dependencies
       dependents <-
         traverse
-          (\r -> (r,) <$> (liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent) r)
+          (\r -> (r,) <$> (Codebase.dependents codebase Queries.ExcludeOwnComponent) r)
           (toList closure)
       let graphEdges = [(r, r, toList deps) | (r, deps) <- toList dependents]
           (graph, getReference, _) = Graph.graphFromEdges graphEdges
@@ -486,20 +495,22 @@ propagate patch b = case validatePatch patch of
     --  Free (Command m i v) monad, passing in the actions that are needed.
     -- However, if we want this to be parametric in the annotation type, then
     -- Command would have to be made parametric in the annotation type too.
-    unhashTermComponent :: Reference -> Cli (Map Symbol (Reference, Term Symbol Ann, Type Symbol Ann))
-    unhashTermComponent r = case Reference.toId r of
+    unhashTermComponent ::
+      Codebase m Symbol Ann ->
+      Reference ->
+      Sqlite.Transaction (Map Symbol (Reference, Term Symbol Ann, Type Symbol Ann))
+    unhashTermComponent codebase r = case Reference.toId r of
       Nothing -> pure mempty
       Just r -> do
-        unhashed <- unhashTermComponent' (Reference.idToHash r)
+        unhashed <- unhashTermComponent' codebase (Reference.idToHash r)
         pure $ fmap (over _1 Reference.DerivedId) unhashed
 
-    unhashTermComponent' :: Hash -> Cli (Map Symbol (Reference.Id, Term Symbol Ann, Type Symbol Ann))
-    unhashTermComponent' h = do
-      Cli.Env {codebase} <- ask
-      maybeTermsWithTypes <-
-        liftIO do
-          Codebase.withConnection codebase \conn ->
-            Sqlite.runTransaction conn (Codebase.getTermComponentWithTypes codebase h)
+    unhashTermComponent' ::
+      Codebase m Symbol Ann ->
+      Hash ->
+      Sqlite.Transaction (Map Symbol (Reference.Id, Term Symbol Ann, Type Symbol Ann))
+    unhashTermComponent' codebase h = do
+      maybeTermsWithTypes <- Codebase.getTermComponentWithTypes codebase h
       pure do
         foldMap (\termsWithTypes -> unhash $ Map.fromList (Reference.componentFor h termsWithTypes)) maybeTermsWithTypes
       where
@@ -512,10 +523,11 @@ propagate patch b = case validatePatch patch of
                 [(v, (r, tm, tp)) | (r, (v, tm, tp)) <- Map.toList m']
 
     verifyTermComponent ::
+      Codebase m Symbol Ann ->
       Map Symbol (Reference, Term Symbol Ann, a) ->
       Edits Symbol ->
-      Cli (Maybe (Map Symbol (Reference, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)))
-    verifyTermComponent componentMap Edits {..} = do
+      Sqlite.Transaction (Maybe (Map Symbol (Reference, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)))
+    verifyTermComponent codebase componentMap Edits {..} = do
       -- If the term contains references to old patterns, we can't update it.
       -- If the term had a redunant type signature, it's discarded and a new type
       -- is inferred. If it wasn't redunant, we have already substituted any updates
@@ -538,32 +550,32 @@ propagate patch b = case validatePatch patch of
                   mempty
                   (Map.toList $ (\(_, tm, _) -> tm) <$> componentMap)
                   mempty
-          typecheckResult <- typecheckFile [] file
+          typecheckResult <- typecheckFile codebase [] file
           pure
             . fmap UF.hashTerms
             $ runIdentity (Result.toMaybe typecheckResult)
               >>= hush
 
 typecheckFile ::
+  Codebase m Symbol Ann ->
   [Type Symbol Ann] ->
   UF.UnisonFile Symbol Ann ->
-  Cli (Result.Result (Seq (Result.Note Symbol Ann)) (Either Names (UF.TypecheckedUnisonFile Symbol Ann)))
-typecheckFile ambient file = do
-  Cli.Env {codebase} <- ask
-  typeLookup <- liftIO (Codebase.typeLookupForDependencies codebase (UF.dependencies file))
+  Sqlite.Transaction (Result.Result (Seq (Result.Note Symbol Ann)) (Either Names (UF.TypecheckedUnisonFile Symbol Ann)))
+typecheckFile codebase ambient file = do
+  typeLookup <- Codebase.typeLookupForDependencies codebase (UF.dependencies file)
   pure . fmap Right $ synthesizeFile' ambient (typeLookup <> Builtin.typeLookup) file
 
 -- TypecheckFile file ambient -> liftIO $ typecheck' ambient codebase file
-unhashTypeComponent :: Codebase IO Symbol Ann -> Reference -> Cli (Map Symbol (Reference, Decl Symbol Ann))
+unhashTypeComponent :: Codebase IO Symbol Ann -> Reference -> Sqlite.Transaction (Map Symbol (Reference, Decl Symbol Ann))
 unhashTypeComponent codebase r = case Reference.toId r of
   Nothing -> pure mempty
   Just id -> do
     unhashed <- unhashTypeComponent' codebase (Reference.idToHash id)
     pure $ over _1 Reference.DerivedId <$> unhashed
 
-unhashTypeComponent' :: Codebase IO Symbol Ann -> Hash -> Cli (Map Symbol (Reference.Id, Decl Symbol Ann))
+unhashTypeComponent' :: Codebase IO Symbol Ann -> Hash -> Sqlite.Transaction (Map Symbol (Reference.Id, Decl Symbol Ann))
 unhashTypeComponent' codebase h =
-  liftIO (Codebase.getDeclComponent codebase h) <&> foldMap \decls ->
+  Codebase.getDeclComponent codebase h <&> foldMap \decls ->
     unhash $ Map.fromList (Reference.componentFor h decls)
   where
     unhash =

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

@@ -23,6 +23,7 @@ import Unison.Prelude
 import Unison.Referent (Referent)
 import qualified Unison.Referent as Referent
 import qualified Unison.Referent' as Referent
+import Unison.Symbol (Symbol)
 import qualified Unison.UnisonFile as UF
 import qualified Unison.UnisonFile.Names as UF
 import qualified Unison.Util.Map as Map
@@ -41,11 +42,11 @@ data SlurpOp
   deriving (Eq, Show)
 
 -- | Tag a variable as representing a term, type, or constructor
-data TaggedVar v = TermVar v | TypeVar v | ConstructorVar v
+data TaggedVar = TermVar Symbol | TypeVar Symbol | ConstructorVar Symbol
   deriving (Eq, Ord, Show)
 
 -- | Extract the var from a TaggedVar
-untagged :: TaggedVar v -> v
+untagged :: TaggedVar -> Symbol
 untagged (TermVar v) = v
 untagged (TypeVar v) = v
 untagged (ConstructorVar v) = v
@@ -95,24 +96,22 @@ mostSevereDepStatus =
 -- | Analyze a file and determine the status of all of its definitions with respect to a set
 -- of vars to analyze and an operation you wish to perform.
 slurpFile ::
-  forall v.
-  Var v =>
-  UF.TypecheckedUnisonFile v Ann ->
-  Set v ->
+  UF.TypecheckedUnisonFile Symbol Ann ->
+  Set Symbol ->
   SlurpOp ->
   Names ->
-  SR.SlurpResult v
+  SR.SlurpResult
 slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
   let -- A mapping of all vars in the file to their references.
       -- TypeVars are keyed to Type references
       -- TermVars are keyed to Term references
       -- ConstructorVars are keyed to Constructor references
-      varReferences :: Map (TaggedVar v) LD.LabeledDependency
+      varReferences :: Map TaggedVar LD.LabeledDependency
       varReferences = buildVarReferences uf
       -- All variables which were either:
       -- 1. specified explicitly by the end-user
       -- 2. An in-file transitive dependency (within the file) of a var specified by the end-user.
-      involvedVars :: Set (TaggedVar v)
+      involvedVars :: Set TaggedVar
       involvedVars = computeInvolvedVars uf defsToConsider varReferences
       -- The set of names after removing any constructors which would
       -- be removed by the requested operation.
@@ -121,14 +120,14 @@ slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
       -- A mapping of every involved variable to its transitive dependencies.
       -- Dependency here is any type or term referenced within the definition (transitively).
       -- This also includes all Constructors of any type used by a term.
-      varDeps :: Map (TaggedVar v) (Set (TaggedVar v))
+      varDeps :: Map TaggedVar (Set TaggedVar)
       varDeps = computeVarDeps uf involvedVars
       -- Compute the status of each definition on its own.
       -- This doesn't consider the vars dependencies.
-      selfStatuses :: Map (TaggedVar v) DefnStatus
+      selfStatuses :: Map TaggedVar DefnStatus
       selfStatuses = computeSelfStatuses involvedVars varReferences codebaseNames
       -- A mapping from each definition's name to the most severe status of it plus its transitive dependencies.
-      depStatuses :: Map (TaggedVar v) DepStatus
+      depStatuses :: Map TaggedVar DepStatus
       depStatuses = computeDepStatuses varDeps selfStatuses
    in toSlurpResult uf slurpOp defsToConsider involvedVars fileNames codebaseNames selfStatuses depStatuses
   where
@@ -138,10 +137,9 @@ slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
 -- | Return a modified set of names with constructors which would be deprecated by possible
 -- updates are removed.
 computeNamesWithDeprecations ::
-  Var v =>
-  UF.TypecheckedUnisonFile v Ann ->
+  UF.TypecheckedUnisonFile Symbol Ann ->
   Names ->
-  Set (TaggedVar v) ->
+  Set TaggedVar ->
   SlurpOp ->
   Names
 computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
@@ -183,16 +181,14 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
 
 -- | Compute a mapping of each definition to its status.
 computeSelfStatuses ::
-  forall v.
-  (Ord v, Var v) =>
-  Set (TaggedVar v) ->
-  Map (TaggedVar v) LD.LabeledDependency ->
+  Set TaggedVar ->
+  Map TaggedVar LD.LabeledDependency ->
   Names ->
-  Map (TaggedVar v) DefnStatus
+  Map TaggedVar DefnStatus
 computeSelfStatuses vars varReferences codebaseNames =
   Map.fromSet definitionStatus vars
   where
-    definitionStatus :: TaggedVar v -> DefnStatus
+    definitionStatus :: TaggedVar -> DefnStatus
     definitionStatus tv =
       let ld = case Map.lookup tv varReferences of
             Just r -> r
@@ -232,12 +228,10 @@ computeDepStatuses varDeps selfStatuses =
 -- I.e. any variable requested by the user and all of their dependencies,
 -- component peers, and component peers of dependencies.
 computeInvolvedVars ::
-  forall v.
-  Var v =>
-  UF.TypecheckedUnisonFile v Ann ->
-  Set v ->
-  Map (TaggedVar v) LD.LabeledDependency ->
-  Set (TaggedVar v)
+  UF.TypecheckedUnisonFile Symbol Ann ->
+  Set Symbol ->
+  Map TaggedVar LD.LabeledDependency ->
+  Set TaggedVar
 computeInvolvedVars uf defsToConsider varReferences
   -- If nothing was specified, consider every var in the file.
   | Set.null defsToConsider = Map.keysSet varReferences
@@ -245,8 +239,8 @@ computeInvolvedVars uf defsToConsider varReferences
   where
     -- The user specifies _untyped_ names, which may not even exist in the file.
     -- We need to figure out which vars exist, and what type they are if they do.
-    requestedVarsWhichActuallyExist :: Set (TaggedVar v)
-    requestedVarsWhichActuallyExist = Set.fromList $ do
+    requestedVarsWhichActuallyExist :: Set TaggedVar
+    requestedVarsWhichActuallyExist = Set.fromList do
       v <- Set.toList defsToConsider
       -- We don't know whether each var is a type or term, so we try both.
       -- We don't test ConstructorVar because you can't request to add/update a Constructor in
@@ -257,11 +251,9 @@ computeInvolvedVars uf defsToConsider varReferences
 
 -- | Compute transitive dependencies for all relevant variables.
 computeVarDeps ::
-  forall v.
-  Var v =>
-  UF.TypecheckedUnisonFile v Ann ->
-  Set (TaggedVar v) ->
-  Map (TaggedVar v) (Set (TaggedVar v))
+  UF.TypecheckedUnisonFile Symbol Ann ->
+  Set TaggedVar ->
+  Map TaggedVar (Set TaggedVar)
 computeVarDeps uf allInvolvedVars =
   allInvolvedVars
     & Set.toList
@@ -272,17 +264,17 @@ computeVarDeps uf allInvolvedVars =
 
 -- | Compute the closure of all vars which the provided vars depend on.
 -- A type depends on its constructors.
-varClosure :: (Var v) => UF.TypecheckedUnisonFile v a -> Set (TaggedVar v) -> Set (TaggedVar v)
+varClosure :: UF.TypecheckedUnisonFile Symbol a -> Set TaggedVar -> Set TaggedVar
 varClosure uf (partitionVars -> sc) =
   let deps = SC.closeWithDependencies uf sc
    in mingleVars deps
 
 -- | Collect a relation of term or type var to labelled dependency for all definitions mentioned in a file.
-buildVarReferences :: forall v a. (Ord v, Show v) => UF.TypecheckedUnisonFile v a -> Map (TaggedVar v) LD.LabeledDependency
+buildVarReferences :: UF.TypecheckedUnisonFile Symbol a -> Map TaggedVar LD.LabeledDependency
 buildVarReferences uf =
   decls <> effects <> terms <> constructors
   where
-    terms :: Map (TaggedVar v) LD.LabeledDependency
+    terms :: Map TaggedVar LD.LabeledDependency
     terms =
       UF.hashTermsId uf
         -- Filter out non-test watch expressions
@@ -295,30 +287,30 @@ buildVarReferences uf =
         & Map.bimap
           TermVar
           (\(refId, _, _, _) -> LD.derivedTerm refId)
-    decls :: Map (TaggedVar v) LD.LabeledDependency
+    decls :: Map TaggedVar LD.LabeledDependency
     decls =
       UF.dataDeclarationsId' uf
         & Map.bimap
           TypeVar
           (\(refId, _) -> LD.derivedType refId)
 
-    effects :: Map (TaggedVar v) LD.LabeledDependency
+    effects :: Map TaggedVar LD.LabeledDependency
     effects =
       UF.effectDeclarationsId' uf
         & Map.bimap
           TypeVar
           (\(refId, _) -> LD.derivedType refId)
 
-    constructors :: Map (TaggedVar v) LD.LabeledDependency
+    constructors :: Map TaggedVar LD.LabeledDependency
     constructors =
-      let effectConstructors :: Map (TaggedVar v) LD.LabeledDependency
+      let effectConstructors :: Map TaggedVar LD.LabeledDependency
           effectConstructors = Map.fromList $ do
             (_, (typeRefId, effect)) <- Map.toList (UF.effectDeclarations' uf)
             let decl = DD.toDataDecl effect
             (conId, constructorV) <- zip (DD.constructorIds decl) (DD.constructorVars decl)
             pure $ (ConstructorVar constructorV, LD.effectConstructor (CR.ConstructorReference typeRefId conId))
 
-          dataConstructors :: Map (TaggedVar v) LD.LabeledDependency
+          dataConstructors :: Map TaggedVar LD.LabeledDependency
           dataConstructors = Map.fromList $ do
             (_, (typeRefId, decl)) <- Map.toList (UF.dataDeclarations' uf)
             (conId, constructorV) <- zip (DD.constructorIds decl) (DD.constructorVars decl)
@@ -326,16 +318,16 @@ buildVarReferences uf =
        in effectConstructors <> dataConstructors
 
 -- A helper type just used by 'toSlurpResult' for partitioning results.
-data SlurpingSummary v = SlurpingSummary
-  { adds :: !(SlurpComponent v),
-    duplicates :: !(SlurpComponent v),
-    updates :: !(SlurpComponent v),
-    termCtorColl :: !(SlurpComponent v),
-    ctorTermColl :: !(SlurpComponent v),
-    blocked :: !(SlurpComponent v)
+data SlurpingSummary = SlurpingSummary
+  { adds :: !SlurpComponent,
+    duplicates :: !SlurpComponent,
+    updates :: !SlurpComponent,
+    termCtorColl :: !SlurpComponent,
+    ctorTermColl :: !SlurpComponent,
+    blocked :: !SlurpComponent
   }
 
-instance Ord v => Semigroup (SlurpingSummary v) where
+instance Semigroup SlurpingSummary where
   SlurpingSummary a b c d e f
     <> SlurpingSummary a' b' c' d' e' f' =
       SlurpingSummary
@@ -346,22 +338,20 @@ instance Ord v => Semigroup (SlurpingSummary v) where
         (e <> e')
         (f <> f')
 
-instance Ord v => Monoid (SlurpingSummary v) where
+instance Monoid SlurpingSummary where
   mempty = SlurpingSummary mempty mempty mempty mempty mempty mempty
 
 -- | Convert a 'VarsByStatus' mapping into a 'SR.SlurpResult'
 toSlurpResult ::
-  forall v.
-  (Var v) =>
-  UF.TypecheckedUnisonFile v Ann ->
+  UF.TypecheckedUnisonFile Symbol Ann ->
   SlurpOp ->
-  Set v ->
-  Set (TaggedVar v) ->
+  Set Symbol ->
+  Set TaggedVar ->
   Names ->
   Names ->
-  Map (TaggedVar v) DefnStatus ->
-  Map (TaggedVar v) DepStatus ->
-  SR.SlurpResult v
+  Map TaggedVar DefnStatus ->
+  Map TaggedVar DepStatus ->
+  SR.SlurpResult
 toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatuses depStatuses =
   SR.SlurpResult
     { SR.originalFile = uf,
@@ -393,7 +383,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
 
     -- Compute a singleton summary for a single definition, per its own status and the most severe status of its
     -- transitive dependencies.
-    summarize1 :: TaggedVar v -> DefnStatus -> SlurpingSummary v
+    summarize1 :: TaggedVar -> DefnStatus -> SlurpingSummary
     summarize1 name = \case
       CtorTermCollision -> mempty {ctorTermColl = sc}
       Duplicated -> mempty {duplicates = sc}
@@ -413,7 +403,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
           DepNeedsUpdate -> mempty {updates = sc}
           DepCollision -> mempty {blocked = sc}
       where
-        sc :: SlurpComponent v
+        sc :: SlurpComponent
         sc =
           scFromTaggedVar name
 
@@ -421,7 +411,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
         depStatus =
           Map.findWithDefault DepOk name depStatuses
 
-    scFromTaggedVar :: TaggedVar v -> SlurpComponent v
+    scFromTaggedVar :: TaggedVar -> SlurpComponent
     scFromTaggedVar = \case
       TermVar v -> SC.fromTerms (Set.singleton v)
       TypeVar v -> SC.fromTypes (Set.singleton v)
@@ -430,8 +420,8 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
     buildAliases ::
       Rel.Relation Name Referent ->
       Rel.Relation Name Referent ->
-      Set v ->
-      Map v SR.Aliases
+      Set Symbol ->
+      Map Symbol SR.Aliases
     buildAliases existingNames namesFromFile dups =
       Map.fromList
         [ ( varFromName n,
@@ -452,14 +442,14 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
             Set.notMember (varFromName n) dups
         ]
 
-    termAliases :: Map v SR.Aliases
+    termAliases :: Map Symbol SR.Aliases
     termAliases =
       buildAliases
         (Names.terms codebaseNames)
         (Names.terms fileNames)
         (SC.terms duplicates)
 
-    typeAliases :: Map v SR.Aliases
+    typeAliases :: Map Symbol SR.Aliases
     typeAliases =
       buildAliases
         (Rel.mapRan Referent.Ref $ Names.types codebaseNames)
@@ -470,7 +460,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
     varFromName name = Var.named (Name.toText name)
 
 -- | Sort out a set of variables by whether it is a term or type.
-partitionVars :: (Foldable f, Ord v) => f (TaggedVar v) -> SlurpComponent v
+partitionVars :: Foldable f => f TaggedVar -> SlurpComponent
 partitionVars =
   foldMap
     ( \case
@@ -480,7 +470,7 @@ partitionVars =
     )
 
 -- | Collapse a SlurpComponent into a tagged set.
-mingleVars :: Ord v => SlurpComponent v -> Set (TaggedVar v)
+mingleVars :: SlurpComponent -> Set TaggedVar
 mingleVars SlurpComponent {terms, types, ctors} =
   Set.map TypeVar types
     <> Set.map TermVar terms

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

@@ -1,41 +1,64 @@
-{-# LANGUAGE PatternSynonyms #-}
+module Unison.Codebase.Editor.SlurpComponent
+  ( -- * Slurp component
+    SlurpComponent (..),
 
-module Unison.Codebase.Editor.SlurpComponent where
+    -- ** Basic constructors
+    empty,
+    fromTerms,
+    fromTypes,
+    fromCtors,
+
+    -- ** Predicates
+    isEmpty,
+
+    -- ** Set operations
+    difference,
+    intersection,
+
+    -- ** Closure
+    closeWithDependencies,
+  )
+where
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Tuple (swap)
 import qualified Unison.DataDeclaration as DD
-import Unison.Prelude
+import Unison.Prelude hiding (empty)
 import Unison.Reference (Reference)
+import Unison.Symbol (Symbol)
 import qualified Unison.Term as Term
 import Unison.UnisonFile (TypecheckedUnisonFile)
 import qualified Unison.UnisonFile as UF
 
-data SlurpComponent v = SlurpComponent {types :: Set v, terms :: Set v, ctors :: Set v}
+data SlurpComponent = SlurpComponent
+  { types :: Set Symbol,
+    terms :: Set Symbol,
+    ctors :: Set Symbol
+  }
   deriving (Eq, Ord, Show)
 
-isEmpty :: SlurpComponent v -> Bool
+isEmpty :: SlurpComponent -> Bool
 isEmpty sc = Set.null (types sc) && Set.null (terms sc) && Set.null (ctors sc)
 
-empty :: Ord v => SlurpComponent v
-empty = SlurpComponent {types = mempty, terms = mempty, ctors = mempty}
+empty :: SlurpComponent
+empty = SlurpComponent {types = Set.empty, terms = Set.empty, ctors = Set.empty}
 
-difference :: Ord v => SlurpComponent v -> SlurpComponent v -> SlurpComponent v
+difference :: SlurpComponent -> SlurpComponent -> SlurpComponent
 difference c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'}
   where
     types' = types c1 `Set.difference` types c2
     terms' = terms c1 `Set.difference` terms c2
     ctors' = ctors c1 `Set.difference` ctors c2
 
-intersection :: Ord v => SlurpComponent v -> SlurpComponent v -> SlurpComponent v
+intersection :: SlurpComponent -> SlurpComponent -> SlurpComponent
 intersection c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'}
   where
     types' = types c1 `Set.intersection` types c2
     terms' = terms c1 `Set.intersection` terms c2
     ctors' = ctors c1 `Set.intersection` ctors c2
 
-instance Ord v => Semigroup (SlurpComponent v) where
+instance Semigroup SlurpComponent where
   c1 <> c2 =
     SlurpComponent
       { types = types c1 <> types c2,
@@ -43,36 +66,35 @@ instance Ord v => Semigroup (SlurpComponent v) where
         ctors = ctors c1 <> ctors c2
       }
 
-instance Ord v => Monoid (SlurpComponent v) where
-  mempty = SlurpComponent {types = mempty, terms = mempty, ctors = mempty}
+instance Monoid SlurpComponent where
+  mempty = empty
 
 -- I'm calling this `closeWithDependencies` because it doesn't just compute
 -- the dependencies of the inputs, it mixes them together.  Make sure this
 -- is what you want.
 closeWithDependencies ::
-  forall v a.
-  Ord v =>
-  TypecheckedUnisonFile v a ->
-  SlurpComponent v ->
-  SlurpComponent v
+  forall a.
+  TypecheckedUnisonFile Symbol a ->
+  SlurpComponent ->
+  SlurpComponent
 closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
   where
     seenDefns = foldl' termDeps (SlurpComponent {terms = mempty, types = seenTypes, ctors = mempty}) (terms inputs)
     seenTypes = foldl' typeDeps mempty (types inputs)
 
-    constructorDeps :: Set v
+    constructorDeps :: Set Symbol
     constructorDeps = UF.constructorsForDecls seenTypes uf
 
-    termDeps :: SlurpComponent v -> v -> SlurpComponent v
+    termDeps :: SlurpComponent -> Symbol -> SlurpComponent
     termDeps seen v | Set.member v (terms seen) = seen
     termDeps seen v = fromMaybe seen $ do
       term <- findTerm v
       let -- get the `v`s for the transitive dependency types
           -- (the ones for terms are just the `freeVars below`)
           -- although this isn't how you'd do it for a term that's already in codebase
-          tdeps :: [v]
+          tdeps :: [Symbol]
           tdeps = resolveTypes $ Term.dependencies term
-          seenTypes :: Set v
+          seenTypes :: Set Symbol
           seenTypes = foldl' typeDeps (types seen) tdeps
           seenTerms = Set.insert v (terms seen)
       pure $
@@ -85,7 +107,7 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
           )
           (Term.freeVars term)
 
-    typeDeps :: Set v -> v -> Set v
+    typeDeps :: Set Symbol -> Symbol -> Set Symbol
     typeDeps seen v | Set.member v seen = seen
     typeDeps seen v = fromMaybe seen $ do
       dd <-
@@ -93,25 +115,25 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
           <|> fmap (DD.toDataDecl . snd) (Map.lookup v (UF.effectDeclarations' uf))
       pure $ foldl' typeDeps (Set.insert v seen) (resolveTypes $ DD.dependencies dd)
 
-    resolveTypes :: Set Reference -> [v]
+    resolveTypes :: Set Reference -> [Symbol]
     resolveTypes rs = [v | r <- Set.toList rs, Just v <- [Map.lookup r typeNames]]
 
-    findTerm :: v -> Maybe (Term.Term v a)
+    findTerm :: Symbol -> Maybe (Term.Term Symbol a)
     findTerm v = Map.lookup v allTerms
 
     allTerms = UF.allTerms uf
 
-    typeNames :: Map Reference v
+    typeNames :: Map Reference Symbol
     typeNames = invert (fst <$> UF.dataDeclarations' uf) <> invert (fst <$> UF.effectDeclarations' uf)
 
     invert :: forall k v. Ord k => Ord v => Map k v -> Map v k
     invert m = Map.fromList (swap <$> Map.toList m)
 
-fromTypes :: Ord v => Set v -> SlurpComponent v
+fromTypes :: Set Symbol -> SlurpComponent
 fromTypes vs = mempty {types = vs}
 
-fromTerms :: Ord v => Set v -> SlurpComponent v
+fromTerms :: Set Symbol -> SlurpComponent
 fromTerms vs = mempty {terms = vs}
 
-fromCtors :: Ord v => Set v -> SlurpComponent v
+fromCtors :: Set Symbol -> SlurpComponent
 fromCtors vs = mempty {ctors = vs}

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

@@ -33,6 +33,7 @@ import Unison.Name (Name)
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
+import Unison.Symbol (Symbol)
 import qualified Unison.Syntax.DeclPrinter as DeclPrinter
 import qualified Unison.Syntax.TypePrinter as TP
 import qualified Unison.UnisonFile as UF
@@ -52,36 +53,36 @@ data Aliases
       }
   deriving (Show, Eq, Ord)
 
-data SlurpResult v = SlurpResult
+data SlurpResult = SlurpResult
   { -- The file that we tried to add from
-    originalFile :: UF.TypecheckedUnisonFile v Ann,
+    originalFile :: UF.TypecheckedUnisonFile Symbol Ann,
     -- Extra definitions that were added to satisfy transitive closure,
     -- beyond what the user specified.
-    extraDefinitions :: SlurpComponent v,
+    extraDefinitions :: SlurpComponent,
     -- Previously existed only in the file; now added to the codebase.
-    adds :: SlurpComponent v,
+    adds :: SlurpComponent,
     -- Exists in the branch and the file, with the same name and contents.
-    duplicates :: SlurpComponent v,
+    duplicates :: SlurpComponent,
     -- Not added to codebase due to the name already existing
     -- in the branch with a different definition.
     -- I.e. an update is required but we're performing an add.
-    collisions :: SlurpComponent v,
+    collisions :: SlurpComponent,
     -- Names that already exist in the branch, but whose definitions
     -- in `originalFile` are treated as updates.
-    updates :: SlurpComponent v,
+    updates :: SlurpComponent,
     -- Names of terms in `originalFile` that couldn't be updated because
     -- they refer to existing constructors. (User should instead do a find/replace,
     -- a constructor rename, or refactor the type that the name comes from).
-    termExistingConstructorCollisions :: Set v,
-    constructorExistingTermCollisions :: Set v,
+    termExistingConstructorCollisions :: Set Symbol,
+    constructorExistingTermCollisions :: Set Symbol,
     -- -- Already defined in the branch, but with a different name.
-    termAlias :: Map v Aliases,
-    typeAlias :: Map v Aliases,
-    defsWithBlockedDependencies :: SlurpComponent v
+    termAlias :: Map Symbol Aliases,
+    typeAlias :: Map Symbol Aliases,
+    defsWithBlockedDependencies :: SlurpComponent
   }
   deriving (Show)
 
-hasAddsOrUpdates :: Ord v => SlurpResult v -> Bool
+hasAddsOrUpdates :: SlurpResult -> Bool
 hasAddsOrUpdates s =
   -- We intentionally ignore constructors here since they are added as part of adding their
   -- types.
@@ -120,11 +121,9 @@ aliasesToShow :: Int
 aliasesToShow = 5
 
 pretty ::
-  forall v.
-  Var v =>
   IsPastTense ->
   PPE.PrettyPrintEnv ->
-  SlurpResult v ->
+  SlurpResult ->
   P.Pretty P.ColorText
 pretty isPast ppe sr =
   let tms = UF.hashTerms (originalFile sr)
@@ -190,7 +189,7 @@ pretty isPast ppe sr =
                 ++ (if null newNames then mempty else [newMessage])
 
       -- The second field in the result is an optional second column.
-      okTerm :: v -> [(P.Pretty P.ColorText, Maybe (P.Pretty P.ColorText))]
+      okTerm :: Symbol -> [(P.Pretty P.ColorText, Maybe (P.Pretty P.ColorText))]
       okTerm v = case Map.lookup v tms of
         Nothing ->
           [(P.bold (prettyVar v), Just $ P.red "(Unison bug, unknown term)")]
@@ -303,14 +302,14 @@ pretty isPast ppe sr =
             sr
         ]
 
-isOk :: Ord v => SlurpResult v -> Bool
+isOk :: SlurpResult -> Bool
 isOk SlurpResult {..} =
   SC.isEmpty collisions
     && Set.null termExistingConstructorCollisions
     && Set.null constructorExistingTermCollisions
     && SC.isEmpty defsWithBlockedDependencies
 
-isAllDuplicates :: Ord v => SlurpResult v -> Bool
+isAllDuplicates :: SlurpResult -> Bool
 isAllDuplicates SlurpResult {..} =
   emptyIgnoringConstructors adds
     && emptyIgnoringConstructors updates
@@ -322,15 +321,14 @@ isAllDuplicates SlurpResult {..} =
     && Set.null constructorExistingTermCollisions
     && emptyIgnoringConstructors defsWithBlockedDependencies
   where
-    emptyIgnoringConstructors :: SlurpComponent v -> Bool
+    emptyIgnoringConstructors :: SlurpComponent -> Bool
     emptyIgnoringConstructors SlurpComponent {types, terms} =
       null types && null terms
 
 filterUnisonFile ::
-  Ord v =>
-  SlurpResult v ->
-  UF.TypecheckedUnisonFile v Ann ->
-  UF.TypecheckedUnisonFile v Ann
+  SlurpResult ->
+  UF.TypecheckedUnisonFile Symbol Ann ->
+  UF.TypecheckedUnisonFile Symbol Ann
 filterUnisonFile
   SlurpResult {adds, updates}
   ( UF.TypecheckedUnisonFileId

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

@@ -5,9 +5,12 @@ module Unison.Codebase.Editor.UriParser
     writeGitRepo,
     deprecatedWriteGitRemotePath,
     writeRemotePath,
+    parseReadRemoteNamespace,
+    parseReadShareRemoteNamespace,
   )
 where
 
+import Data.Bifunctor (first)
 import Data.Char (isAlphaNum, isDigit, isSpace)
 import Data.Sequence as Seq
 import qualified Data.Text as Text
@@ -27,12 +30,14 @@ import Unison.Codebase.Editor.RemoteRepo
   )
 import Unison.Codebase.Path (Path (..))
 import qualified Unison.Codebase.Path as Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
+import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
 import qualified Unison.Hash as Hash
 import Unison.NameSegment (NameSegment (..))
 import qualified Unison.NameSegment as NameSegment
 import Unison.Prelude
 import qualified Unison.Syntax.Lexer
+import qualified Unison.Util.Pretty as P
+import qualified Unison.Util.Pretty.MegaParsec as P
 
 type P = P.Parsec Void Text.Text
 
@@ -60,6 +65,16 @@ repoPath =
     fmap ReadRemoteNamespaceGit readGitRemoteNamespace
       <|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace
 
+parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
+parseReadRemoteNamespace label input =
+  let printError err = P.lines [P.string "I couldn't parse the repository address given above.", P.prettyPrintParseError input err]
+   in first printError (P.parse repoPath label (Text.pack input))
+
+parseReadShareRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadShareRemoteNamespace
+parseReadShareRemoteNamespace label input =
+  let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err]
+   in first printError (P.parse readShareRemoteNamespace label (Text.pack input))
+
 -- >>> P.parseMaybe writeRemotePath "unisonweb.base._releases.M4"
 -- >>> P.parseMaybe writeRemotePath "git(git@github.com:unisonweb/base:v3)._releases.M3"
 -- Just (WriteRemotePathShare (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
@@ -88,7 +103,7 @@ readShareRemoteNamespace = do
   P.label "read share remote namespace" $
     ReadShareRemoteNamespace
       <$> pure DefaultCodeserver
-      -- <*> sbh <- P.optional shortBranchHash
+      -- <*> sch <- P.optional shortBranchHash
       <*> (NameSegment.toText <$> nameSegment)
       <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
 
@@ -97,11 +112,11 @@ readShareRemoteNamespace = do
 -- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)"
 -- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
 -- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar"
--- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
--- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
--- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = })
--- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3})
--- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar})
+-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
+-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
+-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = })
+-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3})
+-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar})
 readGitRemoteNamespace :: P ReadGitRemoteNamespace
 readGitRemoteNamespace = P.label "generic git repo" $ do
   C.string "git("
@@ -111,8 +126,8 @@ readGitRemoteNamespace = P.label "generic git repo" $ do
   C.string ")"
   nshashPath <- P.optional namespaceHashPath
   pure case nshashPath of
-    Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty}
-    Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path}
+    Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty}
+    Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path}
 
 -- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)"
 -- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)"
@@ -321,11 +336,11 @@ parseGitProtocol =
 --
 -- >>> P.parseMaybe namespaceHashPath "."
 -- Just (Nothing,)
-namespaceHashPath :: P (Maybe ShortBranchHash, Path)
+namespaceHashPath :: P (Maybe ShortCausalHash, Path)
 namespaceHashPath = do
-  sbh <- P.optional shortBranchHash
+  sch <- P.optional shortCausalHash
   p <- P.optional absolutePath
-  pure (sbh, fromMaybe Path.empty p)
+  pure (sch, fromMaybe Path.empty p)
 
 -- >>> P.parseMaybe absolutePath "."
 -- Just
@@ -349,8 +364,8 @@ gitTreeishSuffix = P.label "git treeish" . P.try $ do
   void $ C.char ':'
   P.takeWhile1P (Just "not close paren") (/= ')')
 
-shortBranchHash :: P ShortBranchHash
-shortBranchHash = P.label "short branch hash" $ do
+shortCausalHash :: P ShortCausalHash
+shortCausalHash = P.label "short causal hash" $ do
   void $ C.char '#'
-  ShortBranchHash
+  ShortCausalHash
     <$> P.takeWhile1P (Just "base32hex chars") (`elem` Hash.validBase32HexChars)

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

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Unison.CommandLine.DisplayValues where
@@ -329,7 +328,7 @@ displayDoc pped terms typeOf evaluated types = go
         let ppe = PPE.declarationPPE pped ref
          in terms ref >>= \case
               Nothing -> pure $ "😶  Missing term source for: " <> termName ppe r
-              Just tm -> pure . P.syntaxToColor $ P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
+              Just tm -> pure . P.syntaxToColor . P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
       Referent.Con (ConstructorReference r _) _ -> prettyType r
     prettyType r =
       let ppe = PPE.declarationPPE pped r

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

@@ -11,7 +11,6 @@ import qualified Data.Map as Map
 import Data.Proxy (Proxy (..))
 import qualified Data.Set as Set
 import qualified Data.Text as Text
-import Data.Void (Void)
 import System.Console.Haskeline.Completion (Completion (Completion))
 import qualified Text.Megaparsec as P
 import qualified Unison.Codebase.Branch as Branch
@@ -20,8 +19,9 @@ import Unison.Codebase.Editor.Input (Input)
 import qualified Unison.Codebase.Editor.Input as Input
 import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
 import qualified Unison.Codebase.Editor.Output.PushPull as PushPull
-import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath)
+import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemotePath)
 import qualified Unison.Codebase.Editor.SlurpResult as SR
+import Unison.Codebase.Editor.UriParser (parseReadRemoteNamespace)
 import qualified Unison.Codebase.Editor.UriParser as UriParser
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.Path.Parse as Path
@@ -1358,46 +1358,6 @@ loadPullRequest =
         _ -> Left (I.help loadPullRequest)
     )
 
-parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
-parseReadRemoteNamespace label input =
-  let printError err = P.lines [P.string "I couldn't parse the repository address given above.", prettyPrintParseError input err]
-   in first printError (P.parse UriParser.repoPath label (Text.pack input))
-
-prettyPrintParseError :: String -> P.ParseErrorBundle Text Void -> P.Pretty P.ColorText
-prettyPrintParseError input errBundle =
-  let (firstError, sp) = NE.head . fst $ P.attachSourcePos P.errorOffset (P.bundleErrors errBundle) (P.bundlePosState errBundle)
-   in case firstError of
-        P.TrivialError _errorOffset ue ee ->
-          P.lines
-            [ printLocation sp,
-              P.newline,
-              printTrivial ue ee
-            ]
-        P.FancyError _errorOffset ee ->
-          let errors = foldMap (P.string . mappend "\n" . showErrorFancy) ee
-           in P.lines
-                [ printLocation sp,
-                  errors
-                ]
-  where
-    printLocation :: P.SourcePos -> P.Pretty P.ColorText
-    printLocation sp =
-      let col = (P.unPos $ P.sourceColumn sp) - 1
-          row = (P.unPos $ P.sourceLine sp) - 1
-          errorLine = lines input !! row
-       in P.lines
-            [ P.newline,
-              P.string errorLine,
-              P.string $ replicate col ' ' <> "^-- This is where I gave up."
-            ]
-
-    printTrivial :: (Maybe (P.ErrorItem Char)) -> (Set (P.ErrorItem Char)) -> P.Pretty P.ColorText
-    printTrivial ue ee =
-      let expected = "I expected " <> foldMap (P.singleQuoted . P.string . showErrorItem) ee
-          found = P.string . mappend "I found " . showErrorItem <$> ue
-          message = [expected] <> catMaybes [found]
-       in P.oxfordCommasWith "." message
-
 parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
 parseWriteGitRepo label input = do
   first
@@ -2005,6 +1965,24 @@ debugDoctor =
         _ -> Left (showPatternHelp debugDoctor)
     )
 
+debugNameDiff :: InputPattern
+debugNameDiff =
+  InputPattern
+    { patternName = "debug.name-diff",
+      aliases = [],
+      visibility = I.Hidden,
+      argTypes = [(Required, namespaceArg), (Required, namespaceArg)],
+      help = P.wrap "List all name changes between two causal hashes. Does not detect patch or metadata changes.",
+      parse =
+        ( \case
+            [from, to] -> first fromString $ do
+              fromSCH <- Input.parseShortCausalHash from
+              toSCH <- Input.parseShortCausalHash to
+              pure $ Input.DebugNameDiffI fromSCH toSCH
+            _ -> Left (I.help debugNameDiff)
+        )
+    }
+
 test :: InputPattern
 test =
   InputPattern
@@ -2412,6 +2390,7 @@ validInputs =
       debugClearWatchCache,
       debugDoctor,
       debugTabCompletion,
+      debugNameDiff,
       gist,
       authLogin,
       printVersion

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

@@ -37,6 +37,7 @@ import Unison.CommandLine
 import Unison.CommandLine.Completion (haskelineTabComplete)
 import qualified Unison.CommandLine.InputPatterns as IP
 import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
+import Unison.CommandLine.Types (ShouldWatchFiles (..))
 import qualified Unison.CommandLine.Welcome as Welcome
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
@@ -103,8 +104,9 @@ main ::
   UCMVersion ->
   (Branch IO -> STM ()) ->
   (Path.Absolute -> STM ()) ->
+  ShouldWatchFiles ->
   IO ()
-main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange = Ki.scoped \scope -> do
+main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do
   rootVar <- newEmptyTMVarIO
   initialRootCausalHash <- Codebase.getRootCausalHash codebase
   _ <- Ki.fork scope $ do
@@ -134,7 +136,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRunt
   welcomeEvents <- Welcome.run codebase welcome
   initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs
   pageOutput <- newIORef True
-  cancelFileSystemWatch <- watchFileSystem eventQueue dir
+  cancelFileSystemWatch <- case shouldWatchFiles of
+    ShouldNotWatchFiles -> pure (pure ())
+    ShouldWatchFiles -> watchFileSystem eventQueue dir
   credentialManager <- newCredentialManager
   let tokenProvider = AuthN.newTokenProvider credentialManager
   authHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion

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

@@ -37,6 +37,7 @@ import System.Directory
     getHomeDirectory,
   )
 import U.Codebase.Branch (NamespaceStats (..))
+import U.Codebase.Branch.Diff (NameChanges (..))
 import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
 import U.Util.Base32Hex (Base32Hex)
 import qualified U.Util.Base32Hex as Base32Hex
@@ -72,8 +73,9 @@ import qualified Unison.Codebase.Patch as Patch
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.PushBehavior as PushBehavior
 import qualified Unison.Codebase.Runtime as Runtime
-import Unison.Codebase.ShortBranchHash (ShortBranchHash)
-import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.ShortCausalHash (ShortCausalHash)
+import qualified Unison.Codebase.ShortCausalHash as SCH
+import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
 import Unison.Codebase.SqliteCodebase.GitError
   ( GitSqliteCodebaseError (..),
   )
@@ -84,6 +86,7 @@ import Unison.CommandLine (bigproblem, note, tip)
 import Unison.CommandLine.InputPatterns (makeExample')
 import qualified Unison.CommandLine.InputPatterns as IP
 import Unison.ConstructorReference (GConstructorReference (..))
+import qualified Unison.ConstructorType as CT
 import qualified Unison.DataDeclaration as DD
 import qualified Unison.Hash as Hash
 import qualified Unison.HashQualified as HQ
@@ -296,21 +299,20 @@ notifyNumbered o = case o of
       else
         first
           ( \p ->
-              ( P.lines
-                  [ P.wrap $
-                      "The changes summarized below are available for you to review,"
-                        <> "using the following command:",
-                    "",
-                    P.indentN 2 $
-                      IP.makeExampleNoBackticks
-                        IP.loadPullRequest
-                        [ (prettyReadRemoteNamespace baseRepo),
-                          (prettyReadRemoteNamespace headRepo)
-                        ],
-                    "",
-                    p
-                  ]
-              )
+              P.lines
+                [ P.wrap $
+                    "The changes summarized below are available for you to review,"
+                      <> "using the following command:",
+                  "",
+                  P.indentN 2 $
+                    IP.makeExampleNoBackticks
+                      IP.loadPullRequest
+                      [ prettyReadRemoteNamespace baseRepo,
+                        prettyReadRemoteNamespace headRepo
+                      ],
+                  "",
+                  p
+                ]
           )
           (showDiffNamespace HideNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
   -- todo: these numbers aren't going to work,
@@ -352,14 +354,14 @@ notifyNumbered o = case o of
           ],
       numberedArgsForEndangerments ppeDecl endangerments
     )
-  History _cap sbhLength history tail ->
+  History _cap schLength history tail ->
     let (tailMsg, tailHashes) = handleTail (length history + 1)
         msg :: Pretty
         msg =
           P.lines
             [ note $ "The most recent namespace hash is immediately below this message.",
               "",
-              P.sep "\n\n" [go i (toSBH h) diff | (i, (h, diff)) <- zip [1 ..] reversedHistory],
+              P.sep "\n\n" [go i (toSCH h) diff | (i, (h, diff)) <- zip [1 ..] reversedHistory],
               "",
               tailMsg
             ]
@@ -367,8 +369,8 @@ notifyNumbered o = case o of
         branchHashes = (fst <$> reversedHistory) <> tailHashes
      in (msg, displayBranchHash <$> branchHashes)
     where
-      toSBH :: Branch.CausalHash -> ShortBranchHash
-      toSBH h = SBH.fromHash sbhLength h
+      toSCH :: Branch.CausalHash -> ShortCausalHash
+      toSCH h = SCH.fromHash schLength h
       reversedHistory = reverse history
       showNum :: Int -> Pretty
       showNum n = P.shown n <> ". "
@@ -376,7 +378,7 @@ notifyNumbered o = case o of
       handleTail n = case tail of
         E.EndOfLog h ->
           ( P.lines
-              [ "□ " <> showNum n <> prettySBH (toSBH h) <> " (start of history)"
+              [ "□ " <> showNum n <> prettySCH (toSCH h) <> " (start of history)"
               ],
             [h]
           )
@@ -384,9 +386,9 @@ notifyNumbered o = case o of
           ( P.lines
               [ P.wrap $ "This segment of history starts with a merge." <> ex,
                 "",
-                "⊙ " <> showNum n <> prettySBH (toSBH h),
+                "⊙ " <> showNum n <> prettySCH (toSCH h),
                 "⑃",
-                P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySBH (toSBH h))
+                P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySCH (toSCH h))
               ],
             h : hs
           )
@@ -396,15 +398,15 @@ notifyNumbered o = case o of
                 "",
                 dots,
                 "",
-                "⊙ " <> showNum n <> prettySBH (toSBH h),
+                "⊙ " <> showNum n <> prettySCH (toSCH h),
                 ""
               ],
             [h]
           )
       dots = "⠇"
-      go i sbh diff =
+      go i sch diff =
         P.lines
-          [ "⊙ " <> showNum i <> prettySBH sbh,
+          [ "⊙ " <> showNum i <> prettySCH sch,
             "",
             P.indentN 2 $ prettyDiff diff
           ]
@@ -594,13 +596,13 @@ notifyUser dir o = case o of
                   <> P.group (P.plural hashes "hash" <> ":"),
               "",
               (P.indentN 2 . P.oxfordCommas)
-                (map prettySBH $ toList hashes),
+                (map prettySCH $ toList hashes),
               "",
               P.wrap $
                 "and I'm not sure what to do about it."
                   <> "The last root namespace hash that I knew about was:",
               "",
-              P.indentN 2 $ prettySBH current,
+              P.indentN 2 $ prettySCH current,
               "",
               P.wrap $ "Now might be a good time to make a backup of your codebase. 😬",
               "",
@@ -663,8 +665,8 @@ notifyUser dir o = case o of
     CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run."
     CachedTests n n'
       | n == n' ->
-          pure $
-            P.lines [cache, "", displayTestResults True ppe oks fails]
+        pure $
+          P.lines [cache, "", displayTestResults True ppe oks fails]
     CachedTests _n m ->
       pure $
         if m == 0
@@ -673,7 +675,6 @@ notifyUser dir o = case o of
             P.indentN 2 $
               P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅  "]
       where
-
     NewlyComputed -> do
       clearCurrentLine
       pure $
@@ -687,7 +688,7 @@ notifyUser dir o = case o of
   TestIncrementalOutputStart ppe (n, total) r _src -> do
     putPretty' $
       P.shown (total - n) <> " tests left to run, current test: "
-        <> (P.syntaxToColor $ prettyHashQualified (PPE.termName ppe $ Referent.Ref r))
+        <> P.syntaxToColor (prettyHashQualified (PPE.termName ppe $ Referent.Ref r))
     pure mempty
   TestIncrementalOutputEnd _ppe (_n, _total) _r result -> do
     clearCurrentLine
@@ -1037,7 +1038,7 @@ notifyUser dir o = case o of
               P.bracket . P.lines $
                 P.wrap "The watch expression(s) reference these definitions:" :
                 "" :
-                  [ (P.syntaxToColor $ TermPrinter.prettyBinding ppe (HQ.unsafeFromVar v) b)
+                  [ P.syntaxToColor $ TermPrinter.prettyBinding ppe (HQ.unsafeFromVar v) b
                     | (v, b) <- bindings
                   ]
             prettyWatches =
@@ -1235,15 +1236,15 @@ notifyUser dir o = case o of
             <> P.shown path
             <> "in the repository at"
             <> prettyReadGitRepo repo
-      NoRemoteNamespaceWithHash repo sbh ->
+      NoRemoteNamespaceWithHash repo sch ->
         P.wrap $
           "The repository at" <> prettyReadGitRepo repo
             <> "doesn't contain a namespace with the hash prefix"
-            <> (P.blue . P.text . SBH.toText) sbh
-      RemoteNamespaceHashAmbiguous repo sbh hashes ->
+            <> (P.blue . P.text . SCH.toText) sch
+      RemoteNamespaceHashAmbiguous repo sch hashes ->
         P.lines
           [ P.wrap $
-              "The namespace hash" <> prettySBH sbh
+              "The namespace hash" <> prettySCH sch
                 <> "at"
                 <> prettyReadGitRepo repo
                 <> "is ambiguous."
@@ -1251,7 +1252,7 @@ notifyUser dir o = case o of
             "",
             P.indentN 2 $
               P.lines
-                ( prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2)
+                ( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2)
                     <$> Set.toList hashes
                 ),
             "",
@@ -1402,10 +1403,10 @@ notifyUser dir o = case o of
   BranchHashAmbiguous h rs ->
     pure . P.callout "\129300" . P.lines $
       [ P.wrap $
-          "The namespace hash" <> prettySBH h <> "is ambiguous."
+          "The namespace hash" <> prettySCH h <> "is ambiguous."
             <> "Did you mean one of these hashes?",
         "",
-        P.indentN 2 $ P.lines (prettySBH <$> Set.toList rs),
+        P.indentN 2 $ P.lines (prettySCH <$> Set.toList rs),
         "",
         P.wrap "Try again with a few more hash characters to disambiguate."
       ]
@@ -1444,7 +1445,7 @@ notifyUser dir o = case o of
     where
       header =
         case entries of
-          (_head : (_, prevSBH, _) : _) ->
+          (_head : (_, prevSCH, _) : _) ->
             P.lines
               [ P.wrap $
                   "Here is a log of the root namespace hashes,"
@@ -1456,11 +1457,11 @@ notifyUser dir o = case o of
                     [ ( IP.makeExample IP.forkLocal ["2", ".old"],
                         ""
                       ),
-                      ( IP.makeExample IP.forkLocal [prettySBH prevSBH, ".old"],
+                      ( IP.makeExample IP.forkLocal [prettySCH prevSCH, ".old"],
                         "to make an old namespace accessible again,"
                       ),
                       (mempty, mempty),
-                      ( IP.makeExample IP.resetRoot [prettySBH prevSBH],
+                      ( IP.makeExample IP.resetRoot [prettySCH prevSCH],
                         "to reset the root namespace and its history to that of the specified"
                           <> "namespace."
                       )
@@ -1469,9 +1470,9 @@ notifyUser dir o = case o of
                 ""
               ]
           _ -> mempty
-      renderEntry3Column :: UTCTime -> (Maybe UTCTime, SBH.ShortBranchHash, Text) -> [Pretty]
-      renderEntry3Column now (mayTime, sbh, reason) =
-        [maybe "" (prettyHumanReadableTime now) mayTime, P.blue (prettySBH sbh), P.text $ truncateReason reason]
+      renderEntry3Column :: UTCTime -> (Maybe UTCTime, SCH.ShortCausalHash, Text) -> [Pretty]
+      renderEntry3Column now (mayTime, sch, reason) =
+        [maybe "" (prettyHumanReadableTime now) mayTime, P.blue (prettySCH sch), P.text $ truncateReason reason]
       truncateReason :: Text -> Text
       truncateReason txt = case Text.splitAt 60 txt of
         (short, "") -> short
@@ -1805,6 +1806,20 @@ notifyUser dir o = case o of
   IntegrityCheck result -> pure $ case result of
     NoIntegrityErrors -> "🎉 No issues detected 🎉"
     IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
+  DisplayDebugNameDiff NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} -> do
+    let referentText =
+          -- We don't use the constructor type in the actual output here, so there's no
+          -- point in looking up the correct one.
+          P.text . Referent.toText . runIdentity . Cv.referent2to1 (\_ref -> Identity CT.Data)
+    let referenceText = P.text . Reference.toText . Cv.reference2to1
+    pure $
+      P.columnNHeader
+        ["Kind", "Name", "Change", "Ref"]
+        ( (termNameAdds <&> \(n, ref) -> ["Term", prettyName n, "Added", referentText ref])
+            <> (termNameRemovals <&> \(n, ref) -> ["Term", prettyName n, "Removed", referentText ref])
+            <> (typeNameAdds <&> \(n, ref) -> ["Type", prettyName n, "Added", referenceText ref])
+            <> (typeNameRemovals <&> \(n, ref) -> ["Type", prettyName n, "Removed", referenceText ref])
+        )
   DisplayDebugCompletions completions ->
     pure $
       P.column2
@@ -1890,7 +1905,7 @@ prettyPath' p' =
 
 prettyBranchId :: Input.AbsBranchId -> Pretty
 prettyBranchId = \case
-  Left sbh -> prettySBH sbh
+  Left sch -> prettySCH sch
   Right absPath -> prettyAbsolute $ absPath
 
 prettyRelative :: Path.Relative -> Pretty
@@ -1899,8 +1914,8 @@ prettyRelative = P.blue . P.shown
 prettyAbsolute :: Path.Absolute -> Pretty
 prettyAbsolute = P.blue . P.shown
 
-prettySBH :: IsString s => ShortBranchHash -> P.Pretty s
-prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash)
+prettySCH :: IsString s => ShortCausalHash -> P.Pretty s
+prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
 
 prettyCausalHash :: IsString s => Causal.CausalHash -> P.Pretty s
 prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unCausalHash $ hash)
@@ -2062,9 +2077,10 @@ displayDefinitions outputLoc ppe types terms =
           case dt of
             MissingObject r -> missing n r
             BuiltinObject typ ->
-              P.hang
-                ("builtin " <> prettyHashQualified n <> " :")
-                (TypePrinter.prettySyntax (ppeBody n r) typ)
+              (if isJust outputLoc then P.indent "-- " else id) $
+                P.hang
+                  ("builtin " <> prettyHashQualified n <> " :")
+                  (TypePrinter.prettySyntax (ppeBody n r) typ)
             UserObject tm -> TermPrinter.prettyBinding (ppeBody n r) n tm
         go2 ((n, r), dt) =
           case dt of
@@ -2149,7 +2165,7 @@ unsafePrettyTermResultSigFull' ppe = \case
       [ P.hiBlack "-- " <> greyHash (HQ.fromReferent r),
         P.group $
           P.commas (fmap greyHash $ hq : map HQ'.toHQ (toList aliases)) <> " : "
-            <> (P.syntaxToColor $ TypePrinter.pretty0 ppe mempty (-1) typ),
+            <> P.syntaxToColor (TypePrinter.prettySyntax ppe typ),
         mempty
       ]
   _ -> error "Don't pass Nothing"
@@ -2447,7 +2463,7 @@ showDiffNamespace ::
   (Pretty, NumberedArgs)
 showDiffNamespace _ _ _ _ diffOutput
   | OBD.isEmpty diffOutput =
-      ("The namespaces are identical.", mempty)
+    ("The namespaces are identical.", mempty)
 showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
   (P.sepNonEmpty "\n\n" p, toList args)
   where
@@ -2847,7 +2863,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
     -- prefixBranchId ".base" "List.map" -> ".base.List.map"
     prefixBranchId :: Input.AbsBranchId -> Name -> String
     prefixBranchId branchId name = case branchId of
-      Left sbh -> "#" <> SBH.toString sbh <> ":" <> Name.toString (Name.makeAbsolute name)
+      Left sch -> "#" <> SCH.toString sch <> ":" <> Name.toString (Name.makeAbsolute name)
       Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name)
 
     addNumberedArg' :: String -> Numbered Pretty

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

@@ -0,0 +1,6 @@
+module Unison.CommandLine.Types (ShouldWatchFiles (..)) where
+
+data ShouldWatchFiles
+  = ShouldWatchFiles
+  | ShouldNotWatchFiles
+  deriving (Show, Eq)

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

@@ -12,6 +12,7 @@ import Unison.Codebase.Path (Path)
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.SyncMode as SyncMode
 import qualified Unison.Codebase.Verbosity as Verbosity
+import Unison.CommandLine.Types (ShouldWatchFiles (..))
 import Unison.NameSegment (NameSegment (NameSegment))
 import Unison.Prelude
 import qualified Unison.Util.Pretty as P
@@ -21,7 +22,8 @@ data Welcome = Welcome
   { onboarding :: Onboarding, -- Onboarding States
     downloadBase :: DownloadBase,
     watchDir :: FilePath,
-    unisonVersion :: Text
+    unisonVersion :: Text,
+    shouldWatchFiles :: ShouldWatchFiles
   }
 
 data DownloadBase
@@ -47,9 +49,9 @@ data Onboarding
   | PreviouslyOnboarded
   deriving (Show, Eq)
 
-welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome
-welcome initStatus downloadBase filePath unisonVersion =
-  Welcome (Init initStatus) downloadBase filePath unisonVersion
+welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> ShouldWatchFiles -> Welcome
+welcome initStatus downloadBase filePath unisonVersion shouldWatchFiles =
+  Welcome (Init initStatus) downloadBase filePath unisonVersion shouldWatchFiles
 
 pullBase :: ReadShareRemoteNamespace -> Either Event Input
 pullBase ns =
@@ -66,7 +68,7 @@ pullBase ns =
    in Right pullRemote
 
 run :: Codebase IO v a -> Welcome -> IO [Either Event Input]
-run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version} = do
+run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version, shouldWatchFiles} = do
   go onboarding []
   where
     go :: Onboarding -> [Either Event Input] -> IO [Either Event Input]
@@ -91,10 +93,10 @@ run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watc
             authorMsg = toInput authorSuggestion
         -- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards
         Finished -> do
-          startMsg <- getStarted dir
+          startMsg <- getStarted shouldWatchFiles dir
           pure $ reverse (toInput startMsg : acc)
         PreviouslyOnboarded -> do
-          startMsg <- getStarted dir
+          startMsg <- getStarted shouldWatchFiles dir
           pure $ reverse (toInput startMsg : acc)
 
 toInput :: P.Pretty P.ColorText -> Either Event Input
@@ -107,7 +109,7 @@ determineFirstStep downloadBase codebase = do
   case downloadBase of
     DownloadBase ns
       | isEmptyCodebase ->
-        pure $ DownloadingBase ns
+          pure $ DownloadingBase ns
     _ ->
       pure PreviouslyOnboarded
 
@@ -170,8 +172,8 @@ authorSuggestion =
         P.wrap $ P.blue "https://www.unison-lang.org/learn/tooling/configuration/"
       ]
 
-getStarted :: FilePath -> IO (P.Pretty P.ColorText)
-getStarted dir = do
+getStarted :: ShouldWatchFiles -> FilePath -> IO (P.Pretty P.ColorText)
+getStarted shouldWatchFiles dir = do
   earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2)
 
   pure $
@@ -179,10 +181,13 @@ getStarted dir = do
       [ P.wrap "Get started:",
         P.indentN 2 $
           P.column2
-            [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help <cmd>" <> " to view help for one command"),
-              ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"),
-              ("📚", "Read the official docs at " <> P.blue "https://www.unison-lang.org/learn/"),
-              (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"),
-              ("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir))
-            ]
+            ( [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help <cmd>" <> " to view help for one command"),
+                ("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"),
+                ("📚", "Read the official docs at " <> P.blue "https://www.unison-lang.org/learn/"),
+                (earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries")
+              ]
+                <> case shouldWatchFiles of
+                  ShouldWatchFiles -> [("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir))]
+                  ShouldNotWatchFiles -> [("📝", "File watching is disabled, use the 'load' command to parse and typecheck unison files.")]
+            )
       ]

unison-cli/src/Unison/LSP.hs

@@ -8,7 +8,6 @@ module Unison.LSP where
 import Colog.Core (LogAction (LogAction))
 import qualified Colog.Core as Colog
 import Control.Monad.Reader
-import Data.Aeson hiding (Options, defaultOptions)
 import GHC.IO.Exception (ioe_errno)
 import qualified Ki
 import qualified Language.LSP.Logging as LSP
@@ -27,6 +26,8 @@ import Unison.Codebase.Runtime (Runtime)
 import qualified Unison.Debug as Debug
 import Unison.LSP.CancelRequest (cancelRequestHandler)
 import Unison.LSP.CodeAction (codeActionHandler)
+import Unison.LSP.Completion (completionHandler)
+import qualified Unison.LSP.Configuration as Config
 import qualified Unison.LSP.FileAnalysis as Analysis
 import Unison.LSP.FoldingRange (foldingRangeRequest)
 import qualified Unison.LSP.HandlerUtils as Handlers
@@ -65,7 +66,7 @@ spawnLsp codebase runtime latestBranch latestPath = TCP.withSocketsDo do
       case Errno <$> ioe_errno ioerr of
         Just errNo
           | errNo == eADDRINUSE -> do
-            putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
+              putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
         _ -> do
           Debug.debugM Debug.LSP "LSP Exception" ioerr
           Debug.debugM Debug.LSP "LSP Errno" (ioe_errno ioerr)
@@ -85,21 +86,14 @@ serverDefinition ::
   ServerDefinition Config
 serverDefinition vfsVar codebase runtime scope latestBranch latestPath =
   ServerDefinition
-    { defaultConfig = lspDefaultConfig,
-      onConfigurationChange = lspOnConfigurationChange,
+    { defaultConfig = defaultLSPConfig,
+      onConfigurationChange = Config.updateConfig,
       doInitialize = lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath,
       staticHandlers = lspStaticHandlers,
       interpretHandler = lspInterpretHandler,
       options = lspOptions
     }
 
--- | Detect user LSP configuration changes.
-lspOnConfigurationChange :: Config -> Value -> Either Text Config
-lspOnConfigurationChange _ _ = pure Config
-
-lspDefaultConfig :: Config
-lspDefaultConfig = Config
-
 -- | Initialize any context needed by the LSP server
 lspDoInitialize ::
   MVar VFS ->
@@ -120,6 +114,7 @@ lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath lspContext
   parseNamesCacheVar <- newTVarIO mempty
   currentPathCacheVar <- newTVarIO Path.absoluteEmpty
   cancellationMapVar <- newTVarIO mempty
+  completionsVar <- newTVarIO mempty
   let env = Env {ppeCache = readTVarIO ppeCacheVar, parseNamesCache = readTVarIO parseNamesCacheVar, currentPathCache = readTVarIO currentPathCacheVar, ..}
   let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM
   Ki.fork scope (lspToIO Analysis.fileAnalysisWorker)
@@ -141,6 +136,7 @@ lspRequestHandlers =
     & SMM.insert STextDocumentHover (mkHandler hoverHandler)
     & SMM.insert STextDocumentCodeAction (mkHandler codeActionHandler)
     & SMM.insert STextDocumentFoldingRange (mkHandler foldingRangeRequest)
+    & SMM.insert STextDocumentCompletion (mkHandler completionHandler)
   where
     defaultTimeout = 10_000 -- 10s
     mkHandler ::
@@ -167,6 +163,7 @@ lspNotificationHandlers =
     & SMM.insert STextDocumentDidChange (ClientMessageHandler VFS.lspChangeFile)
     & SMM.insert SInitialized (ClientMessageHandler Notifications.initializedHandler)
     & SMM.insert SCancelRequest (ClientMessageHandler $ Notifications.withDebugging cancelRequestHandler)
+    & SMM.insert SWorkspaceDidChangeConfiguration (ClientMessageHandler Config.workspaceConfigurationChanged)
 
 -- | A natural transformation into IO, required by the LSP lib.
 lspInterpretHandler :: Env -> Lsp <~> IO

unison-cli/src/Unison/LSP/Completion.hs

@@ -4,122 +4,238 @@
 
 module Unison.LSP.Completion where
 
-import Control.Lens hiding (List)
+import Control.Comonad.Cofree
+import Control.Lens hiding (List, (:<))
 import Control.Monad.Reader
-import Data.String.Here.Uninterpolated (here)
+import Data.Bifunctor (second)
+import Data.List.Extra (nubOrdOn)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.Text as Text
 import Language.LSP.Types
 import Language.LSP.Types.Lens
-import qualified Text.FuzzyFind as Fuzzy
+import Unison.Codebase.Path (Path)
+import qualified Unison.Codebase.Path as Path
 import qualified Unison.HashQualified' as HQ'
 import Unison.LSP.Types
 import qualified Unison.LSP.VFS as VFS
+import Unison.LabeledDependency (LabeledDependency)
+import qualified Unison.LabeledDependency as LD
+import Unison.Name (Name)
+import qualified Unison.Name as Name
+import Unison.NameSegment (NameSegment (..))
+import qualified Unison.NameSegment as NameSegment
+import Unison.Names (Names (..))
 import Unison.Prelude
-import qualified Unison.Server.Endpoints.FuzzyFind as FZF
-import qualified Unison.Server.Syntax as Server
-import qualified Unison.Server.Types as Backend
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.PrettyPrintEnvDecl as PPED
+import qualified Unison.Referent as Referent
+import qualified Unison.Util.Monoid as Monoid
+import qualified Unison.Util.Relation as Relation
 
--- | Rudimentary auto-completion handler
---
--- TODO:
--- * Rewrite this to use an index rather than fuzzy searching ALL names
--- * Respect ucm's current path
--- * Provide namespaces as auto-complete targets
--- * Auto-complete minimally suffixed names
--- * Include docs in completion details?
 completionHandler :: RequestMessage 'TextDocumentCompletion -> (Either ResponseError (ResponseResult 'TextDocumentCompletion) -> Lsp ()) -> Lsp ()
 completionHandler m respond =
-  respond =<< do
-    mayPrefix <- VFS.completionPrefix (m ^. params)
-    case mayPrefix of
-      Nothing -> pure . Right . InL . List $ []
-      Just (range, prefix) -> do
-        matches <- expand range prefix
-        let isIncomplete = True -- TODO: be smarter about this
-        pure . Right . InR . CompletionList isIncomplete . List $ snippetCompletions prefix range <> matches
+  respond . maybe (Right $ InL mempty) (Right . InR) =<< runMaybeT do
+    (range, prefix) <- MaybeT $ VFS.completionPrefix (m ^. params)
+    ppe <- PPED.suffixifiedPPE <$> lift globalPPE
+    completions <- lift getCompletions
+    Config {maxCompletions} <- lift getConfig
+    let defMatches = matchCompletions completions prefix
+    let (isIncomplete, defCompletions) =
+          defMatches
+            & nubOrdOn (\(p, _name, ref) -> (p, ref))
+            & fmap (over _1 Path.toText)
+            & case maxCompletions of
+              Nothing -> (False,)
+              Just n -> takeCompletions n
+    let defCompletionItems =
+          defCompletions
+            & mapMaybe \(path, fqn, dep) ->
+              let biasedPPE = PPE.biasTo [fqn] ppe
+                  hqName = LD.fold (PPE.types biasedPPE) (PPE.terms biasedPPE) dep
+               in hqName <&> \hqName -> mkDefCompletionItem range (Name.toText fqn) path (HQ'.toText hqName) dep
+    pure . CompletionList isIncomplete . List $ defCompletionItems
   where
-    resultToCompletion :: Range -> Text -> FZF.FoundResult -> CompletionItem
-    resultToCompletion range prefix = \case
-      FZF.FoundTermResult (FZF.FoundTerm {namedTerm = Backend.NamedTerm {termName, termType}}) -> do
-        (mkCompletionItem (HQ'.toText termName))
-          { _detail = (": " <>) . Text.pack . Server.toPlain <$> termType,
-            _kind = Just CiVariable,
-            _insertText = Text.stripPrefix prefix (HQ'.toText termName),
-            _textEdit = Just $ CompletionEditText (TextEdit range (HQ'.toText termName))
-          }
-      FZF.FoundTypeResult (FZF.FoundType {namedType = Backend.NamedType {typeName, typeTag}}) ->
-        let (detail, kind) = case typeTag of
-              Backend.Ability -> ("Ability", CiInterface)
-              Backend.Data -> ("Data", CiClass)
-         in (mkCompletionItem (HQ'.toText typeName))
-              { _detail = Just detail,
-                _kind = Just kind
-              }
-    expand :: Range -> Text -> Lsp [CompletionItem]
-    expand range prefix = do
-      -- We should probably write a different fzf specifically for completion, but for now, it
-      -- expects the unique pieces of the query to be different "words".
-      let query = Text.unwords . Text.splitOn "." $ prefix
-      cb <- asks codebase
-      lspBackend (FZF.serveFuzzyFind cb Nothing Nothing Nothing Nothing (Just $ Text.unpack query)) >>= \case
-        Left _be -> pure []
-        Right results ->
-          pure . fmap (resultToCompletion range prefix . snd) . take 15 . sortOn (Fuzzy.score . fst) $ results
+    -- Takes at most the specified number of completions, but also indicates with a boolean
+    -- whether there were more completions remaining so we can pass that along to the client.
+    takeCompletions :: Int -> [a] -> (Bool, [a])
+    takeCompletions 0 xs = (not $ null xs, [])
+    takeCompletions _ [] = (False, [])
+    takeCompletions n (x : xs) = second (x :) $ takeCompletions (pred n) xs
 
-snippetCompletions :: Text -> Range -> [CompletionItem]
-snippetCompletions prefix range =
-  [ ("handler", handlerTemplate),
-    ("cases", casesTemplate),
-    ("match-with", matchWithTemplate)
-  ]
-    & filter (Text.isPrefixOf prefix . fst)
-    & fmap toCompletion
-  where
-    toCompletion :: (Text, Text) -> CompletionItem
-    toCompletion (pat, snippet) =
-      (mkCompletionItem pat)
-        { _insertTextFormat = Just Snippet,
-          _insertTextMode = Just AdjustIndentation,
-          _textEdit = Just $ CompletionEditText (TextEdit range snippet)
-        }
-    handlerTemplate =
-      [here|
-handle${1:Ability} : Request (${1:Ability} ${2}) a -> a
-handle${1:Ability} = cases
-  {${3} -> continue} -> do
-    ${4}
-    |]
-    casesTemplate =
-      [here|
-cases
-  ${1} -> do
-    ${2}
-    |]
-    matchWithTemplate =
-      [here|
-match ${1} with
-  ${2} -> do
-    ${3}
-    |]
-
-mkCompletionItem :: Text -> CompletionItem
-mkCompletionItem lbl =
+mkDefCompletionItem :: Range -> Text -> Text -> Text -> LabeledDependency -> CompletionItem
+mkDefCompletionItem range fqn path suffixified dep =
   CompletionItem
     { _label = lbl,
-      _kind = Nothing,
+      _kind = case dep of
+        LD.TypeReference _ref -> Just CiClass
+        LD.TermReferent ref -> case ref of
+          Referent.Con {} -> Just CiConstructor
+          Referent.Ref {} -> Just CiValue,
       _tags = Nothing,
-      _detail = Nothing,
+      _detail = Just fqn,
       _documentation = Nothing,
       _deprecated = Nothing,
       _preselect = Nothing,
       _sortText = Nothing,
-      _filterText = Nothing,
+      _filterText = Just path,
       _insertText = Nothing,
       _insertTextFormat = Nothing,
       _insertTextMode = Nothing,
-      _textEdit = Nothing,
+      _textEdit = Just (CompletionEditText $ TextEdit range suffixified),
       _additionalTextEdits = Nothing,
       _commitCharacters = Nothing,
       _command = Nothing,
       _xdata = Nothing
     }
+  where
+    -- We should generally show the longer of the path or suffixified name in the label,
+    -- it helps the user understand the difference between options which may otherwise look
+    -- the same.
+    --
+    -- E.g. if I type "ma" then the suffixied options might be: List.map, Bag.map, but the
+    -- path matches are just "map" and "map" since the query starts at that segment, so we
+    -- show the suffixified version to disambiguate.
+    --
+    -- However, if the user types "base.List.ma" then the matching path is "base.List.map" and
+    -- the suffixification is just "List.map", so we use the path in this case because it more
+    -- closely matches what the user actually typed.
+    --
+    -- This is what's felt best to me, anecdotally.
+    lbl =
+      if Text.length path > Text.length suffixified
+        then path
+        else suffixified
+
+-- | Generate a completion tree from a set of names.
+-- A completion tree is a suffix tree over the path segments of each name it contains.
+-- The goal is to allow fast completion of names by any partial path suffix.
+--
+-- The tree is generated by building a trie where all possible suffixes of a name are
+-- reachable from the root of the trie, with sharing over subtrees to improve memory
+-- residency.
+--
+-- Currently we don't "summarize" all of the children of a node in the node itself, and
+-- instead you have to crawl all the children to get the actual completions.
+--
+-- TODO: Would it be worthwhile to perform compression or include child summaries on the suffix tree?
+-- I suspect most namespace trees won't actually compress very well since each node is likely
+-- to have terms/types at it.
+--
+-- E.g. From the names:
+-- * alpha.beta.Nat
+-- * alpha.Text
+-- * foxtrot.Text
+--
+-- It will generate a tree like the following, where each bullet is a possible completion:
+--
+-- .
+-- ├── foxtrot
+-- │   └── Text
+-- │       └── * foxtrot.Text (##Text)
+-- ├── beta
+-- │   └── Nat
+-- │       └── * alpha.beta.Nat (##Nat)
+-- ├── alpha
+-- │   ├── beta
+-- │   │   └── Nat
+-- │   │       └── * alpha.beta.Nat (##Nat)
+-- │   └── Text
+-- │       └── * alpha.Text (##Text)
+-- ├── Text
+-- │   ├── * foxtrot.Text (##Text)
+-- │   └── * alpha.Text (##Text)
+-- └── Nat
+--     └── * alpha.beta.Nat (##Nat)
+namesToCompletionTree :: Names -> CompletionTree
+namesToCompletionTree Names {terms, types} =
+  let typeCompls =
+        Relation.domain types
+          & ifoldMap
+            ( \name refs ->
+                refs
+                  & Monoid.whenM (not . isDefinitionDoc $ name)
+                  & Set.map \ref -> (name, LD.typeRef ref)
+            )
+      termCompls =
+        Relation.domain terms
+          & ifoldMap
+            ( \name refs ->
+                refs
+                  & Monoid.whenM (not . isDefinitionDoc $ name)
+                  & Set.map \ref -> (name, LD.referent ref)
+            )
+   in foldMap (uncurry nameToCompletionTree) (typeCompls <> termCompls)
+  where
+    -- It's  annoying to see _all_ the definition docs in autocomplete so we filter them out.
+    -- Special docs like "README" will still appear since they're not named 'doc'
+    isDefinitionDoc name =
+      case Name.reverseSegments name of
+        ("doc" :| _) -> True
+        _ -> False
+
+nameToCompletionTree :: Name -> LabeledDependency -> CompletionTree
+nameToCompletionTree name ref =
+  let (lastSegment :| prefix) = Name.reverseSegments name
+      complMap = helper (Map.singleton lastSegment (Set.singleton (name, ref) :< mempty)) prefix
+   in CompletionTree (mempty :< complMap)
+  where
+    -- We build the tree bottom-up rather than top-down so we can take 'share' submaps for
+    -- improved memory residency, each  call is passed the submap that we built under the
+    -- current reversed path prefix.
+    helper ::
+      Map
+        NameSegment
+        (Cofree (Map NameSegment) (Set (Name, LabeledDependency))) ->
+      [NameSegment] ->
+      Map
+        NameSegment
+        (Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
+    helper subMap revPrefix = case revPrefix of
+      [] -> subMap
+      (ns : rest) ->
+        mergeSubmaps (helper (Map.singleton ns (mempty :< subMap)) rest) subMap
+      where
+        mergeSubmaps = Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b)
+
+-- | Crawl the completion tree and return all valid prefix-based completions alongside their
+-- Path from the provided prefix, and their full name.
+--
+-- E.g. if the term "alpha.beta.gamma.map (#abc)" exists in the completion map, and the query is "beta" the result would
+-- be:
+--
+-- @@
+-- [(["beta", "gamma", "map"], "alpha.beta.gamma.map", TermReferent #abc)]
+-- @@
+matchCompletions :: CompletionTree -> Text -> [(Path, Name, LabeledDependency)]
+matchCompletions (CompletionTree tree) txt =
+  matchSegments segments (Set.toList <$> tree)
+  where
+    segments :: [Text]
+    segments =
+      Text.splitOn "." txt
+        & filter (not . Text.null)
+    matchSegments :: [Text] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)]
+    matchSegments xs (currentMatches :< subtreeMap) =
+      case xs of
+        [] ->
+          let current = currentMatches <&> (\(name, def) -> (Path.empty, name, def))
+           in (current <> mkDefMatches subtreeMap)
+        [prefix] ->
+          Map.dropWhileAntitone ((< prefix) . NameSegment.toText) subtreeMap
+            & Map.takeWhileAntitone (Text.isPrefixOf prefix . NameSegment.toText)
+            & \matchingSubtrees ->
+              let subMatches = ifoldMap (\ns subTree -> matchSegments [] subTree & consPathPrefix ns) matchingSubtrees
+               in subMatches
+        (ns : rest) ->
+          foldMap (matchSegments rest) (Map.lookup (NameSegment ns) subtreeMap)
+            & consPathPrefix (NameSegment ns)
+    consPathPrefix :: NameSegment -> ([(Path, Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
+    consPathPrefix ns = over (mapped . _1) (Path.cons ns)
+    mkDefMatches :: Map NameSegment (Cofree (Map NameSegment) [(Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
+    mkDefMatches xs = do
+      (ns, (matches :< rest)) <- Map.toList xs
+      let childMatches = mkDefMatches rest <&> over _1 (Path.cons ns)
+      let currentMatches = matches <&> \(name, dep) -> (Path.singleton ns, name, dep)
+      currentMatches <> childMatches

unison-cli/src/Unison/LSP/Configuration.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+
+module Unison.LSP.Configuration where
+
+import Data.Aeson
+import qualified Data.Text as Text
+import Language.LSP.Types
+import qualified Unison.Debug as Debug
+import Unison.LSP.Types
+import Unison.Prelude
+
+-- | Handle configuration changes
+updateConfig :: Config -> Value -> Either Text Config
+updateConfig _oldConfig newConfig = Debug.debug Debug.LSP "Configuration Change" $ case fromJSON newConfig of
+  Error err -> Left $ Text.pack err
+  Success a -> Right a
+
+-- | We could use this notification to cancel/update work-in-progress,
+-- but we don't actually need to update the config here, that's handled by the lsp library
+-- automatically.
+workspaceConfigurationChanged :: NotificationMessage 'WorkspaceDidChangeConfiguration -> Lsp ()
+workspaceConfigurationChanged _m = do
+  pure ()

unison-cli/src/Unison/LSP/Diagnostics.hs

@@ -33,7 +33,7 @@ reportDiagnostics ::
   f Diagnostic ->
   Lsp ()
 reportDiagnostics docUri fileVersion diags = do
-  let jsonRPC = "" -- TODO: what's this for?
+  let jsonRPC = "2.0"
   let params = PublishDiagnosticsParams {_uri = docUri, _version = fromIntegral <$> fileVersion, _diagnostics = List . toList $ diags}
   sendNotification (NotificationMessage jsonRPC STextDocumentPublishDiagnostics params)
 

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -250,7 +250,7 @@ analyseNotes fileUri ppe src notes = do
           refs <- liftIO $ Codebase.termsOfType codebase cleanedTyp
           forMaybe (toList refs) $ \ref -> runMaybeT $ do
             hqNameSuggestion <- MaybeT . pure $ PPE.terms ppe ref
-            typ <- MaybeT . liftIO $ Codebase.getTypeOfReferent codebase ref
+            typ <- MaybeT . liftIO . Codebase.runTransaction codebase $ Codebase.getTypeOfReferent codebase ref
             let prettyType = TypePrinter.prettyStr Nothing ppe typ
             let txtName = HQ'.toText hqNameSuggestion
             let ranges = (diags ^.. folded . range)

unison-cli/src/Unison/LSP/Types.hs

@@ -1,19 +1,28 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Unison.LSP.Types where
 
 import Colog.Core hiding (Lens')
-import Control.Lens hiding (List)
+import Control.Comonad.Cofree (Cofree)
+import qualified Control.Comonad.Cofree as Cofree
+import Control.Lens hiding (List, (:<))
 import Control.Monad.Except
 import Control.Monad.Reader
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.Char8 as BSC
 import qualified Data.HashMap.Strict as HM
 import Data.IntervalMap.Lazy (IntervalMap)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as Text
 import qualified Ki
 import qualified Language.LSP.Logging as LSP
 import Language.LSP.Server
+import qualified Language.LSP.Server as LSP
 import Language.LSP.Types
 import Language.LSP.Types.Lens
 import Language.LSP.VFS
@@ -21,6 +30,9 @@ import Unison.Codebase
 import qualified Unison.Codebase.Path as Path
 import Unison.Codebase.Runtime (Runtime)
 import Unison.LSP.Orphans ()
+import Unison.LabeledDependency (LabeledDependency)
+import Unison.Name (Name)
+import Unison.NameSegment (NameSegment)
 import Unison.NamesWithHistory (NamesWithHistory)
 import Unison.Parser.Ann
 import Unison.Prelude
@@ -65,9 +77,25 @@ data Env = Env
     dirtyFilesVar :: TVar (Set Uri),
     -- A map  of request IDs to an action which kills that request.
     cancellationMapVar :: TVar (Map SomeLspId (IO ())),
+    -- A lazily computed map of all valid completion suffixes from the current path.
+    completionsVar :: TVar CompletionTree,
     scope :: Ki.Scope
   }
 
+-- | A suffix tree over path segments of name completions.
+-- see 'namesToCompletionTree' for more on how this is built and the invariants it should have.
+newtype CompletionTree = CompletionTree
+  { unCompletionTree :: Cofree (Map NameSegment) (Set (Name, LabeledDependency))
+  }
+  deriving (Show)
+
+instance Semigroup CompletionTree where
+  CompletionTree (a Cofree.:< subtreeA) <> CompletionTree (b Cofree.:< subtreeB) =
+    CompletionTree (a <> b Cofree.:< Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b) subtreeA subtreeB)
+
+instance Monoid CompletionTree where
+  mempty = CompletionTree $ mempty Cofree.:< mempty
+
 -- | A monotonically increasing file version tracked by the lsp client.
 type FileVersion = Int32
 
@@ -88,6 +116,9 @@ data FileAnalysis = FileAnalysis
 getCurrentPath :: Lsp Path.Absolute
 getCurrentPath = asks currentPathCache >>= liftIO
 
+getCompletions :: Lsp CompletionTree
+getCompletions = asks completionsVar >>= readTVarIO
+
 globalPPE :: Lsp PrettyPrintEnvDecl
 globalPPE = asks ppeCache >>= liftIO
 
@@ -95,6 +126,41 @@ getParseNames :: Lsp NamesWithHistory
 getParseNames = asks parseNamesCache >>= liftIO
 
 data Config = Config
+  { -- 'Nothing' will load ALL available completions, which is slower, but may provide a better
+    -- solution for some users.
+    --
+    -- 'Just n' will only fetch the first 'n' completions and will prompt the client to ask for
+    -- more completions after more typing.
+    maxCompletions :: Maybe Int
+  }
+  deriving stock (Show)
+
+instance Aeson.FromJSON Config where
+  parseJSON = Aeson.withObject "Config" \obj -> do
+    maxCompletions <- obj Aeson..:! "maxCompletions" Aeson..!= maxCompletions defaultLSPConfig
+    let invalidKeys = Set.fromList (HM.keys obj) `Set.difference` validKeys
+    when (not . null $ invalidKeys) do
+      fail . Text.unpack $
+        "Unrecognized configuration key(s): "
+          <> Text.intercalate ", " (Set.toList invalidKeys)
+          <> ".\nThe default configuration is:\n"
+          <> Text.pack defaultConfigExample
+    pure Config {..}
+    where
+      validKeys = Set.fromList ["maxCompletions"]
+      defaultConfigExample =
+        BSC.unpack $ Aeson.encode defaultLSPConfig
+
+instance Aeson.ToJSON Config where
+  toJSON (Config maxCompletions) =
+    Aeson.object
+      [ "maxCompletions" Aeson..= maxCompletions
+      ]
+
+defaultLSPConfig :: Config
+defaultLSPConfig = Config {..}
+  where
+    maxCompletions = Just 100
 
 -- | Lift a backend computation into the Lsp monad.
 lspBackend :: Backend.Backend IO a -> Lsp (Either Backend.BackendError a)
@@ -142,3 +208,9 @@ includeEdits uri replacement ranges rca =
             _changeAnnotations = Nothing
           }
    in rca & codeAction . edit ?~ workspaceEdit
+
+getConfig :: Lsp Config
+getConfig = LSP.getConfig
+
+setConfig :: Config -> Lsp ()
+setConfig = LSP.setConfig

unison-cli/src/Unison/LSP/UCMWorker.hs

@@ -5,9 +5,11 @@ import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch)
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Debug as Debug
+import Unison.LSP.Completion
 import Unison.LSP.Types
 import qualified Unison.LSP.VFS as VFS
 import Unison.NamesWithHistory (NamesWithHistory)
+import qualified Unison.NamesWithHistory as NamesWithHistory
 import Unison.PrettyPrintEnvDecl
 import qualified Unison.PrettyPrintEnvDecl.Names as PPE
 import qualified Unison.Server.Backend as Backend
@@ -21,7 +23,7 @@ ucmWorker ::
   STM Path.Absolute ->
   Lsp ()
 ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
-  Env {codebase} <- ask
+  Env {codebase, completionsVar} <- ask
   let loop :: (Branch IO, Path.Absolute) -> Lsp a
       loop (currentRoot, currentPath) = do
         Debug.debugM Debug.LSP "LSP path: " currentPath
@@ -33,6 +35,8 @@ ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
           writeTVar ppeVar ppe
         -- Re-check everything with the new names and ppe
         VFS.markAllFilesDirty
+        atomically do
+          writeTVar completionsVar (namesToCompletionTree $ NamesWithHistory.currentNames parseNames)
         latest <- atomically $ do
           latestRoot <- getLatestRoot
           latestPath <- getLatestPath

unison-cli/src/Unison/Share/Sync.hs

@@ -159,7 +159,22 @@ fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadedCal
     Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path))
     Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path))
     Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> do
-      let doLoadCausalSpineBetween = loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
+      let doLoadCausalSpineBetween = do
+            -- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
+            -- actual path.
+            let isBefore :: Sqlite.Transaction Bool
+                isBefore = do
+                  maybeHashIds <-
+                    runMaybeT $
+                      (,)
+                        <$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
+                        <*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
+                  case maybeHashIds of
+                    Nothing -> pure False
+                    Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
+            isBefore >>= \case
+              False -> pure Nothing
+              True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
       (connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBetween) >>= \case
         -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a
         -- fast-forward push, so we don't bother trying - just report the error now.

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

@@ -67,7 +67,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
       cbInit = case fmt of CodebaseFormat2 -> SC.init
   TR.withTranscriptRunner "Unison.Test.Ucm.runTranscript Invalid Version String" configFile $ \runner -> do
     result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DontMigrate \codebase -> do
-      Codebase.installUcmDependencies codebase
+      Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
       let transcriptSrc = Text.pack . stripMargin $ unTranscript transcript
       output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
       when debugTranscriptOutput $ traceM output

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

@@ -19,14 +19,14 @@ import Unison.Codebase.Editor.RemoteRepo
 import qualified Unison.Codebase.Editor.UriParser as UriParser
 import Unison.Codebase.Path (Path (..))
 import qualified Unison.Codebase.Path as Path
-import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
+import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
 import Unison.NameSegment (NameSegment (..))
 
 test :: Test ()
 test = scope "uriparser" . tests $ [testShare, testGit]
 
-gitHelper :: (ReadGitRepo, Maybe ShortBranchHash, Path) -> ReadRemoteNamespace
-gitHelper (repo, sbh, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sbh path)
+gitHelper :: (ReadGitRepo, Maybe ShortCausalHash, Path) -> ReadRemoteNamespace
+gitHelper (repo, sch, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sch path)
 
 testShare :: Test ()
 testShare =
@@ -49,13 +49,13 @@ testGit =
             gitHelper (ReadGitRepo "/srv/git/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(/srv/git/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           ),
           ( "git(srv/git/project.git)",
             gitHelper (ReadGitRepo "srv/git/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(srv/git/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           )
         ],
       -- File Protocol
@@ -65,13 +65,13 @@ testGit =
             gitHelper (ReadGitRepo "file:///srv/git/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(file:///srv/git/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           ),
           ( "git(file://srv/git/project.git)",
             gitHelper (ReadGitRepo "file://srv/git/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(file://srv/git/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           )
         ],
       -- Smart / Dumb HTTP protocol
@@ -81,7 +81,7 @@ testGit =
             gitHelper (ReadGitRepo "https://example.com/git/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(https://user@example.com/git/project.git:abc)#def.hij.klm]",
-            gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           )
         ],
       -- SSH Protocol
@@ -91,7 +91,7 @@ testGit =
             gitHelper (ReadGitRepo "ssh://git@8.8.8.8:222/user/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           )
         ],
       --  $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
@@ -103,7 +103,7 @@ testGit =
             gitHelper (ReadGitRepo "github.com:user/project.git" Nothing, Nothing, Path.empty)
           ),
           ( "git(git@github.com:user/project.git:abc)#def.hij.klm",
-            gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
+            gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
           )
         ]
     ]
@@ -120,5 +120,5 @@ expectParseFailure s = void . scope (Text.unpack s) . expectLeft . P.parse UriPa
 path :: [Text] -> Path
 path = Path . Seq.fromList . fmap NameSegment
 
-sbh :: Text -> Maybe ShortBranchHash
-sbh = Just . ShortBranchHash
+sch :: Text -> Maybe ShortCausalHash
+sch = Just . ShortCausalHash

unison-cli/unison-cli.cabal

@@ -68,11 +68,13 @@ library
       Unison.CommandLine.InputPatterns
       Unison.CommandLine.Main
       Unison.CommandLine.OutputMessages
+      Unison.CommandLine.Types
       Unison.CommandLine.Welcome
       Unison.LSP
       Unison.LSP.CancelRequest
       Unison.LSP.CodeAction
       Unison.LSP.Completion
+      Unison.LSP.Configuration
       Unison.LSP.Conversions
       Unison.LSP.Diagnostics
       Unison.LSP.FileAnalysis
@@ -141,6 +143,7 @@ library
     , exceptions
     , extra
     , filepath
+    , free
     , friendly-time
     , fuzzyfind
     , generic-lens
@@ -185,6 +188,7 @@ library
     , unison-pretty-printer
     , unison-share-api
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
     , unison-util-relation
@@ -263,6 +267,7 @@ executable cli-integration-tests
     , exceptions
     , extra
     , filepath
+    , free
     , friendly-time
     , fuzzyfind
     , generic-lens
@@ -308,6 +313,7 @@ executable cli-integration-tests
     , unison-pretty-printer
     , unison-share-api
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
     , unison-util-relation
@@ -379,6 +385,7 @@ executable transcripts
     , exceptions
     , extra
     , filepath
+    , free
     , friendly-time
     , fuzzyfind
     , generic-lens
@@ -425,6 +432,7 @@ executable transcripts
     , unison-pretty-printer
     , unison-share-api
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
     , unison-util-relation
@@ -499,6 +507,7 @@ executable unison
     , exceptions
     , extra
     , filepath
+    , free
     , friendly-time
     , fuzzyfind
     , generic-lens
@@ -548,6 +557,7 @@ executable unison
     , unison-pretty-printer
     , unison-share-api
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
     , unison-util-relation
@@ -627,6 +637,7 @@ test-suite cli-tests
     , exceptions
     , extra
     , filepath
+    , free
     , friendly-time
     , fuzzyfind
     , generic-lens
@@ -674,6 +685,7 @@ test-suite cli-tests
     , unison-pretty-printer
     , unison-share-api
     , unison-sqlite
+    , unison-syntax
     , unison-util
     , unison-util-base32hex
     , unison-util-relation

unison-cli/unison/ArgParse.hs

@@ -57,6 +57,7 @@ import System.Environment (lookupEnv)
 import Text.Read (readMaybe)
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.Path.Parse as Path
+import Unison.CommandLine.Types (ShouldWatchFiles (..))
 import qualified Unison.PrettyTerminal as PT
 import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
 import qualified Unison.Server.CodebaseServer as Server
@@ -110,6 +111,7 @@ data Command
       ShouldDownloadBase
       -- Starting path
       (Maybe Path.Absolute)
+      ShouldWatchFiles
   | PrintVersion
   | -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
     Init
@@ -347,7 +349,8 @@ launchParser envOpts isHeadless = do
   codebaseServerOpts <- codebaseServerOptsParser envOpts
   downloadBase <- downloadBaseFlag
   startingPath <- startingPathOption
-  pure (Launch isHeadless codebaseServerOpts downloadBase startingPath)
+  shouldWatchFiles <- noFileWatchFlag
+  pure (Launch isHeadless codebaseServerOpts downloadBase startingPath shouldWatchFiles)
 
 initParser :: Parser Command
 initParser = pure Init
@@ -405,6 +408,18 @@ startingPathOption =
           <> noGlobal
    in optional $ option readAbsolutePath meta
 
+noFileWatchFlag :: Parser ShouldWatchFiles
+noFileWatchFlag =
+  flag
+    ShouldWatchFiles
+    ShouldNotWatchFiles
+    ( long "no-file-watch"
+        <> help noFileWatchHelp
+        <> noGlobal
+    )
+  where
+    noFileWatchHelp = "If set, ucm will not respond to changes in unison files. Instead, you can use the 'load' command."
+
 readAbsolutePath :: ReadM Path.Absolute
 readAbsolutePath = do
   readPath' >>= \case

unison-cli/unison/Main.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
@@ -22,7 +23,7 @@ import ArgParse
     parseCLIArgs,
   )
 import Compat (defaultInterruptHandler, onWindows, withInterruptHandler)
-import Control.Concurrent (newEmptyMVar, takeMVar)
+import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar)
 import Control.Concurrent.STM
 import Control.Error.Safe (rightMay)
 import Control.Exception (evaluate)
@@ -37,10 +38,12 @@ import qualified Data.Text.IO as Text
 import GHC.Conc (setUncaughtExceptionHandler)
 import qualified GHC.Conc
 import qualified Ki
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Client.TLS as HTTP
 import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
-import System.Environment (getProgName, withArgs)
+import System.Environment (getProgName, lookupEnv, withArgs)
 import qualified System.Exit as Exit
 import qualified System.FilePath as FP
 import System.IO (stderr)
@@ -55,6 +58,7 @@ import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch)
 import qualified Unison.Codebase.Editor.Input as Input
 import Unison.Codebase.Editor.RemoteRepo (ReadShareRemoteNamespace)
+import Unison.Codebase.Editor.UriParser (parseReadShareRemoteNamespace)
 import qualified Unison.Codebase.Editor.VersionParser as VP
 import Unison.Codebase.Execute (execute)
 import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..))
@@ -66,6 +70,7 @@ import qualified Unison.Codebase.SqliteCodebase as SC
 import qualified Unison.Codebase.TranscriptParser as TR
 import Unison.CommandLine (plural', watchConfig)
 import qualified Unison.CommandLine.Main as CommandLine
+import qualified Unison.CommandLine.Types as CommandLine
 import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
 import qualified Unison.CommandLine.Welcome as Welcome
 import qualified Unison.LSP as LSP
@@ -82,7 +87,7 @@ import UnliftIO.Directory (getHomeDirectory)
 import qualified Version
 
 main :: IO ()
-main = withCP65001 . Ki.scoped $ \scope -> do
+main = withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
   -- Replace the default exception handler with one that pretty-prints.
   setUncaughtExceptionHandler (pHPrint stderr)
 
@@ -136,7 +141,20 @@ main = withCP65001 . Ki.scoped $ \scope -> do
                   let noOpPathNotifier _ = pure ()
                   let serverUrl = Nothing
                   let startPath = Nothing
-                  launch currentDir config rt sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl startPath ShouldNotDownloadBase initRes noOpRootNotifier noOpPathNotifier
+                  launch
+                    currentDir
+                    config
+                    rt
+                    sbrt
+                    theCodebase
+                    [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
+                    serverUrl
+                    startPath
+                    ShouldNotDownloadBase
+                    initRes
+                    noOpRootNotifier
+                    noOpPathNotifier
+                    CommandLine.ShouldNotWatchFiles
       Run (RunFromPipe mainName) args -> do
         e <- safeReadUtf8StdIn
         case e of
@@ -163,6 +181,7 @@ main = withCP65001 . Ki.scoped $ \scope -> do
                 initRes
                 noOpRootNotifier
                 noOpPathNotifier
+                CommandLine.ShouldNotWatchFiles
       Run (RunCompiled file) args ->
         BL.readFile file >>= \bs ->
           try (evaluate $ RTI.decodeStandalone bs) >>= \case
@@ -229,7 +248,7 @@ main = withCP65001 . Ki.scoped $ \scope -> do
                     ]
       Transcript shouldFork shouldSaveCodebase transcriptFiles ->
         runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
-      Launch isHeadless codebaseServerOpts downloadBase mayStartingPath -> do
+      Launch isHeadless codebaseServerOpts downloadBase mayStartingPath shouldWatchFiles -> do
         getCodebaseOrExit mCodePathOption SC.MigrateAfterPrompt \(initRes, _, theCodebase) -> do
           runtime <- RTI.startRuntime False RTI.Persistent Version.gitDescribeWithDate
           rootVar <- newEmptyTMVarIO
@@ -271,7 +290,20 @@ main = withCP65001 . Ki.scoped $ \scope -> do
                     takeMVar mvar
                   WithCLI -> do
                     PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
-                    launch currentDir config runtime sbRuntime theCodebase [] (Just baseUrl) mayStartingPath downloadBase initRes notifyOnRootChanges notifyOnPathChanges
+                    launch
+                      currentDir
+                      config
+                      runtime
+                      sbRuntime
+                      theCodebase
+                      []
+                      (Just baseUrl)
+                      mayStartingPath
+                      downloadBase
+                      initRes
+                      notifyOnRootChanges
+                      notifyOnPathChanges
+                      shouldWatchFiles
               Exit -> do Exit.exitSuccess
 
 -- | Set user agent and configure TLS on global http client.
@@ -422,8 +454,9 @@ launch ::
   InitResult ->
   (Branch IO -> STM ()) ->
   (Path.Absolute -> STM ()) ->
+  CommandLine.ShouldWatchFiles ->
   IO ()
-launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPath shouldDownloadBase initResult notifyRootChange notifyPathChange =
+launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPath shouldDownloadBase initResult notifyRootChange notifyPathChange shouldWatchFiles =
   let downloadBase = case defaultBaseLib of
         Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS
         _ -> Welcome.DontDownloadBase
@@ -432,7 +465,7 @@ launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPat
         _ -> PreviouslyCreatedCodebase
 
       (ucmVersion, _date) = Version.gitDescribe
-      welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion
+      welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion shouldWatchFiles
    in CommandLine.main
         dir
         welcome
@@ -446,6 +479,7 @@ launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPat
         ucmVersion
         notifyRootChange
         notifyPathChange
+        shouldWatchFiles
 
 newtype MarkdownFile = MarkdownFile FilePath
 
@@ -468,8 +502,14 @@ getConfigFilePath mcodepath = (FP.</> ".unisonConfig") <$> Codebase.getCodebaseD
 
 defaultBaseLib :: Maybe ReadShareRemoteNamespace
 defaultBaseLib =
-  rightMay $
-    runParser VP.defaultBaseLib "version" gitRef
+  let mayBaseSharePath =
+        $( do
+             mayPath <- TH.runIO (lookupEnv "UNISON_BASE_PATH")
+             TH.lift mayPath
+         )
+   in mayBaseSharePath & \case
+        Just s -> eitherToMaybe $ parseReadShareRemoteNamespace "UNISON_BASE_PATH" s
+        Nothing -> rightMay $ runParser VP.defaultBaseLib "version" gitRef
   where
     (gitRef, _date) = Version.gitDescribe
 

unison-core/src/Unison/ABT.hs

@@ -27,6 +27,7 @@ module Unison.ABT
     freshInBoth,
     visit,
     visit',
+    visit_,
     visitPure,
     changeVars,
     allVars,
@@ -114,6 +115,7 @@ import U.Core.ABT
     unabs,
     visit,
     visit',
+    visit_,
     visitPure,
     vmap,
     pattern AbsN',

unison-core/src/Unison/ShortHash.hs

@@ -25,19 +25,42 @@ isConstructor = \case
 
 -- Parse a string like those described in Referent.fromText:
 -- examples:
--- `##Text.take` — builtins don’t have cycles or cids
--- `#2tWjVAuc7` — term ref, no cycle
--- `#y9ycWkiC1.y9` — term ref, part of cycle
--- `#cWkiC1x89#1` — constructor
--- `#DCxrnCAPS.WD#0` — constructor of a type in a cycle
+--
+-- builtins don’t have cycles or cids
+-- >>> fromText "##Text.take"
+-- Just (Builtin "Text.take")
+--
+-- term ref, no cycle
+-- >>> fromText "#2tWjVAuc7"
+-- Just (ShortHash {prefix = "2tWjVAuc7", cycle = Nothing, cid = Nothing})
+--
+-- term ref, part of cycle
+-- >>> fromText "#y9ycWkiC1.y9"
+-- Just (ShortHash {prefix = "y9ycWkiC1", cycle = Just "y9", cid = Nothing})
+--
+-- constructor
+-- >>> fromText "#cWkiC1x89#1"
+-- Just (ShortHash {prefix = "cWkiC1x89", cycle = Nothing, cid = Just "1"})
+--
+-- constructor of a type in a cycle
+-- >>> fromText "#DCxrnCAPS.WD#0"
+-- Just (ShortHash {prefix = "DCxrnCAPS", cycle = Just "WD", cid = Just "0"})
+--
 -- A constructor ID on a builtin is ignored:
---  e.g. ##FileIO#2 is parsed as ##FileIO
+-- >>> fromText "##FileIO#2"
+-- Just (Builtin "FileIO")
+--
 -- Anything to the left of the first # is
---   e.g. foo#abc is parsed as #abc
+-- >>> fromText "foo#abc "
+-- Just (ShortHash {prefix = "abc ", cycle = Nothing, cid = Nothing})
+--
 -- Anything including and following a third # is ignored.
---   e.g. foo#abc#2#hello is parsed as #abc#2
+-- >>> fromText "foo#abc#2#hello"
+-- Just (ShortHash {prefix = "abc", cycle = Nothing, cid = Just "2"})
+--
 -- Anything after a second . before a second # is ignored.
---   e.g. foo#abc.1f.x is parsed as #abc.1f
+-- >>> fromText "foo#abc.1f.x"
+-- Just (ShortHash {prefix = "abc", cycle = Just "1f", cid = Nothing})
 fromText :: Text -> Maybe ShortHash
 fromText t = case Text.split (== '#') t of
   [_, "", b] -> Just $ Builtin b -- builtin starts with ##

unison-core/src/Unison/Term.hs

@@ -38,7 +38,7 @@ import qualified Unison.NamesWithHistory as Names
 import Unison.Pattern (Pattern)
 import qualified Unison.Pattern as Pattern
 import Unison.Prelude
-import Unison.Reference (Reference, pattern Builtin)
+import Unison.Reference (Reference, TermReference, pattern Builtin)
 import qualified Unison.Reference as Reference
 import Unison.Referent (Referent)
 import qualified Unison.Referent as Referent
@@ -1169,7 +1169,7 @@ unReqOrCtor _ = Nothing
 dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
 dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t)
 
-termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
+termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set TermReference
 termDependencies =
   Set.fromList
     . mapMaybe

unison-core/src/Unison/Var.hs

@@ -1,8 +1,34 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Unison.Var where
+module Unison.Var
+  ( Var (..),
+    Type (..),
+    InferenceType (..),
+    blank,
+    freshIn,
+    inferAbility,
+    inferInput,
+    inferOther,
+    inferOutput,
+    inferPatternBindE,
+    inferPatternBindV,
+    inferPatternPureE,
+    inferPatternPureV,
+    inferTypeConstructor,
+    inferTypeConstructorArg,
+    joinDot,
+    missingResult,
+    name,
+    nameStr,
+    named,
+    nameds,
+    namespaced,
+    rawName,
+    reset,
+    uncapitalize,
+    universallyQuantifyIfFree,
+    unnamedRef,
+    unnamedTest,
+  )
+where
 
 import Data.Char (isLower, toLower)
 import Data.Text (pack)
@@ -169,9 +195,6 @@ joinDot prefix v2 =
     then named (name prefix `mappend` name v2)
     else named (name prefix `mappend` "." `mappend` name v2)
 
-freshNamed :: Var v => Set v -> Text -> v
-freshNamed used n = ABT.freshIn used (named n)
-
 universallyQuantifyIfFree :: forall v. Var v => v -> Bool
 universallyQuantifyIfFree v =
   ok (name $ reset v) && unqualified v == v