unwrap IO

UnwrapIO.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
module UnwrapIO where
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.State
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Writer
import Control.Monad.Trans.List

class MonadIO m => UnwrapIO m where
  type Unwrapped m a :: *
  unwrapIO_CB :: (a -> m b) -> m (a -> IO (Unwrapped m b))
  rewrapIO :: m (IO (Unwrapped m a)) -> m a

instance UnwrapIO IO where
  type Unwrapped IO a = a
  unwrapIO_CB = pure
  rewrapIO = join

instance UnwrapIO m => UnwrapIO (StateT s m) where
  type Unwrapped (StateT s m) a = Unwrapped m (a, s)
  unwrapIO_CB f = do
    s <- get
    lift . unwrapIO_CB $ \a -> runStateT (f a) s
  rewrapIO m = m >>= (lift . rewrapIO . pure) >>= state . const

instance UnwrapIO m => UnwrapIO (MaybeT m) where
  type Unwrapped (MaybeT m) a = Unwrapped m (Maybe a)
  unwrapIO_CB f = lift $ unwrapIO_CB $ \a -> runMaybeT (f a)
  rewrapIO m = MaybeT . rewrapIO . pure =<< m

instance UnwrapIO m => UnwrapIO (ExceptT e m) where
  type Unwrapped (ExceptT e m) a = Unwrapped m (Either e a)
  unwrapIO_CB f = lift $ unwrapIO_CB $ \a -> runExceptT (f a)
  rewrapIO m = ExceptT . rewrapIO . pure =<< m
  
instance UnwrapIO m => UnwrapIO (ReaderT r m) where
  type Unwrapped (ReaderT r m) a = Unwrapped m a
  unwrapIO_CB f = do
    r <- ask
    lift $ unwrapIO_CB $ \a -> runReaderT (f a) r
  rewrapIO m = lift . rewrapIO . pure =<< m

instance UnwrapIO m => UnwrapIO (IdentityT m) where
  type Unwrapped (IdentityT m) a = Unwrapped m a
  unwrapIO_CB f = IdentityT $ unwrapIO_CB $ runIdentityT . f
  rewrapIO (IdentityT m) = IdentityT $ rewrapIO m

-- | unwrap into a single IO value.
unwrapIO :: UnwrapIO m => m a -> m (IO (Unwrapped m a))
unwrapIO m = ($ ()) <$> unwrapIO_CB (const m)

-- | lift a function with a callback into the UnwrapIO monad.  This
-- saves you from having to unwrap and rewrap for simpler callback
-- functions.
liftCallback :: UnwrapIO m => ((a -> IO (Unwrapped m b)) -> IO (Unwrapped m b))
             -> (a -> m b) -> m b
liftCallback withCb cb = rewrapIO $ fmap withCb $ unwrapIO_CB cb

-- | like rewrap, but also turns an outer Either into an inner Either.
-- Useful with `try`.
rewrapLiftEither :: UnwrapIO m => IO (Either e (Unwrapped m b))
                 -> IO (m (Either e b))
rewrapLiftEither = fmap $ either (pure . Left) $
                   fmap Right . rewrapIO . pure . pure