generated from tpl/purs
fix: correct implementations of MonadAff, MonadEffect, Fork, Bracket
This commit is contained in:
parent
f7b2e6ceae
commit
d2c3eba082
GPG Key ID:
6D4165AE4C928719
@ -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)
|
||||
|
||||
@ -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.Functor.Compose (Compose)
|
||||
import Data.Either (Either, blush, hush)
|
||||
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
|
||||
fork m = withRunInBase \f -> fork $ f m
|
||||
suspend m = withRunInBase \f -> suspend $ f m
|
||||
join f = lift $ join f
|
||||
instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork (Compose f (Either E)) (RE r m) where
|
||||
fork m = RE $ ReaderT \r -> lift $ Compose <$> fork (toEither m r)
|
||||
suspend m = RE $ ReaderT \r -> lift $ Compose <$> suspend (toEither m r)
|
||||
join f = liftEither =<< lift (join $ unwrap f)
|
||||
|
||||
instance (MonadKill Effect.Error f m) => MonadKill E f (RE r m) where
|
||||
kill e f = lift $ kill (toException e) f
|
||||
instance (MonadKill Effect.Error f m) => MonadKill E (Compose f (Either E)) (RE r m) where
|
||||
kill e f = lift $ kill (toException e) (unwrap f)
|
||||
|
||||
instance (MonadBracket Effect.Error f m) => MonadBracket E f (RE r m) where
|
||||
bracket acq rel m = withRunInBase \f -> bracket (f acq) (\c r -> f $ rel ((bracketCondError (pure <<< Other)) c) r) (f <<< m)
|
||||
instance (MonadEffect m, MonadBracket Effect.Error f m) => MonadBracket E (Compose f (Either E)) (RE r m) where
|
||||
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
|
||||
|
||||
@ -4,20 +4,26 @@ import Prelude
|
||||
|
||||
import Control.Monad.Cont (lift)
|
||||
import Control.Monad.Morph (hoist)
|
||||
import Control.Monad.Postgres (class MonadSession, streamIn, streamOut)
|
||||
import Control.Monad.Postgres (SessionT)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Maybe (Maybe)
|
||||
import Effect.Aff.Class (liftAff)
|
||||
import Effect.Aff.Class (class MonadAff, liftAff)
|
||||
import Effect.Aff.Postgres.Client as Client
|
||||
import Effect.Class (liftEffect)
|
||||
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.Core (Consumer, Producer)
|
||||
import Pipes.Node.Stream (fromReadable, fromWritable)
|
||||
import Pipes.Node.Stream as Pipe.Node
|
||||
|
||||
stdin :: forall m. MonadSession m => String -> Consumer (Maybe Buffer) m Unit
|
||||
stdin :: forall m. MonadAff m => String -> Consumer (Maybe Buffer) (SessionT m) Unit
|
||||
stdin q = do
|
||||
stream <- lift $ streamIn q
|
||||
hoist liftAff $ fromWritable $ O.unsafeFromBufferWritable stream
|
||||
client <- lift ask
|
||||
stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.execWithStdin q client
|
||||
hoist liftAff $ Pipe.Node.fromWritable $ Node.Stream.Object.unsafeFromBufferWritable stream
|
||||
|
||||
stdout :: forall m. MonadSession m => String -> Producer (Maybe Buffer) m Unit
|
||||
stdout :: forall m. MonadAff m => String -> Producer (Maybe Buffer) (SessionT m) Unit
|
||||
stdout q = do
|
||||
stream <- lift $ streamOut q
|
||||
hoist liftAff $ fromReadable $ O.unsafeFromBufferReadable stream
|
||||
client <- lift ask
|
||||
stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.queryWithStdout q client
|
||||
hoist liftAff $ Pipe.Node.fromReadable $ Node.Stream.Object.unsafeFromBufferReadable stream
|
||||
|
||||
135
test/Test.Effect.Postgres.Error.purs
Normal file
135
test/Test.Effect.Postgres.Error.purs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user