module Control.Concurrent.CHP.Connect
(Connectable(..), (<=>), (|<=>), (<=>|), (|<=>|), pipelineConnect, pipelineConnectComplete,
cycleConnect, connectList, connectList_, ChannelPair,
ConnectableExtra(..), connectWith) where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.CHP
class ConnectableExtra l r where
type ConnectableParam l r
connectExtra :: ConnectableParam l r -> ((l, r) -> CHP ()) -> CHP ()
class Connectable l r where
connect :: ((l, r) -> CHP a) -> CHP a
data ChannelPair l r = ChannelPair l r
deriving (Eq, Show)
instance Connectable l r => Connectable (ChannelPair l r) (ChannelPair l r) where
connect f = connect $ \(lx, rx) -> connect $ \(ly, ry) ->
f (ChannelPair lx ry, ChannelPair ly rx)
connectList :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP a
connectList n p | n == 0 = p []
| n > 0 = connect $ \lr -> connectList (n 1) $ p . (lr :)
| otherwise = error $ "Control.Concurrent.CHP.Connect.connectList: negative parameter " ++ show n
connectList_ :: Connectable l r => Int -> ([(l, r)] -> CHP a) -> CHP ()
connectList_ n p | n == 0 = p [] >> return ()
| n > 0 = connect $ \lr -> connectList_ (n 1) $ p . (lr :)
| otherwise = error $ "Control.Concurrent.CHP.Connect.connectList_: negative parameter " ++ show n
(|<=>|) :: Connectable l r => (l -> CHP ()) -> (r -> CHP ()) -> CHP ()
(|<=>|) p q = connect $ \(x, y) -> p x <|*|> q y
jpo :: ConnectableExtra l r => ConnectableParam l r -> (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 r ->
(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 ps = foldl1 (<=>) ps
pipelineConnectComplete :: Connectable l r =>
(l -> CHP ()) -> [r -> l -> CHP ()] -> (r -> CHP ()) -> CHP ()
pipelineConnectComplete begin middle end
= (foldl (|<=>) begin 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 = (newChannelWR >>=)
instance ConnectableExtra (Chanout a) (Chanin a) where
type ConnectableParam (Chanout a) (Chanin a) = ChanOpts a
connectExtra o = (>>=) ((writer &&& reader) <$> oneToOneChannel' o)
instance Connectable (Chanin a) (Chanout a) where
connect = (newChannelRW >>=)
instance ConnectableExtra (Chanin a) (Chanout a) where
type ConnectableParam (Chanin a) (Chanout a) = ChanOpts a
connectExtra o = (>>=) ((reader &&& writer) <$> oneToOneChannel' o)
instance Connectable (Shared Chanin a) (Chanout a) where connect = (newChannelRW >>=)
instance Connectable (Chanin a) (Shared Chanout a) where connect = (newChannelRW >>=)
instance Connectable (Shared Chanin a) (Shared Chanout a) where connect = (newChannelRW >>=)
instance Connectable (Chanout a) (Shared Chanin a) where connect = (newChannelWR >>=)
instance Connectable (Shared Chanout a) (Chanin a) where connect = (newChannelWR >>=)
instance Connectable (Shared Chanout a) (Shared Chanin a) where connect = (newChannelWR >>=)
instance ConnectableExtra (Chanout a) (Shared Chanin a) where
type ConnectableParam (Chanout a) (Shared Chanin a) = ChanOpts a
connectExtra o = (>>=) ((writer &&& reader) <$> oneToAnyChannel' o)
instance ConnectableExtra (Shared Chanout a) (Chanin a) where
type ConnectableParam (Shared Chanout a) (Chanin a) = ChanOpts a
connectExtra o = (>>=) ((writer &&& reader) <$> anyToOneChannel' o)
instance ConnectableExtra (Shared Chanout a) (Shared Chanin a) where
type ConnectableParam (Shared Chanout a) (Shared Chanin a) = ChanOpts a
connectExtra o = (>>=) ((writer &&& reader) <$> anyToAnyChannel' o)
instance ConnectableExtra (Shared Chanin a) (Chanout a) where
type ConnectableParam (Shared Chanin a) (Chanout a) = ChanOpts a
connectExtra o = (>>=) ((reader &&& writer) <$> oneToAnyChannel' o)
instance ConnectableExtra (Chanin a) (Shared Chanout a) where
type ConnectableParam (Chanin a) (Shared Chanout a) = ChanOpts a
connectExtra o = (>>=) ((reader &&& writer) <$> anyToOneChannel' o)
instance ConnectableExtra (Shared Chanin a) (Shared Chanout a) where
type ConnectableParam (Shared Chanin a) (Shared Chanout a) = ChanOpts a
connectExtra o = (>>=) ((reader &&& writer) <$> anyToAnyChannel' 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) (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) (ar, br) = (ConnectableParam al ar, ConnectableParam bl br)
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) (ar, br, cr) = (ConnectableParam al ar, ConnectableParam bl br, ConnectableParam cl cr)
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) (ar, br, cr, dr)
= (ConnectableParam al ar,
ConnectableParam bl br,
ConnectableParam cl cr,
ConnectableParam dl dr)
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) (ar, br, cr, dr, er)
= (ConnectableParam al ar,
ConnectableParam bl br,
ConnectableParam cl cr,
ConnectableParam dl dr,
ConnectableParam el er)
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))