module Control.Monad.IOT (IOT, run) where
import GHC.IO hiding (liftIO)
import GHC.Prim
import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad
import Control.Applicative
import Unsafe.Coerce
data Ret a = Ret (State# RealWorld) a
data Sequence m where
None :: Sequence m
Seq :: (Monad m) => IO (Ret ()) -> Sequence (IOT m)
runSequence :: (Monad m) => Sequence m -> State# RealWorld -> m (Ret ())
runSequence None s = return (Ret s ())
runSequence (Seq io) _ = liftIO io
newtype IOT m t = IOT (Sequence m -> State# RealWorld -> m (Ret t))
instance (Monad m) => Monad (IOT m) where
return x = IOT (\_ s -> return (Ret s x))
IOT f >>= g = IOT (\i s -> f i s >>= \(Ret s2 x) -> case g x of
IOT h -> h i s2)
instance (Monad m) => Applicative (IOT m) where
pure = return
(<*>) = ap
instance (Monad m) => Functor (IOT m) where
fmap f m = m >>= return . f
instance (Monad m) => MonadIO (IOT m) where
liftIO (IO f) = IOT (\_ s -> case f s of
(# s2, x #) -> return (Ret s2 x))
instance MonadTrans IOT where
lift m = IOT (\i s -> m >>= \x -> liftM (\(Ret s ()) -> Ret s x) (runSequence i s))
_squash (IOT f) = IOT (\i s -> let IOT g = f (Seq $ IO $ \s -> (# s, Ret s () #)) s in g i s >>= \(Ret _ pr) -> return pr)
_hoist :: (forall t. m t -> n t) -> IOT m t -> IOT n t
_hoist f (IOT g) = IOT (\i s -> f (g (unsafeCoerce i) s))
instance MMonad IOT where
embed f = _squash . _hoist f
instance MFunctor IOT where
hoist = _hoist
run :: IOT Identity t -> IO t
run (IOT f) = IO (\s -> case runIdentity (f None s) of
Ret s2 x -> (# s2, x #))