Try pipelining more queries

Author: ChrisPenner

src/Share/Backend.hs

@@ -142,7 +142,7 @@ mkTermDefinition termPPED width r docs tm = do
           docs
 
 termListEntry ::
-  (PG.QueryM m) =>
+  (PG.QueryM m e) =>
   Type Symbol Ann ->
   ExactName NameSegment V2Referent.Referent ->
   m (Backend.TermEntry Symbol Ann)
@@ -160,7 +160,7 @@ termListEntry typ (ExactName nameSegment ref) = do
       }
 
 typeListEntry ::
-  (PG.QueryM m) =>
+  (PG.QueryM m e) =>
   ExactName NameSegment Reference ->
   m Backend.TypeEntry
 typeListEntry (ExactName nameSegment ref) = do
@@ -176,7 +176,7 @@ typeListEntry (ExactName nameSegment ref) = do
       }
 
 getTermTag ::
-  (PG.QueryM m, Var v) =>
+  (PG.QueryM m e, Var v) =>
   V2Referent.Referent ->
   Type v Ann ->
   m TermTag
@@ -199,7 +199,7 @@ getTermTag r termType = do
       | otherwise -> Plain
 
 getTypeTag ::
-  (PG.QueryM m) =>
+  (PG.QueryM m e) =>
   Reference.TypeReference ->
   m TypeTag
 getTypeTag r = do

src/Share/Codebase.hs

@@ -278,10 +278,10 @@ expectTypeOfReferents :: Traversal s t V2.Referent (V1.Type Symbol Ann) -> s ->
 expectTypeOfReferents trav s = do
   s & trav %%~ expectTypeOfReferent
 
-expectDeclKind :: (PG.QueryM m) => Reference.TypeReference -> m CT.ConstructorType
+expectDeclKind :: (PG.QueryM m e) => Reference.TypeReference -> m CT.ConstructorType
 expectDeclKind r = loadDeclKind r `whenNothingM` (unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r))
 
-expectDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.TypeReference CT.ConstructorType -> s -> m t
+expectDeclKindsOf :: (PG.QueryM m e) => Traversal s t Reference.TypeReference CT.ConstructorType -> s -> m t
 expectDeclKindsOf trav s = do
   s
     & unsafePartsOf trav %%~ \refs -> do
@@ -290,10 +290,10 @@ expectDeclKindsOf trav s = do
         (r, Nothing) -> unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r)
         (_, Just ct) -> pure ct
 
-loadDeclKind :: (PG.QueryM m) => V2.TypeReference -> m (Maybe CT.ConstructorType)
+loadDeclKind :: (PG.QueryM m e) => V2.TypeReference -> m (Maybe CT.ConstructorType)
 loadDeclKind = loadDeclKindsOf id
 
-loadDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.TypeReference (Maybe CT.ConstructorType) -> s -> m t
+loadDeclKindsOf :: (PG.QueryM m e) => Traversal s t Reference.TypeReference (Maybe CT.ConstructorType) -> s -> m t
 loadDeclKindsOf trav s =
   s
     & unsafePartsOf trav %%~ \refs -> do

src/Share/Postgres.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE LiberalTypeSynonyms #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Postgres helpers
 module Share.Postgres
@@ -42,7 +44,6 @@ module Share.Postgres
     tryRunSessionWithPool,
     unliftSession,
     defaultIsolationLevel,
-    pipelined,
     pFor,
     pFor_,
 
@@ -122,10 +123,6 @@ instance MonadError e (Transaction e) where
 newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either (TransactionError e) a)}
   deriving (Functor, Applicative) via (Compose Hasql.Pipeline.Pipeline (Either (TransactionError e)))
 
--- | Run a pipeline in a transaction
-pipelined :: Pipeline e a -> Transaction e a
-pipelined p = Transaction (Hasql.pipeline (unPipeline p))
-
 pFor :: (Traversable f) => f a -> (a -> Pipeline e b) -> Transaction e (f b)
 pFor f p = pipelined $ for f p
 
@@ -319,81 +316,106 @@ runSessionOrRespondError :: (HasCallStack, ToServerError e, Loggable e) => Sessi
 runSessionOrRespondError t = tryRunSession t >>= either respondError pure
 
 -- | Represents anywhere we can run a statement
-class (Applicative m) => QueryA m where
+class (Applicative m) => QueryA m e | m -> e where
   statement :: q -> Hasql.Statement q r -> m r
 
   -- | Fail the transaction and whole request with an unrecoverable server error.
-  unrecoverableError :: (HasCallStack, ToServerError e, Loggable e, Show e) => e -> m a
+  unrecoverableError :: (HasCallStack, ToServerError x, Loggable x, Show x) => x -> m a
+
+  throwErr :: (ToServerError e, Loggable e, Show e) => e -> m a
 
