{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.PostgreSQL.Tx
( TxM(unsafeRunTxM)
, unsafeRunIOInTxM
, Tx(TxEnv, tx)
, UnsafeTx(unsafeIOTx)
, unsafeReaderIOTx
) where
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT), mapReaderT)
import GHC.TypeLits (ErrorMessage(Text), TypeError)
newtype TxM a = UnsafeTxM { unsafeRunTxM :: IO a }
deriving newtype (Functor, Applicative, Monad)
instance
( TypeError
('Text "MonadIO is banned in TxM; use 'unsafeRunIOInTxM' if you are sure this is safe IO")
) => MonadIO TxM
where
liftIO = undefined
unsafeRunIOInTxM :: IO a -> TxM a
unsafeRunIOInTxM = UnsafeTxM
class Tx (f :: * -> *) where
type TxEnv f :: *
tx :: TxEnv f -> f a -> TxM a
instance Tx (ReaderT r TxM) where
type TxEnv (ReaderT r TxM) = r
tx = flip runReaderT
class UnsafeTx (io :: * -> *) (t :: * -> *) | t -> io where
unsafeIOTx :: io a -> t a
instance UnsafeTx IO TxM where
unsafeIOTx = unsafeRunIOInTxM
instance (UnsafeTx io t) => UnsafeTx (ReaderT r io) (ReaderT r t) where
unsafeIOTx = mapReaderT unsafeIOTx
unsafeReaderIOTx
:: (UnsafeTx (ReaderT r io) (ReaderT r t))
=> (r -> io a) -> ReaderT r t a
unsafeReaderIOTx = unsafeIOTx . ReaderT