{-# LANGUAGE RankNTypes #-}

{- |
Copyright : Flipstone Technology Partners 2023
License   : MIT
Stability : Stable

This module provides functions that can be used to implement
'Orville.PostgreSQL.MonadOrvilleControl' for monads that implement
'UL.MonadUnliftIO'. For example:

@
module MyMonad
  ( MyMonad
  ) where

import qualified Control.Monad.IO.Unlift as UnliftIO
import qualified Orville.PostgreSQL as O
import qualified Orville.PostgreSQL.UnliftIO as OrvilleUnliftIO

newtype MyMonad =
  ...
  deriving (UnliftIO.MonadUnliftIO)

instance O.MonadOrvilleControl MyMonad where
  liftWithConnection = OrvilleUnliftIO.liftWithConnectionViaUnliftIO
  liftCatch = OrvilleUnliftIO.liftCatchViaUnliftIO
  liftMask = OrvilleUnliftIO.liftMaskViaUnliftIO
@

@since 1.0.0.0
-}
module Orville.PostgreSQL.UnliftIO
  ( liftWithConnectionViaUnliftIO
  , liftCatchViaUnliftIO
  , liftMaskViaUnliftIO
  )
where

import qualified Control.Monad.IO.Unlift as UL

{- |
  'liftWithConnectionViaUnliftIO' can be used as the implementation of
  'Orville.PostgreSQL.liftWithConnection' for
  'Orville.PostgreSQL.MonadOrvilleControl' when the 'Monad' implements
  'UL.MonadUnliftIO'.

  @since 1.0.0.0
-}
liftWithConnectionViaUnliftIO ::
  UL.MonadUnliftIO m =>
  (forall a. (conn -> IO a) -> IO a) ->
  (conn -> m b) ->
  m b
liftWithConnectionViaUnliftIO :: forall (m :: * -> *) conn b.
MonadUnliftIO m =>
(forall a. (conn -> IO a) -> IO a) -> (conn -> m b) -> m b
liftWithConnectionViaUnliftIO forall a. (conn -> IO a) -> IO a
ioWithConn conn -> m b
action =
  ((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
UL.withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> (conn -> IO b) -> IO b
forall a. (conn -> IO a) -> IO a
ioWithConn (m b -> IO b
forall a. m a -> IO a
runInIO (m b -> IO b) -> (conn -> m b) -> conn -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. conn -> m b
action)

{- |
  'liftCatchViaUnliftIO' can be used as the implementation of
  'Orville.PostgreSQL.liftCatch' for 'Orville.PostgreSQL.MonadOrvilleControl'
  when the 'Monad' implements 'UL.MonadUnliftIO'.

  @since 1.0.0.0
-}
liftCatchViaUnliftIO ::
  UL.MonadUnliftIO m =>
  (forall a. IO a -> (e -> IO a) -> IO a) ->
  m b ->
  (e -> m b) ->
  m b
liftCatchViaUnliftIO :: forall (m :: * -> *) e b.
MonadUnliftIO m =>
(forall a. IO a -> (e -> IO a) -> IO a) -> m b -> (e -> m b) -> m b
liftCatchViaUnliftIO forall a. IO a -> (e -> IO a) -> IO a
ioCatch m b
action e -> m b
handler = do
  UnliftIO m
unlio <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
UL.askUnliftIO
  IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
UL.liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$
    IO b -> (e -> IO b) -> IO b
forall a. IO a -> (e -> IO a) -> IO a
ioCatch
      (UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
UL.unliftIO UnliftIO m
unlio m b
action)
      (\e
ex -> UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
UL.unliftIO UnliftIO m
unlio (e -> m b
handler e
ex))

{- |
  'liftMaskViaUnliftIO' can be used as the implementation of
  'Orville.PostgreSQL.liftMask' for 'Orville.PostgreSQL.MonadOrvilleControl'
  when the 'Monad' implements 'UL.MonadUnliftIO'.

  @since 1.0.0.0
-}
liftMaskViaUnliftIO ::
  UL.MonadUnliftIO m =>
  (forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b) ->
  ((forall a. m a -> m a) -> m c) ->
  m c
liftMaskViaUnliftIO :: forall (m :: * -> *) c.
MonadUnliftIO m =>
(forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. m a -> m a) -> m c) -> m c
liftMaskViaUnliftIO forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
ioMask (forall a. m a -> m a) -> m c
action = do
  UnliftIO m
unlio <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
UL.askUnliftIO
  IO c -> m c
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
UL.liftIO (IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$
    ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
ioMask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
      UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
UL.unliftIO
        UnliftIO m
unlio
        ((forall a. m a -> m a) -> m c
action (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
UL.liftIO (IO a -> m a) -> (m a -> IO a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> (m a -> IO a) -> m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
UL.unliftIO UnliftIO m
unlio))