-class (Monad m, QueryA m) => QueryM m where
+  pipelined :: Pipeline e a -> m a
+
+class (Monad m, QueryA m e) => QueryM m e | m -> e where
   -- | Allow running IO actions in a transaction. These actions may be run multiple times if
   -- the transaction is retried.
   transactionUnsafeIO :: IO a -> m a
 
-instance QueryA (Transaction e) where
+instance QueryA (Transaction e) e where
   statement q s = do
     transactionStatement q s
 
+  throwErr = throwError
+
+  pipelined p = Transaction (Hasql.pipeline (unPipeline p))
+
   unrecoverableError e = Transaction (pure (Left (Unrecoverable (someServerError e))))
 
-instance QueryM (Transaction e) where
+instance QueryM (Transaction e) e where
   transactionUnsafeIO io = Transaction (Right <$> liftIO io)
 
-instance QueryA (Session e) where
+instance QueryA (Session e) e where
   statement q s = do
     lift $ Session.statement q s
 
+  throwErr = throwError . Err
+
+  pipelined p = do
+    ExceptT $ Hasql.pipeline (unPipeline p)
+
   unrecoverableError e = throwError (Unrecoverable (someServerError e))
 
-instance QueryM (Session e) where
+instance QueryM (Session e) e where
   transactionUnsafeIO io = lift $ liftIO io
 
-instance QueryA (Pipeline e) where
+instance QueryA (Pipeline e) e where
   statement q s = Pipeline (Right <$> Hasql.Pipeline.statement q s)
 
+  throwErr = Pipeline . pure . Left . Err
+
+  pipelined p = p
+
   unrecoverableError e = Pipeline $ pure (Left (Unrecoverable (someServerError e)))
 
-instance (QueryM m) => QueryA (ReaderT e m) where
+instance (QueryM m e) => QueryA (ReaderT r m) e where
   statement q s = lift $ statement q s
 
+  throwErr = lift . throwErr
+
+  pipelined p = lift $ pipelined p
+
   unrecoverableError e = lift $ unrecoverableError e
 
-instance (QueryM m) => QueryM (ReaderT e m) where
+instance (QueryM m e) => QueryM (ReaderT r m) e where
   transactionUnsafeIO io = lift $ transactionUnsafeIO io
 
-instance (QueryM m) => QueryA (MaybeT m) where
+instance (QueryM m e) => QueryA (MaybeT m) e where
   statement q s = lift $ statement q s
 
+  throwErr = lift . throwErr
+
+  pipelined p = lift $ pipelined p
+
   unrecoverableError e = lift $ unrecoverableError e
 
-instance (QueryM m) => QueryM (MaybeT m) where
+instance (QueryM m e) => QueryM (MaybeT m) e where
   transactionUnsafeIO io = lift $ transactionUnsafeIO io
 
 prepareStatements :: Bool
 prepareStatements = True
 
-queryListRows :: forall r m. (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m [r]
+queryListRows :: forall r m e. (Interp.DecodeRow r, QueryA m e) => 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)
+query1Row :: forall r m e. (QueryA m e) => (Interp.DecodeRow r) => Interp.Sql -> m (Maybe r)
 query1Row sql = listToMaybe <$> queryListRows sql
 
-query1Col :: forall a m. (QueryM m, Interp.DecodeField a) => Interp.Sql -> m (Maybe a)
+query1Col :: forall a m e. (QueryA m e, Interp.DecodeField a) => Interp.Sql -> m (Maybe a)
 query1Col sql = listToMaybe <$> queryListCol sql
 
-queryListCol :: forall a m. (QueryM m) => (Interp.DecodeField a) => Interp.Sql -> m [a]
+queryListCol :: forall a m e. (QueryA m e) => (Interp.DecodeField a) => Interp.Sql -> m [a]
 queryListCol sql = queryListRows @(Interp.OneColumn a) sql <&> coerce @[Interp.OneColumn a] @[a]
 
-execute_ :: (QueryA m) => Interp.Sql -> m ()
+execute_ :: (QueryA m e) => Interp.Sql -> m ()
 execute_ sql = statement () (Interp.interp prepareStatements sql)
 
