module Control.Concurrent.CHP.Connect
(Connectable(..), (<=>), (|<=>), (<=>|), (|<=>|), pipelineConnect, pipelineConnectComplete,
cycleConnect, ConnectableExtra(..), connectWith) where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.CHP
class ConnectableExtra l r where
type ConnectableParam l
connectExtra :: ConnectableParam l -> ((l, r) -> CHP ()) -> CHP ()
class Connectable l r where
connect :: ((l, r) -> CHP ()) -> CHP ()
(|<=>|) :: Connectable l r => (l -> CHP ()) -> (r -> CHP ()) -> CHP ()
(|<=>|) p q = connect $ \(x, y) -> p x <|*|> q y
jpo :: ConnectableExtra l r => ConnectableParam l -> (l -> CHP ()) -> (r -> CHP ()) -> CHP ()
jpo o p q = connectExtra o $ \(x, y) -> p x <|*|> q y
(<=>) :: Connectable l r => (a -> l -> CHP ()) -> (r -> b -> CHP ()) -> a -> b -> CHP ()
(<=>) p q x y = p x |<=>| flip q y
(<=>|) :: Connectable l r => (a -> l -> CHP ()) -> (r -> CHP ()) -> a -> CHP ()
(<=>|) p q x = p x |<=>| q
(|<=>) :: Connectable l r => (l -> CHP ()) -> (r -> b -> CHP ()) -> b -> CHP ()
(|<=>) p q x = p |<=>| flip q x
connectWith :: ConnectableExtra l r => ConnectableParam l ->
(a -> l -> CHP ()) -> (r -> b -> CHP ()) -> a -> b -> CHP ()
connectWith o p q x y = jpo o (p x) (flip q y)
pipelineConnect :: Connectable l r => [r -> l -> CHP ()] -> r -> l -> CHP ()
pipelineConnect [] = const . const $ return ()
pipelineConnect [p] = p
pipelineConnect (p:ps) = p <=> pipelineConnect ps
pipelineConnectComplete :: Connectable l r =>
(l -> CHP ()) -> [r -> l -> CHP ()] -> (r -> CHP ()) -> CHP ()
pipelineConnectComplete begin [] end = begin |<=>| end
pipelineConnectComplete begin middle end
= (begin |<=> pipelineConnect middle) |<=>| end
cycleConnect :: Connectable l r => [r -> l -> CHP ()] -> CHP ()
cycleConnect [] = return ()
cycleConnect ps = connect . uncurry . flip . pipelineConnect $ ps
instance Connectable (Chanout a) (Chanin a) where
connect = (>>=) ((writer &&& reader) <$> oneToOneChannel)
instance ConnectableExtra (Chanout a) (Chanin a) where
type ConnectableParam (Chanout a) = ChanOpts a
connectExtra o = (>>=) ((writer &&& reader) <$> oneToOneChannel' o)
instance Connectable (Chanin a) (Chanout a) where
connect = (>>=) ((reader &&& writer) <$> oneToOneChannel)
instance ConnectableExtra (Chanin a) (Chanout a) where
type ConnectableParam (Chanin a) = ChanOpts a
connectExtra o = (>>=) ((reader &&& writer) <$> oneToOneChannel' o)
instance Connectable (Enrolled PhasedBarrier ()) (Enrolled PhasedBarrier ()) where
connect m = do b <- newBarrier
enroll b $ \b0 -> enroll b $ \b1 -> m (b0, b1)
instance ConnectableExtra (Enrolled PhasedBarrier ph) (Enrolled PhasedBarrier ph) where
type ConnectableParam (Enrolled PhasedBarrier ph) = (ph, BarOpts ph)
connectExtra (ph, o) m
= do b <- newPhasedBarrier' ph o
enroll b $ \b0 -> enroll b $ \b1 -> m (b0, b1)
instance (Connectable al ar, Connectable bl br) => Connectable (al, bl) (ar, br) where
connect m = connect $ \(ax, ay) -> connect $ \(bx, by) -> m ((ax, bx), (ay, by))
instance (ConnectableExtra al ar, ConnectableExtra bl br) => ConnectableExtra (al, bl) (ar, br) where
type ConnectableParam (al, bl) = (ConnectableParam al, ConnectableParam bl)
connectExtra (ao, bo) m = connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) -> m ((ax, bx), (ay, by))
instance (Connectable al ar, Connectable bl br, Connectable cl cr) =>
Connectable (al, bl, cl) (ar, br, cr) where
connect m = connect $ \(ax, ay) -> connect $ \(bx, by) ->
connect $ \(cx, cy) -> m ((ax, bx, cx), (ay, by, cy))
instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr) =>
ConnectableExtra (al, bl, cl) (ar, br, cr) where
type ConnectableParam (al, bl, cl) = (ConnectableParam al, ConnectableParam bl, ConnectableParam cl)
connectExtra (ao, bo, co) m
= connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) ->
connectExtra co $ \(cx, cy) -> m ((ax, bx, cx), (ay, by, cy))
instance (Connectable al ar, Connectable bl br, Connectable cl cr,
Connectable dl dr) =>
Connectable (al, bl, cl, dl) (ar, br, cr, dr) where
connect m = connect $ \(ax, ay) -> connect $ \(bx, by) ->
connect $ \(cx, cy) -> connect $ \(dx, dy) ->
m ((ax, bx, cx, dx), (ay, by, cy, dy))
instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr,
ConnectableExtra dl dr) =>
ConnectableExtra (al, bl, cl, dl) (ar, br, cr, dr) where
type ConnectableParam (al, bl, cl, dl)
= (ConnectableParam al,
ConnectableParam bl,
ConnectableParam cl,
ConnectableParam dl)
connectExtra (ao, bo, co, do_) m
= connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) ->
connectExtra co $ \(cx, cy) -> connectExtra do_ $ \(dx, dy) ->
m ((ax, bx, cx, dx), (ay, by, cy, dy))
instance (Connectable al ar, Connectable bl br, Connectable cl cr,
Connectable dl dr, Connectable el er) =>
Connectable (al, bl, cl, dl, el) (ar, br, cr, dr, er) where
connect m = connect $ \(ax, ay) -> connect $ \(bx, by) ->
connect $ \(cx, cy) -> connect $ \(dx, dy) ->
connect $ \(ex, ey) -> m ((ax, bx, cx, dx, ex), (ay, by, cy, dy, ey))
instance (ConnectableExtra al ar, ConnectableExtra bl br, ConnectableExtra cl cr,
ConnectableExtra dl dr, ConnectableExtra el er) =>
ConnectableExtra (al, bl, cl, dl, el) (ar, br, cr, dr, er) where
type ConnectableParam (al, bl, cl, dl, el)
= (ConnectableParam al,
ConnectableParam bl,
ConnectableParam cl,
ConnectableParam dl,
ConnectableParam el)
connectExtra (ao, bo, co, do_, eo) m
= connectExtra ao $ \(ax, ay) -> connectExtra bo $ \(bx, by) ->
connectExtra co $ \(cx, cy) -> connectExtra do_ $ \(dx, dy) ->
connectExtra eo $ \(ex, ey) -> m ((ax, bx, cx, dx, ex), (ay, by, cy, dy, ey))