fix: correct implementations of MonadAff, MonadEffect, Fork, Bracket

README.md

@@ -259,59 +259,59 @@ the api of [`node-postgres`]:
   - release clients with [`Pool.release`] or [`Pool.destroy`]
   - release with [`Pool.end`]
 
-[`Pool`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#t:Pool
+[`Pool`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#t:Pool
-[`Config`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#t:Config
+[`Config`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#t:Config
-[`Pool.make`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#v:make
+[`Pool.make`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#v:make
-[`Pool.end`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#v:end
+[`Pool.end`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#v:end
-[`Pool.connect`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#v:connect
+[`Pool.connect`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#v:connect
-[`Pool.destroy`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#v:destroy
+[`Pool.destroy`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#v:destroy
-[`Pool.release`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Pool#v:release
+[`Pool.release`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Pool#v:release
 
-[`Client`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#t:Client
+[`Client`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#t:Client
-[`Client.end`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:end
+[`Client.end`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:end
-[`Client.make`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:make
+[`Client.make`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:make
-[`Client.connected`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:connected
+[`Client.connected`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:connected
-[`Client.query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:query
+[`Client.query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:query
-[`Client.queryRaw`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:queryRaw
+[`Client.queryRaw`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:queryRaw
-[`Client.exec`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Effect.Aff.Postgres.Client#v:exec
+[`Client.exec`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Effect.Aff.Postgres.Client#v:exec
 
-[`Range`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Range#t:Range
+[`Range`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Range#t:Range
-[`Range.gt`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Range#v:gt
+[`Range.gt`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Range#v:gt
-[`Range.gte`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Range#v:gte
+[`Range.gte`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Range#v:gte
-[`Range.lt`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Range#v:lt
+[`Range.lt`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Range#v:lt
-[`Range.lte`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Range#v:lte
+[`Range.lte`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Range#v:lte
 
-[`Raw`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Raw#t:Raw
+[`Raw`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Raw#t:Raw
-[`Null`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Raw#t:Null
+[`Null`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Raw#t:Null
 
-[`Serialize`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres#t:Serialize
+[`Serialize`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres#t:Serialize
-[`Deserialize`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres#t:Deserialize
+[`Deserialize`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres#t:Deserialize
-[`Rep`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres#t:Rep
+[`Rep`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres#t:Rep
-[`modifyPgTypes`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres#v:modifyPgTypes
+[`modifyPgTypes`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres#v:modifyPgTypes
 
-[`Result`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Result#t:Result
+[`Result`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Result#t:Result
-[`FromRow`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Result#t:FromRow
+[`FromRow`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Result#t:FromRow
-[`FromRows`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Result#t:FromRows
+[`FromRows`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Result#t:FromRows
 
-[`Query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Query#t:Query
+[`Query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Query#t:Query
-[`AsQuery`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Query#t:AsQuery
+[`AsQuery`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Query#t:AsQuery
 
-[`Query.Builder`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Query.Builder#t:Builder
+[`Query.Builder`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Query.Builder#t:Builder
-[`Query.Builder.param`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Query.Builder#v:param
+[`Query.Builder.param`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Query.Builder#v:param
-[`Query.Builder.build`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Data.Postgres.Query.Builder#v:build
+[`Query.Builder.build`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Data.Postgres.Query.Builder#v:build
 
-[`MonadCursor`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#t:MonadCursor
+[`MonadCursor`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#t:MonadCursor
-[`MonadSession`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#t:MonadSession
+[`MonadSession`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#t:MonadSession
-[`CursorT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#t:CursorT
+[`CursorT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#t:CursorT
-[`SessionT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#t:SessionT
+[`SessionT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#t:SessionT
-[`PostgresT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#t:PostgresT
+[`PostgresT`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#t:PostgresT
-[`cursor`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:cursor
+[`cursor`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:cursor
-[`session`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:session
+[`session`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:session
-[`transaction`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:transaction
+[`transaction`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:transaction
-[`runPostgres`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:runPostgres
+[`runPostgres`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:runPostgres
-[`query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:query
+[`query`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:query
-[`exec`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:exec
+[`exec`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:exec
-[`exec_`]: https://pursuit.purescript.org//////////////////////////////////////////////////////packages/purescript-postgresql/2.0.11/Control.Monad.Postgres#v:exec_
+[`exec_`]: https://pursuit.purescript.org//////////////////////////////////////////////////////////packages/purescript-postgresql/2.0.15/Control.Monad.Postgres#v:exec_
 
 [`node-postgres`]: https://node-postgres.com/
 [`pg-types`]: https://github.com/brianc/node-pg-types/

spago.yaml

@@ -1,7 +1,7 @@
 package:
   name: postgresql
   publish:
-    version: '2.0.11'
+    version: '2.0.15'
     license: 'GPL-3.0-or-later'
     location:
       githubOwner: 'cakekindel'

src/Control.Monad.Postgres.Session.purs

@@ -3,7 +3,6 @@ module Control.Monad.Postgres.Session where
 import Prelude hiding (join)
 
 import Control.Monad.Error.Class (class MonadError, catchError, throwError)
-import Control.Monad.Fork.Class (class MonadBracket)
 import Control.Monad.Morph (hoist)
 import Control.Monad.Reader (ask)
 import Control.Monad.Trans.Class (lift)
@@ -17,9 +16,7 @@ import Effect.Aff.Postgres.Client (Client)
 import Effect.Aff.Postgres.Client as Client
 import Effect.Aff.Postgres.Pool (Pool)
 import Effect.Aff.Postgres.Pool as Pool
-import Effect.Aff.Unlift (class MonadUnliftAff)
 import Effect.Class (class MonadEffect, liftEffect)
-import Effect.Exception as Effect
 import Effect.Postgres.Error (RE)
 import Effect.Postgres.Error as E
 import Effect.Postgres.Error.Except as X

src/Effect.Postgres.Error.Except.purs

@@ -4,6 +4,7 @@ import Prelude
 
 import Control.Monad.Error.Class (class MonadError, class MonadThrow, liftEither, try)
 import Control.Monad.Except (ExceptT(..), runExceptT)
+import Control.Monad.Morph (hoist)
 import Data.Bifunctor (lmap)
 import Data.Either (Either)
 import Data.Postgres (RepT)
@@ -29,11 +30,15 @@ withEither e m = ExceptT $ map (lmap $ pure <<< e) $ m
 exception :: forall m a. MonadError Effect.Error m => m a -> Except m a
 exception = with Other
 
-parsing :: forall m a. MonadEffect m => Query -> RepT a -> Except m a
-parsing q = withEither (Deserializing q) <<< liftEffect <<< runExceptT
-
-printing :: forall m a. MonadEffect m => RepT a -> Except m a
-printing = withEither Serializing <<< liftEffect <<< runExceptT
-
 executing :: forall m a. MonadError Effect.Error m => Query -> m a -> Except m a
 executing q = with (Executing q)
+
+parsing :: forall m a. MonadEffect m => Query -> RepT a -> Except m a
+parsing q m = do
+  e <- hoist liftEffect $ exception $ runExceptT m
+  withEither (Deserializing q) (pure e)
+
+printing :: forall m a. MonadEffect m => RepT a -> Except m a
+printing m = do
+  e <- hoist liftEffect $ exception $ runExceptT m
+  withEither Serializing (pure e)

src/Effect.Postgres.Error.RE.purs

@@ -5,26 +5,32 @@ import Prelude hiding (join)
 import Control.Alt (class Alt)
 import Control.Alternative (class Alternative, class Plus)
 import Control.Monad.Base (class MonadBase)
-import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, liftEither, throwError)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, liftEither, liftMaybe, throwError)
 import Control.Monad.Except (ExceptT, runExceptT)
-import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, BracketCondition, bracket, fork, join, kill, never, suspend, uninterruptible)
+import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, fork, join, kill, never, suspend, uninterruptible)
 import Control.Monad.Fork.Class as Bracket
 import Control.Monad.Morph (class MFunctor, class MMonad, embed, hoist)
-import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), runReaderT)
+import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), ask, runReaderT)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
-import Control.Monad.Unlift (class MonadUnlift, withRunInBase)
+import Control.Monad.Unlift (class MonadUnlift)
 import Control.Parallel (class Parallel, parallel, sequential)
+import Data.Array.NonEmpty as Array.NonEmpty
 import Data.Bifunctor (lmap)
-import Data.Either (Either)
+import Data.Either (Either, blush, hush)
-import Data.Functor.Compose (Compose)
+import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
-import Effect.Aff.Class (class MonadAff)
+import Data.Traversable (for_, traverse_)
+import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Aff.Unlift (class MonadUnliftAff, withRunInAff)
-import Effect.Class (class MonadEffect)
+import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Exception as Effect
+import Effect.Exception as Exception
 import Effect.Postgres.Error.Common (E, Error(..), toException)
 import Effect.Postgres.Error.Except (Except)
+import Effect.Postgres.Error.Except as E
+import Effect.Ref as Ref
 import Effect.Unlift (class MonadUnliftEffect, withRunInEffect)
 
 -- | `ReaderT` with `ExceptT E`
@@ -67,10 +73,14 @@ derive newtype instance Monad m => Bind (RE r m)
 derive newtype instance Monad m => Monad (RE r m)
 derive newtype instance Monad m => MonadError E (RE r m)
 derive newtype instance Monad m => MonadThrow E (RE r m)
-derive newtype instance MonadEffect m => MonadEffect (RE r m)
-derive newtype instance MonadAff m => MonadAff (RE r m)
 derive newtype instance MonadRec m => MonadRec (RE r m)
 
+instance MonadEffect m => MonadEffect (RE r m) where
+  liftEffect m = hoist liftEffect $ liftExcept $ E.exception m
+
+instance MonadAff m => MonadAff (RE r m) where
+  liftAff m = hoist liftAff $ liftExcept $ E.exception m
+
 instance (Monad m, Parallel p m) => Parallel (ParRE r p) (RE r m) where
   parallel = wrap <<< parallel <<< unwrap
   sequential = wrap <<< sequential <<< unwrap
@@ -101,20 +111,47 @@ instance (MonadBase m (RE r m), MonadThrow Effect.Error m) => MonadUnlift m (RE
 instance Monad m => MonadBase m (RE r m) where
   liftBase = lift
 
-instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork f (RE r m) where
+instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork (Compose f (Either E)) (RE r m) where
-  fork m = withRunInBase \f -> fork $ f m
+  fork m = RE $ ReaderT \r -> lift $ Compose <$> fork (toEither m r)
-  suspend m = withRunInBase \f -> suspend $ f m
+  suspend m = RE $ ReaderT \r -> lift $ Compose <$> suspend (toEither m r)
-  join f = lift $ join f
+  join f = liftEither =<< lift (join $ unwrap f)
 
-instance (MonadKill Effect.Error f m) => MonadKill E f (RE r m) where
+instance (MonadKill Effect.Error f m) => MonadKill E (Compose f (Either E)) (RE r m) where
-  kill e f = lift $ kill (toException e) f
+  kill e f = lift $ kill (toException e) (unwrap f)
 
-instance (MonadBracket Effect.Error f m) => MonadBracket E f (RE r m) where
+instance (MonadEffect m, MonadBracket Effect.Error f m) => MonadBracket E (Compose f (Either E)) (RE r m) where
-  bracket acq rel m = withRunInBase \f -> bracket (f acq) (\c r -> f $ rel ((bracketCondError (pure <<< Other)) c) r) (f <<< m)
+  bracket acq rel go = do
+    r <- ask
+
+    errs <- liftEffect $ Ref.new []
+
+    let
+      eErrsEmpty = pure $ Other $ Exception.error "no errors"
+      appendErrs = liftEffect <<< flip Ref.modify_ errs <<< (<>) <<< Array.NonEmpty.toArray
+      readErrs = liftEffect $ Array.NonEmpty.fromArray <$> Ref.read errs
+
+      run' :: forall a. RE r m a -> m (Maybe a)
+      run' m = do
+        either <- toEither m r
+        traverse_ appendErrs $ blush either
+        pure $ hush either
+
+      rel' _ Nothing = pure unit
+      rel' (Bracket.Failed e) (Just a) = void $ run' $ rel (Bracket.Failed $ pure $ Other e) a
+      rel' (Bracket.Killed e) (Just a) = void $ run' $ rel (Bracket.Killed $ pure $ Other e) a
+      rel' (Bracket.Completed (Just ret)) (Just a) = void $ run' $ rel (Bracket.Completed ret) a
+      rel' (Bracket.Completed Nothing) (Just a) = void $ run' do
+        errs' <- fromMaybe eErrsEmpty <$> readErrs
+        rel (Bracket.Failed errs') a
+
+      acq' = run' acq
+
+      go' (Just a) = run' $ go a
+      go' Nothing = pure Nothing
+
+    ret <- lift $ bracket acq' rel' go'
+    errs' <- readErrs
+    for_ errs' throwError
+    liftMaybe eErrsEmpty ret
   uninterruptible = hoist uninterruptible
   never = lift never
-
-bracketCondError :: forall ea eb a. (ea -> eb) -> BracketCondition ea a -> BracketCondition eb a
-bracketCondError _ (Bracket.Completed a) = Bracket.Completed a
-bracketCondError f (Bracket.Failed a) = Bracket.Failed $ f a
-bracketCondError f (Bracket.Killed a) = Bracket.Killed $ f a

src/Pipes.Postgres.purs

@@ -3,63 +3,27 @@ module Pipes.Postgres where
 import Prelude
 
 import Control.Monad.Cont (lift)
-import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
 import Control.Monad.Morph (hoist)
-import Control.Monad.Postgres (PostgresT)
+import Control.Monad.Postgres (SessionT)
 import Control.Monad.Reader (ask)
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Aff.Postgres.Client as Client
-import Effect.Aff.Postgres.Pool as Pool
 import Effect.Class (liftEffect)
-import Effect.Exception (Error)
 import Effect.Postgres.Error.RE as RE
 import Node.Buffer (Buffer)
-import Node.Stream.Object as O
+import Node.Stream.Object as Node.Stream.Object
-import Pipes ((>->))
 import Pipes.Core (Consumer, Producer)
-import Pipes.Node.Stream (fromReadable, fromWritable)
+import Pipes.Node.Stream as Pipe.Node
-import Pipes.Prelude as Pipes
 
-stdin
+stdin :: forall m. MonadAff m => String -> Consumer (Maybe Buffer) (SessionT m) Unit
-  :: forall m
-   . MonadAff m
-  => MonadError Error m
-  => String
-  -> Consumer (Maybe Buffer) (PostgresT m) Unit
 stdin q = do
-  pool <- lift ask
+  client <- lift ask
-  client <- lift $ RE.liftExcept $ hoist liftAff $ Pool.connect pool
   stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.execWithStdin q client
-  lift $ RE.liftExcept $ hoist liftAff $ void $ Client.exec "begin" client
+  hoist liftAff $ Pipe.Node.fromWritable $ Node.Stream.Object.unsafeFromBufferWritable stream
-  let
-    releaseOnEOS Nothing = do
-      RE.liftExcept $ hoist liftAff $ void $ Client.exec "commit" client
-      RE.liftExcept $ hoist liftEffect $ Pool.release pool client
-      pure Nothing
-    releaseOnEOS (Just a) = pure (Just a)
 
-    pipe = Pipes.mapM releaseOnEOS >-> hoist lift (fromWritable $ O.unsafeFromBufferWritable stream)
+stdout :: forall m. MonadAff m => String -> Producer (Maybe Buffer) (SessionT m) Unit
-    err e = lift do
-      RE.liftExcept $ hoist liftAff $ void $ Client.exec "rollback" client
-      RE.liftExcept $ hoist liftEffect $ Pool.release pool client
-      throwError e
-
-  catchError pipe err
-
-stdout
-  :: forall m
-   . MonadAff m
-  => MonadThrow Error m
-  => String
-  -> Producer (Maybe Buffer) (PostgresT m) Unit
 stdout q = do
-  pool <- lift ask
+  client <- lift ask
-  client <- lift $ RE.liftExcept $ hoist liftAff $ Pool.connect pool
   stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.queryWithStdout q client
-  let
+  hoist liftAff $ Pipe.Node.fromReadable $ Node.Stream.Object.unsafeFromBufferReadable stream
-    releaseOnEOS :: Maybe Buffer -> PostgresT m (Maybe Buffer)
-    releaseOnEOS Nothing = RE.liftExcept $ hoist liftEffect $ Pool.release pool client $> Nothing
-    releaseOnEOS (Just a) = pure (Just a)
-  hoist lift (fromReadable (O.unsafeFromBufferReadable stream))
-    >-> Pipes.mapM releaseOnEOS

test/Test.Effect.Postgres.Error.purs

@@ -0,0 +1,135 @@
+module Test.Effect.Postgres.Error where
+
+import Prelude hiding (join)
+
+import Control.Monad.Cont (lift)
+import Control.Monad.Error.Class (throwError)
+import Control.Monad.Fork.Class (bracket, fork, join)
+import Control.Parallel (parOneOf, parSequence)
+import Data.Either (isLeft)
+import Data.Newtype (wrap)
+import Data.Postgres (deserialize)
+import Data.Postgres.Query (stringQuery)
+import Data.Postgres.Raw (Raw)
+import Effect.Aff (Aff, delay)
+import Effect.Aff.Class (liftAff)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exn
+import Effect.Postgres.Error (Error(..))
+import Effect.Postgres.Error.Except as E
+import Effect.Postgres.Error.RE (RE)
+import Effect.Postgres.Error.RE as RE
+import Test.Common (withPoolClient)
+import Test.Spec (Spec, around, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+import Unsafe.Coerce (unsafeCoerce)
+
+spec :: Spec Unit
+spec =
+  around withPoolClient $ describe "Effect.Postgres.Error" do
+    describe "Except" do
+      it "catches Aff" $ const do
+        either <- E.toEither $ E.exception (throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "catches Effect" $ const do
+        either <- liftEffect $ E.toEither $ E.exception (throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "catches RepT" $ const do
+        let
+          parse = deserialize @Int (unsafeCoerce "foo" :: Raw)
+        either <- liftEffect $ E.toEither $ E.parsing (stringQuery "select 'foo'") parse
+        isLeft either `shouldEqual` true
+      it "catches Effect exception in RepT" $ const do
+        let
+          parse = lift $ throwError $ Exn.error "foo"
+        either <- liftEffect $ E.toEither $ E.parsing (stringQuery "select 'foo'") parse
+        isLeft either `shouldEqual` true
+    describe "RE" do
+      it "liftAff catches exceptions" $ const do
+        either <- RE.toEither (liftAff $ throwError $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "liftEffect catches exceptions" $ const do
+        either <- RE.toEither (liftEffect $ throwError $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "liftExcept catches exceptions" $ const do
+        either <- RE.toEither (throwError $ pure $ Other $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "fork > join catches Fiber exceptions" $ const do
+        either <- flip RE.toEither unit do
+          fiber <- fork (liftAff $ throwError $ Exn.error "foo") :: RE Unit Aff _
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "bracket catches error in acq" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (liftAff $ throwError $ Exn.error "foo")
+              (const $ const $ pure unit)
+              (const $ pure unit)
+        isLeft either `shouldEqual` true
+      it "bracket catches error in rel" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (pure unit)
+              (const $ const $ liftAff $ throwError $ Exn.error "foo")
+              (const $ pure unit)
+        isLeft either `shouldEqual` true
+      it "bracket catches error in go" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (pure unit)
+              (const $ const $ pure unit)
+              (const $ liftAff $ throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in acq" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+                (liftAff $ throwError $ Exn.error "foo")
+                (const $ const $ pure unit)
+                (const $ pure unit)
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in rel" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+              (pure unit)
+              (const $ const $ liftAff $ throwError $ Exn.error "foo")
+              (const $ pure unit)
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in go" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+              (pure unit)
+              (const $ const $ pure unit)
+              (const $ liftAff $ throwError $ Exn.error "foo")
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "catches errors in `parSequence`" $ const do
+        either <-
+          flip RE.toEither unit
+            $ parSequence
+            $ [ liftAff $ throwError $ Exn.error "a"
+              , pure "a"
+              ]
+        isLeft either `shouldEqual` true
+      it "catches errors in `parOneOf`" $ const do
+        either <-
+          flip RE.toEither unit
+            $ parOneOf
+            $ [ liftAff $ throwError $ Exn.error "a"
+              , liftAff $ throwError $ Exn.error "b"
+              ]
+        isLeft either `shouldEqual` true

test/Test.Main.purs

@@ -25,6 +25,7 @@ import Test.Data.Postgres as Test.Data.Postgres
 import Test.Data.Postgres.Custom as Test.Data.Postgres.Custom
 import Test.Data.Postgres.Interval as Test.Data.Postgres.Interval
 import Test.Effect.Postgres.Client as Test.Effect.Postgres.Client
+import Test.Effect.Postgres.Error as Test.Effect.Postgres.Error
 import Test.Effect.Postgres.Pool as Test.Effect.Postgres.Pool
 import Test.Spec.Reporter (specReporter)
 import Test.Spec.Runner (runSpec)
@@ -64,6 +65,7 @@ main = launchAff_ do
   bracket spawnDb killDb
     $ const
     $ runSpec [ specReporter ] do
+        Test.Effect.Postgres.Error.spec
         Test.Data.Postgres.Custom.spec
         Test.Data.Postgres.spec
         Test.Data.Postgres.Interval.spec