module Control.Concurrent.Free
( F, liftF
, hoist
, retractA, retractM
, foldA, foldM
, foldConcurrentM
, retractConcurrentIO, foldConcurrentIO
) where
import Control.Applicative (liftA2)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception (SomeException(..), try, throwIO)
import Control.Monad (join)
data F f a where
Pure :: a -> F f a
Lift :: f x -> (x -> a) -> F f a
Ap :: F f a -> F f (a -> b) -> F f b
Join :: F f (F f a) -> F f a
instance Functor (F f) where
fmap f (Pure a) = Pure (f a)
fmap f (Lift x g) = Lift x (f . g)
fmap f (Ap x y) = Ap x (fmap f <$> y)
fmap f (Join x) = Join (fmap f <$> x)
instance Applicative (F f) where
pure = Pure
Pure f <*> y = fmap f y
x <*> y = Ap y x
instance Monad (F f) where
return = pure
Pure x >>= f = f x
x >>= f = Join (fmap f x)
x >> y = x *> y
liftF :: f a -> F f a
liftF x = Lift x id
hoist :: (forall a. f a -> g a) -> F f a -> F g a
hoist f (Pure a) = Pure a
hoist f (Lift x g) = Lift (f x) g
hoist f (Ap x y) = Ap (hoist f x) (hoist f y)
hoist f (Join x) = Join (hoist f (fmap (hoist f) x))
retractA :: Applicative f => F f a -> Maybe (f a)
retractA (Pure a) = Just (pure a)
retractA (Lift x g) = Just (fmap g x)
retractA (Ap x y) = liftA2 (<*>) (retractA y) (retractA x)
retractA (Join x) = Nothing
retractM :: Monad f => F f a -> f a
retractM (Pure a) = pure a
retractM (Lift x g) = fmap g x
retractM (Ap x y) = retractM y <*> retractM x
retractM (Join x) = join . retractM $ fmap retractM x
foldConcurrentM :: Monad m => (forall x. f x -> m (m x)) -> F f a -> m a
foldConcurrentM run (Pure a) = return a
foldConcurrentM run (Lift x g) = run x >>= fmap g
foldConcurrentM run (Ap x y) =
foldConcurrentM run y <*> foldConcurrentM run x
foldConcurrentM run (Join x) = do
y <- foldConcurrentM run x
foldConcurrentM run y
retractConcurrentIO :: F IO a -> IO a
retractConcurrentIO = foldConcurrentM $ \action -> do
v <- newEmptyMVar
forkIO $ try action >>= putMVar v
return $ do
r <- takeMVar v
case r of
Left (SomeException e) -> throwIO e
Right a -> return a
foldA :: Applicative g => (forall x. f x -> g x) -> F f a -> Maybe (g a)
foldA f = retractA . hoist f
foldM :: Monad m => (forall x. f x -> m x) -> F f a -> m a
foldM f = retractM . hoist f
foldConcurrentIO :: (forall x. f x -> IO x) -> F f a -> IO a
foldConcurrentIO f = retractConcurrentIO . hoist f