Parallelize a bunch of diff operations

Author: ChrisPenner

src/Share/NamespaceDiffs.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ApplicativeDo #-}
+
 -- | Logic for computing the differerences between two namespaces,
 -- typically used when showing the differences caused by a contribution.
 module Share.NamespaceDiffs
@@ -23,6 +25,7 @@ import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Set.NonEmpty (NESet)
 import Data.Set.NonEmpty qualified as NESet
+import Servant (err500)
 import Share.Postgres qualified as PG
 import Share.Postgres.IDs (BranchHashId)
 import Share.Postgres.NameLookups.Conversions qualified as Cv
@@ -31,7 +34,6 @@ import Share.Postgres.NamespaceDiffs qualified as ND
 import Share.Prelude
 import Share.Utils.Logging qualified as Logging
 import Share.Web.Errors
-import Servant (err500)
 import U.Codebase.Reference qualified as V2
 import U.Codebase.Referent qualified as V2
 import Unison.Codebase.Path (Path)
@@ -82,7 +84,7 @@ data DefinitionDiffKind r
     RenamedFrom r (NESet Name)
   deriving stock (Eq, Show, Ord, Functor, Foldable, Traversable)
 
-instance Ord r => Semigroup (DefinitionDiffs Name r) where
+instance (Ord r) => Semigroup (DefinitionDiffs Name r) where
   d1 <> d2 =
     DefinitionDiffs
       { added = added d1 <> added d2,
@@ -92,7 +94,7 @@ instance Ord r => Semigroup (DefinitionDiffs Name r) where
         newAliases = Map.unionWith (\(a1, b1) (a2, b2) -> (a1 <> a2, b1 <> b2)) (newAliases d1) (newAliases d2)
       }
 
-instance Ord r => Monoid (DefinitionDiffs Name r) where
+instance (Ord r) => Monoid (DefinitionDiffs Name r) where
   mempty =
     DefinitionDiffs
       { added = mempty,
@@ -133,26 +135,26 @@ data DiffAtPath referent reference = DiffAtPath
   deriving stock (Eq, Show)
 
 -- | A traversal over all the referents in a `DiffAtPath`.
-diffAtPathReferents_ :: Ord referent' => Traversal (DiffAtPath referent reference) (DiffAtPath referent' reference) referent referent'
+diffAtPathReferents_ :: (Ord referent') => Traversal (DiffAtPath referent reference) (DiffAtPath referent' reference) referent referent'
 diffAtPathReferents_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) =
   termDiffsAtPath
     & (Set.traverse . traverse) %%~ f
     & fmap \termDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath}
 
 -- | A traversal over all the references in a `DiffAtPath`.
-diffAtPathReferences_ :: Ord reference' => Traversal (DiffAtPath referent reference) (DiffAtPath referent reference') reference reference'
+diffAtPathReferences_ :: (Ord reference') => Traversal (DiffAtPath referent reference) (DiffAtPath referent reference') reference reference'
 diffAtPathReferences_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) =
   typeDiffsAtPath
     & (Set.traverse . traverse) %%~ f
     & fmap \typeDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath}
 
 -- | Traversal over all the referents in a `NamespaceTreeDiff`.
-namespaceTreeDiffReferents_ :: Ord referent' => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent' reference) referent referent'
+namespaceTreeDiffReferents_ :: (Ord referent') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent' reference) referent referent'
 namespaceTreeDiffReferents_ =
   traversed . traversed . diffAtPathReferents_
 
 -- | Traversal over all the references in a `NamespaceTreeDiff`.
-namespaceTreeDiffReferences_ :: Ord reference' => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent reference') reference reference'
+namespaceTreeDiffReferences_ :: (Ord reference') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent reference') reference reference'
 namespaceTreeDiffReferences_ = traversed . traversed . diffAtPathReferences_
 
 data NamespaceDiffError = ImpossibleError Text