-queryExpect1Row :: forall r m. (HasCallStack) => (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m r
+queryExpect1Row :: forall r m e. (HasCallStack) => (Interp.DecodeRow r, QueryM m e) => Interp.Sql -> m r
 queryExpect1Row sql =
   query1Row sql >>= \case
     Nothing -> error "queryExpect1Row: expected 1 row, got 0"
     Just r -> pure r
 
-queryExpect1Col :: forall a m. (HasCallStack) => (Interp.DecodeField a, QueryM m) => Interp.Sql -> m a
+queryExpect1Col :: forall a m e. (HasCallStack) => (Interp.DecodeField a, QueryM m e) => Interp.Sql -> m a
 queryExpect1Col sql =
   query1Col sql >>= \case
     Nothing -> error "queryExpect1Col: expected 1 row, got 0"
@@ -497,7 +519,7 @@ instance Interp.DecodeValue RawBytes where
 whenNonEmpty :: forall m f a x. (Monad m, Foldable f, Monoid a) => f x -> m a -> m a
 whenNonEmpty f m = if null f then pure mempty else m
 
-timeTransaction :: (QueryM m) => String -> m a -> m a
+timeTransaction :: (QueryM m e) => String -> m a -> m a
 timeTransaction label ma =
   if Debug.shouldDebug Debug.Timing
     then do

src/Share/Postgres/Causal/Queries.hs

@@ -34,6 +34,7 @@ import Share.Codebase.Types (CodebaseM)
 import Share.Codebase.Types qualified as Codebase
 import Share.IDs (UserId)
 import Share.Postgres
+import Share.Postgres qualified as PG
 import Share.Postgres.Causal.Types
 import Share.Postgres.Definitions.Queries qualified as Defn
 import Share.Postgres.Definitions.Types
@@ -58,7 +59,7 @@ import Unison.NameSegment.Internal as NameSegment
 import Unison.Reference qualified as Reference
 import Unison.Util.Map qualified as Map
 
-expectCausalNamespace :: (HasCallStack, QueryM m) => CausalId -> m (CausalNamespace m)
+expectCausalNamespace :: (HasCallStack, QueryM m e) => CausalId -> m (CausalNamespace m)
 expectCausalNamespace causalId =
   loadCausalNamespace causalId
     `whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected causal branch for hash:" <> tShow causalId)
@@ -98,7 +99,7 @@ expectPgCausalNamespace causalId =
   loadPgCausalNamespace causalId
     `whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected causal branch for causal: " <> tShow causalId)
 
-loadCausalNamespace :: forall m. (QueryM m) => CausalId -> m (Maybe (CausalNamespace m))
+loadCausalNamespace :: forall m e. (QueryM m e) => CausalId -> m (Maybe (CausalNamespace m))
 loadCausalNamespace causalId = runMaybeT $ do
   causalHash <- HashQ.expectCausalHashesByIdsOf id causalId
   branchHashId <- HashQ.expectNamespaceIdsByCausalIdsOf id causalId
@@ -139,22 +140,23 @@ expectNamespaceHashByCausalHash causalHash = do
                 AND EXISTS (SELECT FROM causal_ownership o WHERE o.causal_id = causals.id AND o.user_id = #{codebaseOwner})
     |]
 
-expectNamespace :: forall m. (QueryM m) => BranchHashId -> m (Branch m)
+expectNamespace :: forall m e. (QueryM m e) => BranchHashId -> m (Branch m)
 expectNamespace branchHashId = do
-  termsAndConstructors <- getTermsAndConstructors branchHashId <&> (traversed . traversed %~ loadTermMetadata)
-  types <- getTypes branchHashId <&> (traversed . traversed %~ loadTypeMetadata)
   patches <- getPatches branchHashId
   children <- getChildren branchHashId
-  pure $
-    Branch
-      { -- (<>) is safe here because no referents will overlap between terms and constructors
-        terms = termsAndConstructors,
-        types,
-        patches,
-        children
-      }
+  pipelined $ do
+    termsAndConstructors <- getTermsAndConstructors branchHashId <&> (traversed . traversed %~ loadTermMetadata)
+    types <- getTypes branchHashId <&> (traversed . traversed %~ loadTypeMetadata)
+    pure $
+      Branch
+        { -- (<>) is safe here because no referents will overlap between terms and constructors
+          terms = termsAndConstructors,
+          types,
+          patches,
+          children
+        }
   where
-    getTermsAndConstructors :: BranchHashId -> m (Map NameSegment (Map Referent NamespaceTermMappingId))
+    getTermsAndConstructors :: forall m. (QueryA m e) => BranchHashId -> m (Map NameSegment (Map Referent NamespaceTermMappingId))
     getTermsAndConstructors branchHashId = do
       queryListRows @(NameSegment, Maybe Text, Maybe ComponentHash, Maybe PgComponentIndex, Maybe PgConstructorIndex, NamespaceTermMappingId)
         [sql| SELECT name_segment.text AS name_segment, builtin.text AS builtin_text, comp_hash.base32, COALESCE(term.component_index, constr_typ.component_index), constr.constructor_index, mapping.id
@@ -183,7 +185,7 @@ expectNamespace branchHashId = do
           )
         <&> Map.fromListWith (<>)
 
-    getTypes :: BranchHashId -> m (Map NameSegment (Map Reference NamespaceTypeMappingId))
+    getTypes :: forall m. (QueryA m e) => BranchHashId -> m (Map NameSegment (Map Reference NamespaceTypeMappingId))
     getTypes branchHashId = do
       queryListRows
         [sql| SELECT name_segment.text AS name_segment, builtin.text AS builtin_text, component_hashes.base32, typ.component_index, mapping.id
@@ -207,7 +209,7 @@ expectNamespace branchHashId = do
           )
         <&> Map.fromListWith (<>)
 
-    getPatches :: BranchHashId -> m (Map NameSegment (PatchHash, m Patch))
+    getPatches :: forall m. (QueryM m e) => BranchHashId -> m (Map NameSegment (PatchHash, m Patch))
     getPatches branchHashId = do
       queryListRows
         [sql| SELECT name_segment.text AS name_segment, patch.hash, patch.id
@@ -222,7 +224,7 @@ expectNamespace branchHashId = do
           )
         <&> Map.fromList
 
-    getChildren :: BranchHashId -> m (Map NameSegment (CausalBranch m))
+    getChildren :: forall m. (QueryM m e) => BranchHashId -> m (Map NameSegment (CausalBranch m))
     getChildren branchHashId = do
       childIds <-
         queryListRows
@@ -235,7 +237,7 @@ expectNamespace branchHashId = do
         (name_segment,) <$> expectCausalNamespace causalId
       pure $ Map.fromList childList
 
-    loadTermMetadata :: NamespaceTermMappingId -> m MdValues
+    loadTermMetadata :: forall m. (QueryA m e) => NamespaceTermMappingId -> m MdValues
     loadTermMetadata mappingId = do
       queryListRows @(Maybe Hash, Maybe PgComponentIndex, Maybe Text)
         [sql|
@@ -248,7 +250,7 @@ expectNamespace branchHashId = do
       |]
         <&> formatMdValues
 
-    loadTypeMetadata :: NamespaceTypeMappingId -> m MdValues
+    loadTypeMetadata :: forall m. (QueryA m e) => NamespaceTypeMappingId -> m MdValues
     loadTypeMetadata mappingId =
       do
         queryListRows @(Maybe Hash, Maybe PgComponentIndex, Maybe Text)
@@ -608,7 +610,7 @@ savePgNamespace mayBh b@(BranchFull.Branch {terms, types, patches, children}) =
       execute_ [sql| SELECT save_namespace(#{bhId}) |]
 
 -- | Hash a namespace into a BranchHash
-hashPgNamespace :: forall m. (QueryM m) => PgNamespace -> m BranchHash
+hashPgNamespace :: forall m e. (QueryM m e) => PgNamespace -> m BranchHash
 hashPgNamespace b = do
   BranchFull.Branch {terms, types, patches, children} <-
     b
@@ -660,7 +662,7 @@ hashPgNamespace b = do
       Referent.Ref r -> H.ReferentRef (v2ToH2Reference r)
       Referent.Con r cid -> H.ReferentCon (v2ToH2Reference r) cid
 
-hashCausal :: (QueryM m) => BranchHashId -> Set CausalId -> m CausalHash
+hashCausal :: (QueryM m e) => BranchHashId -> Set CausalId -> m CausalHash
 hashCausal branchHashId ancestorIds = do
   branchHash <- HashQ.expectBranchHash branchHashId
   ancestors <-
@@ -778,7 +780,7 @@ saveV2BranchShallow v2Branch = do
     mdValuesToMetadataSetFormat (V2.MdValues meta) = BranchFull.Inline meta
 
 -- | Get the namespace stats of a namespace.
-expectNamespaceStatsOf :: (QueryM m) => Traversal s t BranchHash NamespaceStats -> s -> m t
+expectNamespaceStatsOf :: (QueryM m e) => Traversal s t BranchHash NamespaceStats -> s -> m t
 expectNamespaceStatsOf trav s =
   s
     & unsafePartsOf trav %%~ \branchHashes -> do
@@ -867,13 +869,13 @@ importAccessibleCausals causalHashes = do
               -- Order by determines which values are returned by DISTINCT ON
               ORDER BY copyable.causal_id ASC, copyable.created_at DESC
         |]
-  for_ results \case
+  lift $ PG.pFor_ results \case
     (causalId, owner) -> do
       execute_ [sql| SELECT copy_causal_into_codebase(#{causalId}, #{owner}, #{codebaseOwnerUserId}) |]
   pure results
 
 -- | Find the best common ancestor between two causals for diffs or merges.
-bestCommonAncestor :: (QueryM m) => CausalId -> CausalId -> m (Maybe CausalId)
+bestCommonAncestor :: (QueryM m e) => CausalId -> CausalId -> m (Maybe CausalId)
 bestCommonAncestor a b = do
   query1Col
     [sql| SELECT best_common_causal_ancestor(#{a}, #{b}) as causal_id