1 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 module Control.Invert 3 ( InvertM 4 , runInvert 5 , give 6 ) where 7 8 import Control.Monad (join) 9 import Control.Monad.IO.Class (MonadIO(..)) 10 import Control.Monad.Trans.Cont (ContT(..)) 11 import Data.IORef (newIORef, readIORef, writeIORef) 12 13 data InvertR b 14 = InvertCont b (IO (InvertR b)) 15 | InvertDone 16 17 instance Functor InvertR where 18 fmap f (InvertCont b c) = InvertCont (f b) (fmap f <$> c) 19 fmap _ InvertDone = InvertDone 20 21 invertCont :: InvertR b -> IO (InvertR b) 22 invertCont (InvertCont _ c) = c 23 invertCont i = return i 24 25 invertValue :: InvertR b -> Maybe b 26 invertValue (InvertCont b _) = Just b 27 invertValue _ = Nothing 28 29 newtype InvertM b a = InvertM { runInvertM :: ContT (InvertR b) IO a } 30 deriving (Functor, Applicative, Monad, MonadIO) 31 32 give :: b -> InvertM b () 33 give b = InvertM $ ContT $ \c -> return $ InvertCont b $ c () 34 35 -- |Convert an 'InvertM' action into an IO action that, when called repeatedly, returns 'Just' for each 'give', and 'Nothing' after the action completes. 36 runInvert :: InvertM b () -> IO (IO (Maybe b)) 37 runInvert m = do 38 r <- newIORef (runContT (runInvertM m) (\() -> return InvertDone)) 39 return $ do 40 v <- join $ readIORef r 41 writeIORef r $ invertCont v 42 return $ invertValue v