@@ -170,8 +172,10 @@ instance Logging.Loggable NamespaceDiffError where
 -- Note: This ignores all dependencies in the lib namespace.
 diffTreeNamespaces :: (BranchHashId, NameLookupReceipt) -> (BranchHashId, NameLookupReceipt) -> (PG.Transaction e (Either NamespaceDiffError (NamespaceTreeDiff V2.Referent V2.Reference)))
 diffTreeNamespaces (oldBHId, oldNLReceipt) (newBHId, newNLReceipt) = do
-  (oldTerms, newTerms) <- ND.getRelevantTermsForDiff oldNLReceipt oldBHId newBHId
-  (oldTypes, newTypes) <- ND.getRelevantTypesForDiff newNLReceipt oldBHId newBHId
+  ((oldTerms, newTerms), (oldTypes, newTypes)) <- PG.pipelined do
+    terms <- ND.getRelevantTermsForDiff oldNLReceipt oldBHId newBHId
+    types <- ND.getRelevantTypesForDiff newNLReceipt oldBHId newBHId
+    pure (terms, types)
   case diffTreeNamespacesHelper (oldTerms, newTerms) (oldTypes, newTypes) of
     Left e -> pure $ Left e
     Right nd ->
@@ -263,7 +267,7 @@ compressNameTree (diffs Cofree.:< children) =
 -- | Compute changes between two unstructured Name relations, determining what has changed and how
 -- it should be interpreted so it's meaningful to the user.
 computeDefinitionDiff ::
-  Ord ref =>
+  (Ord ref) =>
   Relation Name ref {- Relevant definitions from old namespace -} ->
   Relation Name ref {- Relevant definitions from new namespace -} ->
   Either NamespaceDiffError (DefinitionDiffs Name ref)
@@ -326,7 +330,7 @@ computeDefinitionDiff old new =
       )
 
 -- | Convert a `DefinitionDiffs` into a tree of differences.
-definitionDiffsToTree :: forall ref. Ord ref => DefinitionDiffs Name ref -> Cofree (Map NameSegment) (Map NameSegment (Set (DefinitionDiff ref)))
+definitionDiffsToTree :: forall ref. (Ord ref) => DefinitionDiffs Name ref -> Cofree (Map NameSegment) (Map NameSegment (Set (DefinitionDiff ref)))
 definitionDiffsToTree dd =
   let DefinitionDiffs {added, removed, updated, renamed, newAliases} = dd
       expandedAliases :: Map Name (Set (DefinitionDiffKind ref))

src/Share/Postgres.hs

@@ -372,7 +372,7 @@ instance (QueryM m) => QueryM (MaybeT m) where
 prepareStatements :: Bool
 prepareStatements = True
 
