{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Control.Churro.Types where
import Prelude hiding (id, (.))
import Control.Arrow
import Control.Category
import Control.Concurrent.Async (cancel, wait, Async, async)
import Data.Void
import Control.Exception (finally)
newtype Churro a t i o = Churro { Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro :: IO (In t (Maybe i), Out t (Maybe o), Async a) }
type Source a t o = Churro a t Void o
type Sink a t i = Churro a t i Void
type DoubleDipped a t = Churro a t Void Void
class Transport (t :: * -> *) where
data In t :: * -> *
data Out t :: * -> *
flex :: IO (In t a, Out t a)
yank :: Out t a -> IO a
yeet :: In t a -> a -> IO ()
instance Transport t => Functor (Churro a t i) where
fmap :: (a -> b) -> Churro a t i a -> Churro a t i b
fmap a -> b
f Churro a t i a
c = IO (In t (Maybe i), Out t (Maybe b), Async a) -> Churro a t i b
forall a (t :: * -> *) i o.
IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
Churro do
(In t (Maybe i)
i,Out t (Maybe a)
o,Async a
a) <- Churro a t i a -> IO (In t (Maybe i), Out t (Maybe a), Async a)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a t i a
c
(In t (Maybe b)
i',Out t (Maybe b)
o') <- IO (In t (Maybe b), Out t (Maybe b))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
Async a
a' <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async do
IO () -> IO a -> IO a
forall b a. IO b -> IO a -> IO a
finally' (Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
a) do
(a -> b) -> Out t (Maybe a) -> In t (Maybe b) -> IO ()
forall (t :: * -> *) a b.
Transport t =>
(a -> b) -> Out t (Maybe a) -> In t (Maybe b) -> IO ()
c2c a -> b
f Out t (Maybe a)
o In t (Maybe b)
i'
Async a -> IO a
forall a. Async a -> IO a
wait Async a
a
(In t (Maybe i), Out t (Maybe b), Async a)
-> IO (In t (Maybe i), Out t (Maybe b), Async a)
forall (m :: * -> *) a. Monad m => a -> m a
return (In t (Maybe i)
i,Out t (Maybe b)
o',Async a
a')
instance (Transport t, Monoid a) => Category (Churro a t) where
id :: Churro a t a a
id = IO (In t (Maybe a), Out t (Maybe a), Async a) -> Churro a t a a
forall a (t :: * -> *) i o.
IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
Churro do
(In t (Maybe a)
i,Out t (Maybe a)
o) <- IO (In t (Maybe a), Out t (Maybe a))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
Async a
a <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async IO a
forall a. Monoid a => a
mempty
(In t (Maybe a), Out t (Maybe a), Async a)
-> IO (In t (Maybe a), Out t (Maybe a), Async a)
forall (m :: * -> *) a. Monad m => a -> m a
return (In t (Maybe a)
i,Out t (Maybe a)
o,Async a
a)
Churro a t b c
g . :: Churro a t b c -> Churro a t a b -> Churro a t a c
. Churro a t a b
f = Churro a t a b
f Churro a t a b -> Churro a t b c -> Churro a t a c
forall (t :: * -> *) fo gi a1 fi a2 go.
(Transport t, fo ~ gi) =>
Churro a1 t fi fo -> Churro a2 t gi go -> Churro a2 t fi go
>>>> Churro a t b c
g
(>>>>) :: (Transport t, fo ~ gi) => Churro a1 t fi fo -> Churro a2 t gi go -> Churro a2 t fi go
Churro a1 t fi fo
f >>>> :: Churro a1 t fi fo -> Churro a2 t gi go -> Churro a2 t fi go
>>>> Churro a2 t gi go
g = IO (In t (Maybe fi), Out t (Maybe go), Async a2)
-> Churro a2 t fi go
forall a (t :: * -> *) i o.
IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
Churro do
(In t (Maybe fi)
fi, Out t (Maybe fo)
fo, Async a1
fa) <- Churro a1 t fi fo
-> IO (In t (Maybe fi), Out t (Maybe fo), Async a1)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a1 t fi fo
f
(In t (Maybe gi)
gi, Out t (Maybe go)
go, Async a2
ga) <- Churro a2 t gi go
-> IO (In t (Maybe gi), Out t (Maybe go), Async a2)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a2 t gi go
g
Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async do (fo -> gi) -> Out t (Maybe fo) -> In t (Maybe gi) -> IO ()
forall (t :: * -> *) a b.
Transport t =>
(a -> b) -> Out t (Maybe a) -> In t (Maybe b) -> IO ()
c2c fo -> gi
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id Out t (Maybe fo)
fo In t (Maybe gi)
gi
Async a2
b <- IO a2 -> IO (Async a2)
forall a. IO a -> IO (Async a)
async do
IO () -> IO a2 -> IO a2
forall b a. IO b -> IO a -> IO a
finally' (Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async a1 -> IO ()
forall a. Async a -> IO ()
cancel Async a1
fa IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async a2 -> IO ()
forall a. Async a -> IO ()
cancel Async a2
ga) do
a2
r <- Async a2 -> IO a2
forall a. Async a -> IO a
wait Async a2
ga
Async a1 -> IO ()
forall a. Async a -> IO ()
cancel Async a1
fa
Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a
a2 -> IO a2
forall (m :: * -> *) a. Monad m => a -> m a
return a2
r
(In t (Maybe fi), Out t (Maybe go), Async a2)
-> IO (In t (Maybe fi), Out t (Maybe go), Async a2)
forall (m :: * -> *) a. Monad m => a -> m a
return (In t (Maybe fi)
fi, Out t (Maybe go)
go, Async a2
b)
instance (Transport t, Monoid a) => Applicative (Churro a t Void) where
pure :: a -> Churro a t Void a
pure = a -> Churro a t Void a
forall (t :: * -> *) a o i.
(Transport t, Monoid a) =>
o -> Churro a t i o
pure'
Churro a t Void (a -> b)
f <*> :: Churro a t Void (a -> b) -> Churro a t Void a -> Churro a t Void b
<*> Churro a t Void a
g = (Out t (Maybe Void) -> In t (Maybe b) -> IO a) -> Churro a t Void b
forall (t :: * -> *) i o a.
Transport t =>
(Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
buildChurro \Out t (Maybe Void)
_i In t (Maybe b)
o -> do
(In t (Maybe Void)
_fi, Out t (Maybe (a -> b))
fo, Async a
fa) <- Churro a t Void (a -> b)
-> IO (In t (Maybe Void), Out t (Maybe (a -> b)), Async a)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a t Void (a -> b)
f
(In t (Maybe Void)
_gi, Out t (Maybe a)
go, Async a
ga) <- Churro a t Void a
-> IO (In t (Maybe Void), Out t (Maybe a), Async a)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a t Void a
g
let
prog :: IO ()
prog :: IO ()
prog = do
Maybe (a -> b)
fx <- Out t (Maybe (a -> b)) -> IO (Maybe (a -> b))
forall (t :: * -> *) a. Transport t => Out t a -> IO a
yank Out t (Maybe (a -> b))
fo
Maybe a
gx <- Out t (Maybe a) -> IO (Maybe a)
forall (t :: * -> *) a. Transport t => Out t a -> IO a
yank Out t (Maybe a)
go
case (Maybe (a -> b)
fx, Maybe a
gx) of
(Just a -> b
f', Just a
g') -> (In t (Maybe b) -> Maybe b -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe b)
o (Maybe b -> IO ()) -> Maybe b -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
f' a
g')) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
prog
(Maybe (a -> b), Maybe a)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO ()
prog
In t (Maybe b) -> Maybe b -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe b)
o Maybe b
forall a. Maybe a
Nothing
Async a -> IO a
forall a. Async a -> IO a
wait Async a
fa
Async a -> IO a
forall a. Async a -> IO a
wait Async a
ga
pure' :: (Transport t, Monoid a) => o -> Churro a t i o
pure' :: o -> Churro a t i o
pure' o
x = (Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
forall (t :: * -> *) i o a.
Transport t =>
(Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
buildChurro \Out t (Maybe i)
_i In t (Maybe o)
o -> In t (Maybe o) -> Maybe o -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe o)
o (o -> Maybe o
forall a. a -> Maybe a
Just o
x) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> In t (Maybe o) -> Maybe o -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe o)
o Maybe o
forall a. Maybe a
Nothing IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
instance (Transport t, Monoid a) => Arrow (Churro a t) where
arr :: (b -> c) -> Churro a t b c
arr = (b -> c) -> Churro a t b c
forall (cat :: * -> * -> *) a b.
(Functor (cat a), Category cat) =>
(a -> b) -> cat a b
arr'
first :: Churro a t b c -> Churro a t (b, d) (c, d)
first Churro a t b c
c = IO (In t (Maybe (b, d)), Out t (Maybe (c, d)), Async a)
-> Churro a t (b, d) (c, d)
forall a (t :: * -> *) i o.
IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
Churro do
(In t (Maybe b)
i,Out t (Maybe c)
o,Async a
a) <- Churro a t b c -> IO (In t (Maybe b), Out t (Maybe c), Async a)
forall a (t :: * -> *) i o.
Churro a t i o -> IO (In t (Maybe i), Out t (Maybe o), Async a)
runChurro Churro a t b c
c
(In t (Maybe (b, d))
ai',Out t (Maybe (b, d))
ao') <- IO (In t (Maybe (b, d)), Out t (Maybe (b, d)))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
(In t (Maybe (c, d))
bi',Out t (Maybe (c, d))
bo') <- IO (In t (Maybe (c, d)), Out t (Maybe (c, d)))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
let go :: IO ()
go = do
Maybe (b, d)
is <- Out t (Maybe (b, d)) -> IO (Maybe (b, d))
forall (t :: * -> *) a. Transport t => Out t a -> IO a
yank Out t (Maybe (b, d))
ao'
In t (Maybe b) -> Maybe b -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe b)
i (((b, d) -> b) -> Maybe (b, d) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, d) -> b
forall a b. (a, b) -> a
fst Maybe (b, d)
is)
Maybe c
os <- Out t (Maybe c) -> IO (Maybe c)
forall (t :: * -> *) a. Transport t => Out t a -> IO a
yank Out t (Maybe c)
o
In t (Maybe (c, d)) -> Maybe (c, d) -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe (c, d))
bi' (Maybe (c, d) -> IO ()) -> Maybe (c, d) -> IO ()
forall a b. (a -> b) -> a -> b
$ (,) (c -> d -> (c, d)) -> Maybe c -> Maybe (d -> (c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe c
os Maybe (d -> (c, d)) -> Maybe d -> Maybe (c, d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((b, d) -> d) -> Maybe (b, d) -> Maybe d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, d) -> d
forall a b. (a, b) -> b
snd Maybe (b, d)
is
case (Maybe (b, d)
is, Maybe c
os) of
(Just (b, d)
_, Just c
_) -> IO ()
go
(Maybe (b, d), Maybe c)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Async a
a' <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async do
IO ()
go
In t (Maybe (c, d)) -> Maybe (c, d) -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe (c, d))
bi' Maybe (c, d)
forall a. Maybe a
Nothing
Async a -> IO a
forall a. Async a -> IO a
wait Async a
a
(In t (Maybe (b, d)), Out t (Maybe (c, d)), Async a)
-> IO (In t (Maybe (b, d)), Out t (Maybe (c, d)), Async a)
forall (m :: * -> *) a. Monad m => a -> m a
return (In t (Maybe (b, d))
ai',Out t (Maybe (c, d))
bo',Async a
a')
arr' :: (Functor (cat a), Category cat) => (a -> b) -> cat a b
arr' :: (a -> b) -> cat a b
arr' a -> b
f = (a -> b) -> cat a a -> cat a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f cat a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
buildChurro :: Transport t => (Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
buildChurro :: (Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
buildChurro Out t (Maybe i) -> In t (Maybe o) -> IO a
cb = (In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a)
-> Churro a t i o
forall (t :: * -> *) i o a.
Transport t =>
(In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a)
-> Churro a t i o
buildChurro' \In t (Maybe i)
_o' Out t (Maybe i)
i In t (Maybe o)
o -> Out t (Maybe i) -> In t (Maybe o) -> IO a
cb Out t (Maybe i)
i In t (Maybe o)
o
buildChurro' :: Transport t => (In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a) -> Churro a t i o
buildChurro' :: (In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a)
-> Churro a t i o
buildChurro' In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a
cb = IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
forall a (t :: * -> *) i o.
IO (In t (Maybe i), Out t (Maybe o), Async a) -> Churro a t i o
Churro do
(In t (Maybe i)
ai,Out t (Maybe i)
ao) <- IO (In t (Maybe i), Out t (Maybe i))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
(In t (Maybe o)
bi,Out t (Maybe o)
bo) <- IO (In t (Maybe o), Out t (Maybe o))
forall (t :: * -> *) a. Transport t => IO (In t a, Out t a)
flex
Async a
a <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async do In t (Maybe i) -> Out t (Maybe i) -> In t (Maybe o) -> IO a
cb In t (Maybe i)
ai Out t (Maybe i)
ao In t (Maybe o)
bi
(In t (Maybe i), Out t (Maybe o), Async a)
-> IO (In t (Maybe i), Out t (Maybe o), Async a)
forall (m :: * -> *) a. Monad m => a -> m a
return (In t (Maybe i)
ai,Out t (Maybe o)
bo,Async a
a)
yeetList :: (Foldable f, Transport t) => In t a -> f a -> IO ()
yeetList :: In t a -> f a -> IO ()
yeetList In t a
t = (a -> IO ()) -> f a -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (In t a -> a -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t a
t)
yankList :: Transport t => Out t (Maybe a) -> IO [a]
yankList :: Out t (Maybe a) -> IO [a]
yankList = (Out t (Maybe a) -> (a -> IO [a]) -> IO [a])
-> (a -> IO [a]) -> Out t (Maybe a) -> IO [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Out t (Maybe a) -> (a -> IO [a]) -> IO [a]
forall (t :: * -> *) a i.
(Transport t, Monoid a) =>
Out t (Maybe i) -> (i -> IO a) -> IO a
yankAll ([a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> (a -> [a]) -> a -> IO [a]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
yankAll :: (Transport t, Monoid a) => Out t (Maybe i) -> (i -> IO a) -> IO a
yankAll :: Out t (Maybe i) -> (i -> IO a) -> IO a
yankAll Out t (Maybe i)
c i -> IO a
f = do
Maybe i
x <- Out t (Maybe i) -> IO (Maybe i)
forall (t :: * -> *) a. Transport t => Out t a -> IO a
yank Out t (Maybe i)
c
case Maybe i
x of
Maybe i
Nothing -> IO a
forall a. Monoid a => a
mempty
Just i
y -> i -> IO a
f i
y IO a -> IO a -> IO a
forall a. Semigroup a => a -> a -> a
<> Out t (Maybe i) -> (i -> IO a) -> IO a
forall (t :: * -> *) a i.
(Transport t, Monoid a) =>
Out t (Maybe i) -> (i -> IO a) -> IO a
yankAll Out t (Maybe i)
c i -> IO a
f
yankAll' :: (Transport t, Monoid b) => Out t (Maybe a) -> (Maybe a -> IO b) -> IO b
yankAll' :: Out t (Maybe a) -> (Maybe a -> IO b) -> IO b
yankAll' Out t (Maybe a)
c Maybe a -> IO b
f = do
b
x <- Out t (Maybe a) -> (a -> IO b) -> IO b
forall (t :: * -> *) a i.
(Transport t, Monoid a) =>
Out t (Maybe i) -> (i -> IO a) -> IO a
yankAll Out t (Maybe a)
c (Maybe a -> IO b
f (Maybe a -> IO b) -> (a -> Maybe a) -> a -> IO b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
forall a. a -> Maybe a
Just)
b
y <- Maybe a -> IO b
f Maybe a
forall a. Maybe a
Nothing
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
x b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
y)
c2c :: Transport t => (a -> b) -> Out t (Maybe a) -> In t (Maybe b) -> IO ()
c2c :: (a -> b) -> Out t (Maybe a) -> In t (Maybe b) -> IO ()
c2c a -> b
f Out t (Maybe a)
o In t (Maybe b)
i = Out t (Maybe a) -> (Maybe a -> IO ()) -> IO ()
forall (t :: * -> *) b a.
(Transport t, Monoid b) =>
Out t (Maybe a) -> (Maybe a -> IO b) -> IO b
yankAll' Out t (Maybe a)
o (In t (Maybe b) -> Maybe b -> IO ()
forall (t :: * -> *) a. Transport t => In t a -> a -> IO ()
yeet In t (Maybe b)
i (Maybe b -> IO ()) -> (Maybe a -> Maybe b) -> Maybe a -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)
finally' :: IO b -> IO a -> IO a
finally' :: IO b -> IO a -> IO a
finally' = (IO a -> IO b -> IO a) -> IO b -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally