module Graphics.FreeGame.Internal.Finalizer (FinalizerT(..), finalizer, runFinalizerT) where
import Control.Monad.IO.Class
import Control.Applicative
newtype FinalizerT m a = FinalizerT
{ unFinalizerT :: forall r. (a -> m r) -> (IO () -> r -> m r) -> m r }
finalizer :: Monad m => IO () -> FinalizerT m ()
finalizer m = FinalizerT $ \p f -> p () >>= f m
instance Functor (FinalizerT m) where
fmap f (FinalizerT g) = FinalizerT $ \p -> g (p . f)
instance Applicative (FinalizerT m) where
pure a = FinalizerT $ \p _ -> p a
FinalizerT ff <*> FinalizerT fa = FinalizerT $ \p f -> ff (\a -> fa (\b -> p (a b)) f) f
instance Monad (FinalizerT m) where
return a = FinalizerT $ \p _ -> p a
FinalizerT rf >>= k = FinalizerT $ \p f -> rf (\x -> unFinalizerT (k x) p f) f
instance MonadIO m => MonadIO (FinalizerT m) where
liftIO m = FinalizerT $ \r _ -> liftIO m >>= r
runFinalizerT :: MonadIO m => FinalizerT m a -> m a
runFinalizerT (FinalizerT z) = do
(fin, a) <- z (\a -> return (return (), a)) (\m (fs, r) -> return (m >> fs,r))
liftIO fin
return a