module Control.Concurrent.STM.Promise
(
Promise(..), an,
PromiseResult(..),
isAn, isUnfinished, isCancelled,
eitherResult, eitherResult', bothResults, bothResults'
) where
import Control.Monad.STM
import Data.Monoid
data Promise a = Promise
{ spawn :: IO ()
, cancel :: IO ()
, result :: STM (PromiseResult a)
}
deriving Functor
data PromiseResult a
= Unfinished
| Cancelled
| An a
deriving (Functor, Eq, Ord, Show)
an :: PromiseResult a -> a
an (An a) = a
an _ = error "an: on non-An result!"
isAn :: PromiseResult a -> Bool
isAn An{} = True
isAn _ = False
isUnfinished :: PromiseResult a -> Bool
isUnfinished Unfinished{} = True
isUnfinished _ = False
isCancelled :: PromiseResult a -> Bool
isCancelled Cancelled{} = True
isCancelled _ = False
eitherResult :: PromiseResult a -> PromiseResult a -> PromiseResult a
eitherResult (An a) _ = An a
eitherResult _ (An e) = An e
eitherResult Unfinished _ = Unfinished
eitherResult _ Unfinished = Unfinished
eitherResult _ _ = Cancelled
eitherResult' :: Monoid a => (a -> Bool) -> PromiseResult a -> PromiseResult a -> PromiseResult a
eitherResult' failure (An a) b | failure a = case b of An e -> An (a `mappend` e)
Unfinished -> Unfinished
Cancelled -> An a
| otherwise = An a
eitherResult' failure a (An e) | failure e = case a of An i -> An (i `mappend` e)
Unfinished -> Unfinished
Cancelled -> An e
| otherwise = An e
eitherResult' _ Unfinished _ = Unfinished
eitherResult' _ _ Unfinished = Unfinished
eitherResult' _ _ _ = Cancelled
bothResults :: PromiseResult a -> PromiseResult b -> PromiseResult (a,b)
bothResults (An a) (An e) = An (a,e)
bothResults Cancelled _ = Cancelled
bothResults _ Cancelled = Cancelled
bothResults _ _ = Unfinished
bothResults' :: Monoid a => (a -> Bool) -> PromiseResult a -> PromiseResult a -> PromiseResult a
bothResults' _ (An a) (An e) = An (a `mappend` e)
bothResults' failure (An a) _ | failure a = An a
bothResults' failure _ (An e) | failure e = An e
bothResults' _ Cancelled _ = Cancelled
bothResults' _ _ Cancelled = Cancelled
bothResults' _ _ _ = Unfinished