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