-queryListRows :: forall r m. (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m [r]
+queryListRows :: forall r m. (Interp.DecodeRow r, QueryA m) => Interp.Sql -> m [r]
 queryListRows sql = statement () (Interp.interp prepareStatements sql)
 
 query1Row :: forall r m. (QueryM m) => (Interp.DecodeRow r) => Interp.Sql -> m (Maybe r)

src/Share/Postgres/NamespaceDiffs.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Share.Postgres.NamespaceDiffs
@@ -7,7 +8,6 @@ module Share.Postgres.NamespaceDiffs
 where
 
 import Data.Either qualified as Either
-import Share.Postgres (Transaction)
 import Share.Postgres qualified as PG
 import Share.Postgres.IDs (BranchHashId)
 import Share.Postgres.NameLookups.Types (NameLookupReceipt, NamedRef (..), ReversedName)
@@ -25,11 +25,11 @@ import Unison.Util.Relation qualified as Rel
 -- 3. Names that are in both namespaces, but have different refs
 -- 4. Refs that are in both namespaces, but have different names
 getRelevantTermsForDiff ::
+  (PG.QueryA m) =>
   NameLookupReceipt ->
   BranchHashId ->
   BranchHashId ->
-  Transaction
-    e
+  m
     ( Relation Name PGReferent {- relevant terms in old namespace -},
       Relation Name PGReferent {- relevant terms only in new namespace -}
     )
@@ -42,9 +42,8 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
   -- 4. Find (name, ref) pairs that are in both namespaces, but have different names
   -- 5. Return the results as a list of (ref, name, isNew) tuples. It's possible for the same
   --    (name, ref) pair to appear with both (isNew = true) and (isNew = false) in the result.
-  rows <-
-    PG.queryListRows @(NamedRef PGReferent PG.:. PG.Only Bool)
-      [PG.sql|
+  PG.queryListRows @(NamedRef PGReferent PG.:. PG.Only Bool)
+    [PG.sql|
             WITH only_in_old AS (
               ( SELECT old.reversed_name, old.referent_builtin, old.referent_component_hash_id, old.referent_component_index, old.referent_constructor_index
                 FROM scoped_term_name_lookup old
@@ -107,12 +106,15 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
               SELECT new.reversed_name, new.referent_builtin, new.referent_component_hash_id, new.referent_component_index, new.referent_constructor_index, true
                 FROM relevant_terms_in_new new
           |]
-      <&> fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) ->
-        if inNew
-          then Right (from @ReversedName @Name reversedSegments, ref)
-          else Left (from @ReversedName @Name reversedSegments, ref)
-  let (old, new) = Either.partitionEithers rows
-  pure $ (Rel.fromList old, Rel.fromList new)
+    <&> ( fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) ->
+            if inNew
+              then Right (from @ReversedName @Name reversedSegments, ref)
+              else
+                Left (from @ReversedName @Name reversedSegments, ref)
+        )
+    <&> \rows ->
+      let (old, new) = Either.partitionEithers rows
+       in (Rel.fromList old, Rel.fromList new)
 
 -- | Gets the types relevant for computing the diff between two branches.
 -- Where 'relevant' is defined as:
@@ -121,7 +123,7 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
 -- 2. Types that are in the new namespace but not the old namespace
 -- 3. Names that are in both namespaces, but have different refs
 -- 4. Refs that are in both namespaces, but have different names
-getRelevantTypesForDiff :: NameLookupReceipt -> BranchHashId -> BranchHashId -> Transaction e (Relation Name PGReference, Relation Name PGReference)
+getRelevantTypesForDiff :: (PG.QueryA m) => NameLookupReceipt -> BranchHashId -> BranchHashId -> m (Relation Name PGReference, Relation Name PGReference)
 getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
   -- This SQL query does the following:
   --
@@ -131,9 +133,8 @@ getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
   -- 4. Find (name, ref) pairs that are in both namespaces, but have different names
   -- 5. Return the results as a list of (ref, name, isNew) tuples. It's possible for the same
   --    (name, ref) pair to appear with both (isNew = true) and (isNew = false) in the result.
-  rows <-
-    PG.queryListRows @(NamedRef PGReference PG.:. PG.Only Bool)
-      [PG.sql|
+  PG.queryListRows @(NamedRef PGReference PG.:. PG.Only Bool)
+    [PG.sql|
             WITH only_in_old AS (
               ( SELECT old.reversed_name, old.reference_builtin, old.reference_component_hash_id, old.reference_component_index
                 FROM scoped_type_name_lookup old
@@ -192,9 +193,11 @@ getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do
               SELECT new.reversed_name, new.reference_builtin, new.reference_component_hash_id, new.reference_component_index, true
                 FROM relevant_types_in_new new
           |]
-      <&> fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) ->
-        if inNew
-          then Right (from @ReversedName @Name reversedSegments, ref)
-          else Left (from @ReversedName @Name reversedSegments, ref)
-  let (old, new) = Either.partitionEithers rows
-  pure $ (Rel.fromList old, Rel.fromList new)
+    <&> ( fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) ->
+            if inNew
+              then Right (from @ReversedName @Name reversedSegments, ref)
+              else Left (from @ReversedName @Name reversedSegments, ref)
+        )
+    <&> \rows ->
+      let (old, new) = Either.partitionEithers rows
+       in (Rel.fromList old, Rel.fromList new)

src/Share/Web/Share/Diffs/Impl.hs

@@ -33,6 +33,7 @@ import Unison.Server.Types (DisplayObjectDiff, TermDefinition (..), TermTag, Typ
 import Unison.ShortHash (ShortHash)
 import Unison.Syntax.Name qualified as Name
 import Unison.Util.Pretty (Width)
+import UnliftIO qualified
 
 diffNamespaces ::
   AuthZReceipt ->
@@ -66,16 +67,16 @@ diffCausals ::
 diffCausals !_authZReceipt oldCausalId newCausalId = do
   -- Ensure name lookups for each thing we're diffing.
   -- We do this in two separate transactions to ensure we can still make progress even if we need to build name lookups.
-  (oldBranchHashId, oldBranchNLReceipt) <- PG.runTransaction $ do
-    oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId
-    oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId
-    pure (oldBranchHashId, oldBranchNLReceipt)
-
-  (newBranchHashId, newNLReceipt) <- PG.runTransaction $ do
-    newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId
-    newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId
-    pure (newBranchHashId, newNLReceipt)
+  let getOldBranch = PG.runTransaction $ do
+        oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId
+        oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId
+        pure (oldBranchHashId, oldBranchNLReceipt)
 
+  let getNewBranch = PG.runTransaction $ do
+        newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId
+        newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId
+        pure (newBranchHashId, newNLReceipt)
+  ((oldBranchHashId, oldBranchNLReceipt), (newBranchHashId, newNLReceipt)) <- getOldBranch `UnliftIO.concurrently` getNewBranch
   PG.runTransactionOrRespondError $ do
     diff <- NamespaceDiffs.diffTreeNamespaces (oldBranchHashId, oldBranchNLReceipt) (newBranchHashId, newNLReceipt) `whenLeftM` throwError
     withTermTags <-
@@ -100,12 +101,12 @@ diffTerms ::
   (Codebase.CodebaseEnv, BranchHashId, Name) ->
   (Codebase.CodebaseEnv, BranchHashId, Name) ->
   WebApp (TermDefinition, TermDefinition, DisplayObjectDiff)
-diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) =
-  do
-    oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName))
-    newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName))
-    let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj
-    pure $ (oldTerm, newTerm, termDiffDisplayObject)
+diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) = do
+  let getOldTerm = getTermDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName))
+  let getNewTerm = getTermDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName))
+  (oldTerm, newTerm) <- getOldTerm `UnliftIO.concurrently` getNewTerm
+  let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects (termDefinition oldTerm) (termDefinition newTerm)
+  pure $ (oldTerm, newTerm, termDiffDisplayObject)
   where
     renderWidth :: Width
     renderWidth = 80
@@ -124,12 +125,16 @@ diffTypes ::
   (Codebase.CodebaseEnv, BranchHashId, Name) ->
   (Codebase.CodebaseEnv, BranchHashId, Name) ->
   WebApp (TypeDefinition, TypeDefinition, DisplayObjectDiff)
-diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) =
-  do
-    sourceType@(TypeDefinition {typeDefinition = sourceDisplayObj}) <- getTypeDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName))
-    newType@(TypeDefinition {typeDefinition = newDisplayObj}) <- getTypeDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName))
-    let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects sourceDisplayObj newDisplayObj
-    pure $ (sourceType, newType, typeDiffDisplayObject)
+diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) = do
+  let getOldType =
+        getTypeDefinition old
+          `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName))
+  let getNewType =
+        getTypeDefinition new
+          `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName))
+  (sourceType, newType) <- getOldType `UnliftIO.concurrently` getNewType
+  let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects (typeDefinition sourceType) (typeDefinition newType)
+  pure $ (sourceType, newType, typeDiffDisplayObject)
   where
     renderWidth :: Width
     renderWidth = 80