module Control.Monad.IOT (IOT, run, module Control.Monad.Trans, module Control.Monad.Identity, module Control.Monad.Morph) where
import GHC.IO (IO(IO))
import GHC.Prim
import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad
import Control.Applicative
import Control.Concurrent.MVar
import Data.Typeable
import Unsafe.Coerce
data State = State (State# RealWorld) !(MVar ())
newtype IOT m t = IOT (State -> m (State, t))
instance (Monad m) => Monad (IOT m) where
return x = IOT $ \s -> return (s, x)
IOT f >>= g = IOT $ \s -> f s >>= \(s, x) -> let IOT h = g x in h s
instance (Monad m) => Applicative (IOT m) where
pure = return
(<*>) = ap
instance (Monad m) => Functor (IOT m) where
fmap f m = m >>= return . f
err = error "IOT: double RealWorld use"
instance (Monad m) => MonadIO (IOT m) where
liftIO m = IOT $ \(State s mv) -> let
IO f = do
tryTakeMVar mv >>= maybe err return
liftM2 (,) m (newMVar ());
(# s', (x, mv') #) = f s in
return (State s' mv', x)
instance MonadTrans IOT where
lift m = IOT $ \s -> liftM (\x -> (s, x)) m
_hoist :: (forall t. m t -> n t) -> IOT m t -> IOT n t
_hoist f (IOT g) = IOT (f . g)
_squash :: (Monad m) => IOT (IOT m) t -> IOT m t
_squash (IOT f) = do
mv <- liftIO $ newMVar ()
(State _ m, x) <- IOT (\st@(State s _) -> let IOT g = f st in g (State s mv))
liftIO (tryTakeMVar m) >>= maybe err return
return x
instance MFunctor IOT where
hoist = _hoist
instance MMonad IOT where
embed f = _squash . _hoist f
run :: IOT Identity t -> IO t
run (IOT f) = do
mv <- newMVar ()
(m, x) <- IO (\s -> case f (State s mv) of
Identity (State s' m, x) -> (# s', (m, x) #))
tryTakeMVar m >>= maybe err return
return x