module Control.Future where
import Control.Applicative
import Control.Concurrent
import Data.IORef
data Progress a b = Making | Fixme a | Finished b
deriving (Functor, Show)
newtype Future a b = Future { runFuture :: IO (Progress [a] b) }
instance Functor (Future a) where
fmap f (Future a) = Future $ (fmap.fmap) f a
instance Applicative (Future a) where
pure = Future . return . Finished
Future fs <*> Future as =
Future $ do
fs' <- fs
as' <- as
return $ case (fs', as') of
(Finished f, Finished a) -> Finished $ f a
(Fixme f, Finished _) -> Fixme f
(Finished _, Fixme a) -> Fixme a
(Fixme f, Fixme a) -> Fixme (f ++ a)
_ -> Making
instance Alternative (Future a) where
empty = Future $ return Making
Future as <|> Future bs =
Future $ do
as' <- as
case as' of
Finished _ -> return as'
_ -> bs
instance Monad (Future a) where
return = pure
Future m >>= f =
Future $ do
m' <- m
case m' of
Finished x -> runFuture (f x)
Fixme l -> return (Fixme l)
Making -> return Making
type Future' = Future String
forceFuture :: Future a b -> ([a] -> IO b) -> IO b
forceFuture fu@(Future fs) f = do
fs' <- fs
case fs' of
Finished r -> return r
Fixme l -> f l
Making -> threadDelay 1000 >> forceFuture fu f
waitFuture :: Future a b -> IO (Progress [a] b)
waitFuture fu@(Future fs) = do
fs' <- fs
case fs' of
Making -> threadDelay 1000 >> waitFuture fu
otherwise -> return fs'
maybeChance :: Future a b -> ([a] -> IO b) -> IO (Maybe b)
maybeChance (Future fs) f = do
fs' <- fs
case fs' of
Finished r -> return $ Just r
Fixme l -> f l >>= return . Just
Making -> return Nothing
eitherChance :: Future a b -> IO (Progress [a] b)
eitherChance (Future fs) = fs
asyncIO :: ((Progress [a] b -> IO ()) -> IO ()) -> IO (Future a b)
asyncIO makeThread = do
ref <- newIORef Making
makeThread (writeIORef ref)
return $ Future $ readIORef ref
runAction :: Future a (IO b) -> IO ()
runAction (Future fs) = do
fs' <- fs
case fs' of
Finished run -> run >> return ()
otherwise -> return ()