{-# LANGUAGE DeriveFunctor #-}
module Control.Concurrent.Conceit (
Conceit (..)
, _Conceit
, _runConceit
, conceit
, mapConceit
, conceit'
) where
import Data.Void
import Data.Bifunctor
import Data.Semigroup
import Data.Monoid (Monoid,mempty,mappend)
import Data.Traversable
import Control.Applicative
import Control.Monad (forever)
import Control.Exception
import Control.Concurrent
newtype Conceit e a = Conceit { Conceit e a -> IO (Either e a)
runConceit :: IO (Either e a) } deriving a -> Conceit e b -> Conceit e a
(a -> b) -> Conceit e a -> Conceit e b
(forall a b. (a -> b) -> Conceit e a -> Conceit e b)
-> (forall a b. a -> Conceit e b -> Conceit e a)
-> Functor (Conceit e)
forall a b. a -> Conceit e b -> Conceit e a
forall a b. (a -> b) -> Conceit e a -> Conceit e b
forall e a b. a -> Conceit e b -> Conceit e a
forall e a b. (a -> b) -> Conceit e a -> Conceit e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Conceit e b -> Conceit e a
$c<$ :: forall e a b. a -> Conceit e b -> Conceit e a
fmap :: (a -> b) -> Conceit e a -> Conceit e b
$cfmap :: forall e a b. (a -> b) -> Conceit e a -> Conceit e b
Functor
instance Bifunctor Conceit where
bimap :: (a -> b) -> (c -> d) -> Conceit a c -> Conceit b d
bimap a -> b
f c -> d
g (Conceit IO (Either a c)
x) = IO (Either b d) -> Conceit b d
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either b d) -> Conceit b d) -> IO (Either b d) -> Conceit b d
forall a b. (a -> b) -> a -> b
$ (Either a c -> Either b d) -> IO (Either a c) -> IO (Either b d)
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA ((a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) IO (Either a c)
x
instance Applicative (Conceit e) where
pure :: a -> Conceit e a
pure = IO (Either e a) -> Conceit e a
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e a) -> Conceit e a)
-> (a -> IO (Either e a)) -> a -> Conceit e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> IO (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> IO (Either e a))
-> (a -> Either e a) -> a -> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Conceit IO (Either e (a -> b))
fs <*> :: Conceit e (a -> b) -> Conceit e a -> Conceit e b
<*> Conceit IO (Either e a)
as =
IO (Either e b) -> Conceit e b
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e b) -> Conceit e b) -> IO (Either e b) -> Conceit e b
forall a b. (a -> b) -> a -> b
$ (Either e (a -> b, a) -> Either e b)
-> IO (Either e (a -> b, a)) -> IO (Either e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a -> b, a) -> b) -> Either e (a -> b, a) -> Either e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a -> b
f, a
a) -> a -> b
f a
a)) (IO (Either e (a -> b, a)) -> IO (Either e b))
-> IO (Either e (a -> b, a)) -> IO (Either e b)
forall a b. (a -> b) -> a -> b
$ IO (Either e (a -> b))
-> IO (Either e a) -> IO (Either e (a -> b, a))
forall e a b.
IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
conceit IO (Either e (a -> b))
fs IO (Either e a)
as
instance Alternative (Conceit e) where
empty :: Conceit e a
empty = IO (Either e a) -> Conceit e a
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e a) -> Conceit e a) -> IO (Either e a) -> Conceit e a
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either e a)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound)
Conceit IO (Either e a)
as <|> :: Conceit e a -> Conceit e a -> Conceit e a
<|> Conceit IO (Either e a)
bs =
IO (Either e a) -> Conceit e a
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e a) -> Conceit e a) -> IO (Either e a) -> Conceit e a
forall a b. (a -> b) -> a -> b
$ (Either e (Either a a) -> Either e a)
-> IO (Either e (Either a a)) -> IO (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either a a -> a) -> Either e (Either a a) -> Either e a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id)) (IO (Either e (Either a a)) -> IO (Either e a))
-> IO (Either e (Either a a)) -> IO (Either e a)
forall a b. (a -> b) -> a -> b
$ IO (Either e a) -> IO (Either e a) -> IO (Either e (Either a a))
forall e a b.
IO (Either e a) -> IO (Either e b) -> IO (Either e (Either a b))
race IO (Either e a)
as IO (Either e a)
bs
instance (Semigroup a) => Semigroup (Conceit e a) where
Conceit e a
c1 <> :: Conceit e a -> Conceit e a -> Conceit e a
<> Conceit e a
c2 = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> Conceit e a -> Conceit e (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conceit e a
c1 Conceit e (a -> a) -> Conceit e a -> Conceit e a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Conceit e a
c2
instance (Monoid a) => Monoid (Conceit e a) where
mempty :: Conceit e a
mempty = IO (Either e a) -> Conceit e a
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e a) -> Conceit e a)
-> (a -> IO (Either e a)) -> a -> Conceit e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> IO (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> IO (Either e a))
-> (a -> Either e a) -> a -> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Conceit e a) -> a -> Conceit e a
forall a b. (a -> b) -> a -> b
$ a
forall a. Monoid a => a
mempty
_Conceit :: IO a -> Conceit e a
_Conceit :: IO a -> Conceit e a
_Conceit = IO (Either e a) -> Conceit e a
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e a) -> Conceit e a)
-> (IO a -> IO (Either e a)) -> IO a -> Conceit e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either e a) -> IO a -> IO (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
_runConceit :: Conceit Void a -> IO a
_runConceit :: Conceit Void a -> IO a
_runConceit Conceit Void a
c = (Void -> a) -> (a -> a) -> Either Void a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> a
forall a. Void -> a
absurd a -> a
forall a. a -> a
id (Either Void a -> a) -> IO (Either Void a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conceit Void a -> IO (Either Void a)
forall e a. Conceit e a -> IO (Either e a)
runConceit Conceit Void a
c
mapConceit :: (Traversable t) => (a -> IO (Either e b)) -> t a -> IO (Either e (t b))
mapConceit :: (a -> IO (Either e b)) -> t a -> IO (Either e (t b))
mapConceit a -> IO (Either e b)
f = Conceit e (t b) -> IO (Either e (t b))
forall e a. Conceit e a -> IO (Either e a)
runConceit (Conceit e (t b) -> IO (Either e (t b)))
-> (t a -> Conceit e (t b)) -> t a -> IO (Either e (t b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Conceit e b) -> Conceit e (t b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (t (Conceit e b) -> Conceit e (t b))
-> (t a -> t (Conceit e b)) -> t a -> Conceit e (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Conceit e b) -> t a -> t (Conceit e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IO (Either e b) -> Conceit e b
forall e a. IO (Either e a) -> Conceit e a
Conceit (IO (Either e b) -> Conceit e b)
-> (a -> IO (Either e b)) -> a -> Conceit e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (Either e b)
f)
catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
race :: IO (Either e a) -> IO (Either e b) -> IO (Either e (Either a b))
race :: IO (Either e a) -> IO (Either e b) -> IO (Either e (Either a b))
race IO (Either e a)
left IO (Either e b)
right = IO (Either e a)
-> IO (Either e b)
-> (MVar (Either SomeException (Either (Either e a) (Either e b)))
-> IO (Either e (Either a b)))
-> IO (Either e (Either a b))
forall a b r.
IO a
-> IO b
-> (MVar (Either SomeException (Either a b)) -> IO r)
-> IO r
conceit' IO (Either e a)
left IO (Either e b)
right MVar (Either SomeException (Either (Either e a) (Either e b)))
-> IO (Either e (Either a b))
forall e a a b.
Exception e =>
MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either a (Either a b))
collect
where
collect :: MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either a (Either a b))
collect MVar (Either e (Either (Either a a) (Either a b)))
m = do
Either e (Either (Either a a) (Either a b))
e <- MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either e (Either (Either a a) (Either a b)))
forall a. MVar a -> IO a
takeMVar MVar (Either e (Either (Either a a) (Either a b)))
m
case Either e (Either (Either a a) (Either a b))
e of
Left e
ex -> e -> IO (Either a (Either a b))
forall e a. Exception e => e -> IO a
throwIO e
ex
Right (Right (Right b
r1)) -> Either a (Either a b) -> IO (Either a (Either a b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Either a b) -> IO (Either a (Either a b)))
-> Either a (Either a b) -> IO (Either a (Either a b))
forall a b. (a -> b) -> a -> b
$ Either a b -> Either a (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either a (Either a b))
-> Either a b -> Either a (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
r1
Right (Right (Left a
e1)) -> Either a (Either a b) -> IO (Either a (Either a b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Either a b) -> IO (Either a (Either a b)))
-> Either a (Either a b) -> IO (Either a (Either a b))
forall a b. (a -> b) -> a -> b
$ a -> Either a (Either a b)
forall a b. a -> Either a b
Left a
e1
Right (Left (Right a
r2)) -> Either a (Either a b) -> IO (Either a (Either a b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Either a b) -> IO (Either a (Either a b)))
-> Either a (Either a b) -> IO (Either a (Either a b))
forall a b. (a -> b) -> a -> b
$ Either a b -> Either a (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either a (Either a b))
-> Either a b -> Either a (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
r2
Right (Left (Left a
e2)) -> Either a (Either a b) -> IO (Either a (Either a b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (Either a b) -> IO (Either a (Either a b)))
-> Either a (Either a b) -> IO (Either a (Either a b))
forall a b. (a -> b) -> a -> b
$ a -> Either a (Either a b)
forall a b. a -> Either a b
Left a
e2
conceit :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
conceit :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
conceit IO (Either e a)
left IO (Either e b)
right = IO (Either e a)
-> IO (Either e b)
-> (MVar (Either SomeException (Either (Either e a) (Either e b)))
-> IO (Either e (a, b)))
-> IO (Either e (a, b))
forall a b r.
IO a
-> IO b
-> (MVar (Either SomeException (Either a b)) -> IO r)
-> IO r
conceit' IO (Either e a)
left IO (Either e b)
right ([Either (Either e a) (Either e b)]
-> MVar (Either SomeException (Either (Either e a) (Either e b)))
-> IO (Either e (a, b))
forall e a a b.
Exception e =>
[Either (Either a a) (Either a b)]
-> MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either a (a, b))
collect [])
where
collect :: [Either (Either a a) (Either a b)]
-> MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either a (a, b))
collect [Left (Right a
a), Right (Right b
b)] MVar (Either e (Either (Either a a) (Either a b)))
_ = Either a (a, b) -> IO (Either a (a, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (a, b) -> IO (Either a (a, b)))
-> Either a (a, b) -> IO (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
a,b
b)
collect [Right (Right b
b), Left (Right a
a)] MVar (Either e (Either (Either a a) (Either a b)))
_ = Either a (a, b) -> IO (Either a (a, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (a, b) -> IO (Either a (a, b)))
-> Either a (a, b) -> IO (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
a,b
b)
collect (Left (Left a
ea):[Either (Either a a) (Either a b)]
_) MVar (Either e (Either (Either a a) (Either a b)))
_ = Either a (a, b) -> IO (Either a (a, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (a, b) -> IO (Either a (a, b)))
-> Either a (a, b) -> IO (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ a -> Either a (a, b)
forall a b. a -> Either a b
Left a
ea
collect (Right (Left a
eb):[Either (Either a a) (Either a b)]
_) MVar (Either e (Either (Either a a) (Either a b)))
_ = Either a (a, b) -> IO (Either a (a, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (a, b) -> IO (Either a (a, b)))
-> Either a (a, b) -> IO (Either a (a, b))
forall a b. (a -> b) -> a -> b
$ a -> Either a (a, b)
forall a b. a -> Either a b
Left a
eb
collect [Either (Either a a) (Either a b)]
xs MVar (Either e (Either (Either a a) (Either a b)))
m = do
Either e (Either (Either a a) (Either a b))
e <- MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either e (Either (Either a a) (Either a b)))
forall a. MVar a -> IO a
takeMVar MVar (Either e (Either (Either a a) (Either a b)))
m
case Either e (Either (Either a a) (Either a b))
e of
Left e
ex -> e -> IO (Either a (a, b))
forall e a. Exception e => e -> IO a
throwIO e
ex
Right Either (Either a a) (Either a b)
r -> [Either (Either a a) (Either a b)]
-> MVar (Either e (Either (Either a a) (Either a b)))
-> IO (Either a (a, b))
collect (Either (Either a a) (Either a b)
rEither (Either a a) (Either a b)
-> [Either (Either a a) (Either a b)]
-> [Either (Either a a) (Either a b)]
forall a. a -> [a] -> [a]
:[Either (Either a a) (Either a b)]
xs) MVar (Either e (Either (Either a a) (Either a b)))
m
conceit' :: IO a
-> IO b
-> (MVar (Either SomeException (Either a b)) -> IO r)
-> IO r
conceit' :: IO a
-> IO b
-> (MVar (Either SomeException (Either a b)) -> IO r)
-> IO r
conceit' IO a
left IO b
right MVar (Either SomeException (Either a b)) -> IO r
collect = do
MVar (Either SomeException (Either a b))
done <- IO (MVar (Either SomeException (Either a b)))
forall a. IO (MVar a)
newEmptyMVar
((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO r) -> IO r)
-> ((forall a. IO a -> IO a) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
ThreadId
lid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO a
left IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> IO ())
-> (a -> Either SomeException (Either a b)) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either SomeException (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either SomeException (Either a b))
-> (a -> Either a b) -> a -> Either SomeException (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)
IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` (MVar (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> IO ())
-> (SomeException -> Either SomeException (Either a b))
-> SomeException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException (Either a b)
forall a b. a -> Either a b
Left)
ThreadId
rid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO b
right IO b -> (b -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> IO ())
-> (b -> Either SomeException (Either a b)) -> b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either SomeException (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either SomeException (Either a b))
-> (b -> Either a b) -> b -> Either SomeException (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right)
IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` (MVar (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> IO ())
-> (SomeException -> Either SomeException (Either a b))
-> SomeException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException (Either a b)
forall a b. a -> Either a b
Left)
let stop :: IO ()
stop = ThreadId -> IO ()
killThread ThreadId
rid IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
lid
r
r <- IO r -> IO r
forall a. IO a -> IO a
restore (MVar (Either SomeException (Either a b)) -> IO r
collect MVar (Either SomeException (Either a b))
done) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
`onException` IO ()
stop
IO ()
stop
r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r