#if MIN_VERSION_base(4,7,0)
#endif
module Data.Promise
( Lazy
, runLazy
, runLazy_
, runLazyIO
, runLazyIO_
, Promise(..)
, promise, promise_
, (!=)
, demand
, BrokenPromise(..)
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad (ap)
import Control.Monad.Fix
import Control.Monad.Primitive
import Control.Monad.ST.Unsafe
import Data.Typeable
import System.IO.Unsafe
import Unsafe.Coerce
data BrokenPromise = BrokenPromise deriving (Show, Typeable)
instance Exception BrokenPromise
newtype Lazy s a = Lazy { getLazy :: forall x. MVar (Maybe (IO (K s x))) -> IO (K s a) }
deriving Typeable
#if MIN_VERSION_base(4,7,0)
type role Lazy nominal representational
#endif
instance Functor (Lazy s) where
fmap f (Lazy m) = Lazy $ \mv -> fmap go (m mv) where
go (Pure a) = Pure (f a)
go (Fulfilled v k) = Fulfilled v (fmap (fmap f) k)
instance Applicative (Lazy s) where
pure = return
(<*>) = ap
instance Monad (Lazy s) where
return a = Lazy $ \_ -> return $ Pure a
m >>= f = Lazy $ \mv -> let
go (Pure a) = getLazy (f a) mv
go (Fulfilled v k) = return $ Fulfilled v (k >>= go)
in getLazy m mv >>= go
instance PrimMonad (Lazy s) where
type PrimState (Lazy s) = s
primitive m = Lazy $ \_ -> Pure <$> unsafeSTToIO (primitive m)
instance MonadFix (Lazy s) where
mfix f = do
a <- promise_
r <- f (demand a)
a != r
return r
data Promise s a where
Promise :: MVar a -> a -> Promise s a
deriving Typeable
demand :: Promise s a -> a
demand (Promise _ a) = a
promise :: a -> Lazy s (Promise s a)
promise d = Lazy $ \mv -> do
v <- newEmptyMVar
return $ Pure $ Promise v (drive d mv v)
promise_ :: Lazy s (Promise s a)
promise_ = promise $ throw BrokenPromise
infixl 0 !=
(!=) :: Promise s a -> a -> Lazy s ()
Promise v _ != a = Lazy $ \ _ -> do
putMVar v a
return $ Fulfilled v $ return (Pure ())
runLazyIO :: (forall s. Promise s a -> Lazy s b) -> a -> IO a
runLazyIO f d = do
mv <- newEmptyMVar
v <- newEmptyMVar
let iv = Promise v (drive d mv v)
putMVar mv (Just (getLazy (f iv) mv))
return $ demand iv
runLazyIO_ :: (forall s. Promise s a -> Lazy s b) -> IO a
runLazyIO_ k = runLazyIO k $ throw BrokenPromise
runLazy :: (forall s. Promise s a -> Lazy s b) -> a -> a
runLazy f d = unsafePerformIO (runLazyIO f d)
runLazy_ :: (forall s. Promise s a -> Lazy s b) -> a
runLazy_ k = runLazy k $ throw BrokenPromise
meq :: MVar a -> MVar b -> Bool
meq a b = a == unsafeCoerce b
data K s a where
Pure :: a -> K s a
Fulfilled :: MVar x -> IO (K s a) -> K s a
instance Functor (K s) where
fmap f (Pure a) = Pure (f a)
fmap f (Fulfilled m k) = Fulfilled m (fmap (fmap f) k)
pump :: a -> IO (K s x) -> MVar a -> IO (Maybe (IO (K s x)))
pump d m v = m >>= \case
Pure _ -> return Nothing
Fulfilled u n
| meq u v -> return (Just n)
| otherwise -> pump d n v
drive :: a -> MVar (Maybe (IO (K s x))) -> MVar a -> a
drive d mv v = unsafePerformIO $ tryTakeMVar v >>= \case
Just a -> return a
Nothing -> takeMVar mv >>= \case
Nothing -> do
putMVar mv Nothing
return d
Just k -> tryTakeMVar v >>= \case
Just a -> do
putMVar mv (Just k)
return a
Nothing -> do
mk <- pump d k v
putMVar mv mk
case mk of
Nothing -> return d
Just _ -> takeMVar v