Pipeline a bunch of sync operations

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
@@ -23,6 +25,8 @@ module Share.Postgres
     Only (..),
     QueryA (..),
     QueryM (..),
+    unrecoverableError,
+    throwErr,
     decodeField,
     (:.) (..),
 
@@ -42,7 +46,6 @@ module Share.Postgres
     tryRunSessionWithPool,
     unliftSession,
     defaultIsolationLevel,
-    pipelined,
     pFor,
     pFor_,
 
@@ -119,13 +122,9 @@ instance MonadError e (Transaction e) where
       Right a -> pure (Right a)
 
 -- | Applicative pipelining transaction
-newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either (TransactionError e) a)}
+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 +318,138 @@ 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
+  unrecoverableErrorA :: (HasCallStack, ToServerError x, Loggable x, Show x) => m (Either x a) -> m a
+
+  throwErrA :: (ToServerError e, Loggable e, Show e) => m (Either e a) -> 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
 
-  unrecoverableError e = Transaction (pure (Left (Unrecoverable (someServerError e))))
+  throwErrA m = m >>= either throwError pure
+
+  pipelined (Pipeline p) = Transaction (Hasql.pipeline p)
 
-instance QueryM (Transaction e) where
+  unrecoverableErrorA me =
+    me >>= \case
+      Right a -> pure a
+      Left e -> Transaction (pure (Left (Unrecoverable (someServerError e))))
+
+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
 
-  unrecoverableError e = throwError (Unrecoverable (someServerError e))
+  throwErrA m = m >>= either (throwError . Err) pure
+
+  pipelined (Pipeline p) = do
+    ExceptT $ Hasql.pipeline p
 
-instance QueryM (Session e) where
+  unrecoverableErrorA me =
+    me >>= \case
+      Right a -> pure a
+      Left e -> throwError (Unrecoverable (someServerError e))
+
+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)
 
-  unrecoverableError e = Pipeline $ pure (Left (Unrecoverable (someServerError e)))
+  throwErrA (Pipeline me) =
+    -- Flatten error into pipeline
+    Pipeline $
+      me <&> \case
+        Left e -> Left e
+        Right (Left e) -> Left (Err e)
+        Right (Right a) -> Right a
+
+  pipelined p = p
 
-instance (QueryM m) => QueryA (ReaderT e m) where
+  unrecoverableErrorA (Pipeline me) =
+    Pipeline
+      ( me <&> \case
+          Right (Left e) -> Left . Unrecoverable . someServerError $ e
+          Right (Right a) -> Right a
+          Left e -> Left e
+      )
+
+-- Pipeline $ pure (Left (Unrecoverable (someServerError e)))
+
+instance (QueryM m e) => QueryA (ReaderT r m) e where
   statement q s = lift $ statement q s
 
-  unrecoverableError e = lift $ unrecoverableError e
+  throwErrA m = mapReaderT throwErrA m
+
+  pipelined p = lift $ pipelined p
+
+  unrecoverableErrorA me = mapReaderT unrecoverableErrorA me
 
-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
 
-  unrecoverableError e = lift $ unrecoverableError e
+  throwErrA m =
+    m >>= \case
+      Left e -> lift $ throwErr e
+      Right a -> pure a
 
-instance (QueryM m) => QueryM (MaybeT m) where
+  pipelined p = lift $ pipelined p
+
+  unrecoverableErrorA m =
+    m >>= \case
+      Left e -> lift $ unrecoverableError e
+      Right a -> pure a
+
+instance (QueryM m e) => QueryM (MaybeT m) e where
   transactionUnsafeIO io = lift $ transactionUnsafeIO io
 
+unrecoverableError :: (QueryA m e) => (ToServerError x, Loggable x, Show x) => x -> m a
+unrecoverableError e = unrecoverableErrorA (pure $ Left e)
+
+throwErr :: (QueryA m e, ToServerError e, Loggable e, Show e) => e -> m a
+throwErr e = throwErrA (pure $ Left e)
+
 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 +553,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