Merge pull request #4265 from unisonweb/pg/name-lookups-hasql

Port Name lookups to Postgres

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

@@ -1,5 +1,6 @@
 module U.Codebase.Branch.Diff
   ( TreeDiff (..),
+    hoistTreeDiff,
     NameChanges (..),
     DefinitionDiffs (..),
     Diff (..),
@@ -12,6 +13,7 @@ module U.Codebase.Branch.Diff
 where
 
 import Control.Comonad.Cofree
+import Control.Comonad.Cofree qualified as Cofree
 import Control.Lens (ifoldMap)
 import Control.Lens qualified as Lens
 import Data.Functor.Compose (Compose (..))
@@ -20,6 +22,7 @@ import Data.Semialign qualified as Align
 import Data.Set qualified as Set
 import Data.These
 import U.Codebase.Branch
+import U.Codebase.Branch qualified as V2Branch
 import U.Codebase.Branch.Type qualified as Branch
 import U.Codebase.Causal qualified as Causal
 import U.Codebase.Reference (Reference)
@@ -29,6 +32,7 @@ import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
 import Unison.Prelude
+import Unison.Sqlite qualified as Sqlite
 import Unison.Util.Monoid (foldMapM, ifoldMapM)
 import Unison.Util.Relation (Relation)
 import Unison.Util.Relation qualified as Relation
@@ -76,6 +80,10 @@ instance (Applicative m) => Semigroup (TreeDiff m) where
 instance (Applicative m) => Monoid (TreeDiff m) where
   mempty = TreeDiff (mempty :< Compose mempty)
 
+hoistTreeDiff :: Functor m => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n
+hoistTreeDiff f (TreeDiff cfr) =
+  TreeDiff $ Cofree.hoistCofree (\(Compose m) -> Compose (fmap f m)) cfr
+
 -- | 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
@@ -114,37 +122,40 @@ instance Semigroup NameBasedDiff where
     NameBasedDiff (terms0 <> terms1) (types0 <> types1)
 
 -- | Diff two Branches, returning a tree containing all of the changes
-diffBranches :: forall m. (Monad m) => Branch m -> Branch m -> TreeDiff m
-diffBranches from to =
+diffBranches :: Branch Sqlite.Transaction -> Branch Sqlite.Transaction -> Sqlite.Transaction (TreeDiff Sqlite.Transaction)
+diffBranches from to = do
+  fromChildren <- V2Branch.nonEmptyChildren from
+  toChildren <- V2Branch.nonEmptyChildren to
   let termDiffs = diffMap (Branch.terms from) (Branch.terms to)
-      typeDiffs = diffMap (Branch.types from) (Branch.types to)
-      defDiff = DefinitionDiffs {termDiffs, typeDiffs}
-      childDiff :: (Map NameSegment (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)))
-      childDiff = do
-        Align.align (children from) (children to)
+  let typeDiffs = diffMap (Branch.types from) (Branch.types to)
+  let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
+  let childDiff :: Map NameSegment (Sqlite.Transaction (Cofree (Compose (Map NameSegment) Sqlite.Transaction) DefinitionDiffs))
+      childDiff =
+        Align.align fromChildren toChildren
           & mapMaybe \case
             This ca -> Just 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
-              pure . unTreeDiff $ diffBranches removedChildBranch Branch.empty
+              unTreeDiff <$> diffBranches removedChildBranch Branch.empty
             That ca -> Just do
               newChildBranch <- Causal.value ca
-              pure . unTreeDiff $ diffBranches Branch.empty newChildBranch
+              unTreeDiff <$> diffBranches Branch.empty newChildBranch
             These fromC toC
               | Causal.valueHash fromC == Causal.valueHash toC ->
                   -- This child didn't change.
                   Nothing
               | otherwise -> Just $ do
                   fromChildBranch <- Causal.value fromC
                   toChildBranch <- Causal.value toC
