{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Monad.WrapIO (MonadWrapIO(..)) where

import Control.Monad.Trans.Class

import Control.Monad.Wrap

-- | MonadWrapIO is analogous to 'MonadWrap', but where the wrapping
-- function is always of type @'IO' r -> 'IO' r@.  The point of
-- @MonadWrapIO@ is to go through as many nested monad transformers as
-- necessary to reach the 'IO' monad, so you don't have to keep track
-- of where you are in terms of monad nesting depth.
class (Monad m) => MonadWrapIO m a r | m a -> r where
    -- | @wrapIO@ is to 'wrap' as 'liftIO' is to 'lift'.
    wrapIO :: (IO r -> IO r) -> m a -> m a
    -- | @resultFIO@ is to 'resultF' as 'liftIO' is to 'lift'.
    resultFIO :: m (a -> r)
    -- | @resultIO@ is to 'result' as 'liftIO' is to 'lift'.
    resultIO :: a -> m r
    resultIO a = resultFIO >>= return . ($ a)

instance MonadWrapIO IO a a where
    wrapIO f = f
    resultFIO = return id
    resultIO = return

-- This implementation works for all wrapable monads, but requires
-- UndecidableInstances.
instance (Monad m, MonadTrans t, Monad (t m), MonadWrapIO m ar r,
          MonadWrap t a ar) => MonadWrapIO (t m) a r where
    wrapIO f = wrap (wrapIO f)
    resultFIO = do outer <- resultF
                   inner <- lift resultFIO
                   return $ inner . outer
    resultIO a = result a >>= lift . resultIO