-                  case diffBranches fromChildBranch toChildBranch of
+                  diffBranches fromChildBranch toChildBranch >>= \case
                     TreeDiff (defDiffs :< Compose mchildren) -> do
                       pure $ (defDiffs :< Compose mchildren)
-   in TreeDiff (defDiff :< Compose childDiff)
+  pure $
+    TreeDiff (defDiff :< Compose childDiff)
   where
-    diffMap :: forall ref. (Ord ref) => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
+    diffMap :: forall ref. (Ord ref) => Map NameSegment (Map ref (Sqlite.Transaction MdValues)) -> Map NameSegment (Map ref (Sqlite.Transaction MdValues)) -> Map NameSegment (Diff ref)
     diffMap l r =
       Align.align l r
         & fmap \case
@@ -211,7 +222,10 @@ streamNameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :
             let name = appendName ns
              in (listifyNames name $ adds diff, listifyNames name $ removals diff)
   let nameChanges = NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals}
-  acc <- f namePrefix nameChanges
+  acc <-
+    if nameChanges == mempty
+      then pure mempty
+      else f namePrefix nameChanges
   childAcc <-
     children
       & ifoldMapM

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

@@ -648,7 +648,7 @@ ensureNameLookupForBranchHash getDeclType mayFromBranchHash toBranchHash = do
       toBranch <- Ops.expectBranchByBranchHash toBranchHash
       depMounts <- Projects.inferDependencyMounts toBranch <&> fmap (first (coerce @_ @PathSegments . Path.toList))
       let depMountPaths = (Path.fromList . coerce) . fst <$> depMounts
-      let treeDiff = ignoreDepMounts depMountPaths $ BranchDiff.diffBranches fromBranch toBranch
+      treeDiff <- ignoreDepMounts depMountPaths <$> BranchDiff.diffBranches fromBranch toBranch
       let namePrefix = Nothing
       Ops.buildNameLookupForBranchHash
         mayExistingLookupBH

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

@@ -1320,7 +1320,7 @@ loop e = do
                 Cli.runTransaction do
                   fromBranch <- Codebase.expectCausalBranchByCausalHash fromCH >>= V2Causal.value
                   toBranch <- Codebase.expectCausalBranchByCausalHash toCH >>= V2Causal.value
-                  let treeDiff = V2Branch.Diff.diffBranches fromBranch toBranch
+                  treeDiff <- V2Branch.Diff.diffBranches fromBranch toBranch
                   nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff
                   pure (DisplayDebugNameDiff nameChanges)
               Cli.respond output
@@ -1909,7 +1909,7 @@ handleDiffNamespaceToPatch description input = do
         branch1 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId1)
         branch2 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId2)
         lift do
-          branchDiff <- V2Branch.Diff.nameBasedDiff (V2Branch.Diff.diffBranches branch1 branch2)
+          branchDiff <- V2Branch.Diff.diffBranches branch1 branch2 >>= V2Branch.Diff.nameBasedDiff
           termEdits <-
             (branchDiff ^. #terms)
               & Relation.domain

unison-share-api/src/Unison/Server/Backend.hs

@@ -86,6 +86,7 @@ module Unison.Server.Backend
     evalDocRef,
     mkTermDefinition,
     mkTypeDefinition,
+    displayTerm,
   )
 where
 
@@ -877,6 +878,7 @@ mungeSyntaxText ::
 mungeSyntaxText = fmap Syntax.convertElement
 
 mkTypeDefinition ::
+  MonadIO m =>
   Codebase IO Symbol Ann ->
   PPED.PrettyPrintEnvDecl ->
   Path.Path ->
@@ -887,7 +889,7 @@ mkTypeDefinition ::
   DisplayObject
     (AnnotatedText (UST.Element Reference))
     (AnnotatedText (UST.Element Reference)) ->
-  Backend IO TypeDefinition
+  m TypeDefinition
 mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do
   let bn = bestNameForType @Symbol (PPED.suffixifiedPPE pped) width r
   tag <-