module Control.Concurrent.Session.Pid
( Pid (..)
, InternalPid (..)
, makePid
, rootPid
, iPidToPid
, myPid
, InterleavedChain (..)
, BuildPidTyMap (..)
, CreateSession (..)
, PidEq (..)
, MultiReceive (MultiReceiveNil)
, (~|||~)
, multiReceive
) where
import Control.Concurrent.Session.Bool
import Control.Concurrent.Session.Number
import Control.Concurrent.Session.Map
import Control.Concurrent.Session.List
import Control.Concurrent.Session.SessionType
import Control.Concurrent.Session.SMonad
import Control.Concurrent.Session.Runtime
import Control.Concurrent
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
type RawPid = [Int]
data Pid :: * -> * -> * -> * -> * where
Pid :: RawPid -> prog -> prog' -> TyMap sessionsToIdx idxsToPairStructs ->
Pid prog prog' sessionsToIdx idxsToPairStructs
data InternalPid :: * -> * -> * -> * -> * where
IPid :: Pid prog prog' sessionsToIdx idxsToPairStructs -> [RawPid] ->
InternalPid prog prog' sessionsToIdx idxsToPairStructs
pidToRawPid :: Pid prog prog' sessionsToIdx idxsToPairStructs -> RawPid
pidToRawPid (Pid p _ _ _) = p
iPidToPid :: InternalPid prog prog' sessionsToIdx idxsToPairStructs ->
Pid prog prog' sessionsToIdx idxsToPairStructs
iPidToPid (IPid p _) = p
instance Show (Pid prog prog' sessionsToIdx idxsToPairStructs) where
show = (:) '<' . (:) '.' . foldr (\c a -> shows c ('.':a)) ">" . reverse . pidToRawPid
instance Eq (Pid prog prog' sessionsToIdx idxsToPairStructs) where
(==) a b = (==) (pidToRawPid a) (pidToRawPid b)
instance Ord (Pid prog prog' sessionsToIdx idxsToPairStructs) where
compare a b = compare (pidToRawPid a) (pidToRawPid b)
instance Eq (InternalPid prog prog' sessionsToIdx idxsToPairStructs) where
(==) a b = (==) (iPidToPid a) (iPidToPid b)
instance Ord (InternalPid prog prog' sessionsToIdx idxsToPairStructs) where
compare a b = compare (iPidToPid a) (iPidToPid b)
class PidEq a b where
(=~=) :: a -> b -> Bool
instance PidEq (Pid progA progA' sessionsToIdxA idxsToPairStructsA) (Pid progB progB' sessionsToIdxB idxsToPairStructsB) where
(=~=) a b = (==) (pidToRawPid a) (pidToRawPid b)
makePid :: InternalPid prog prog' sessionsToIdxO idxsToPairStructsO ->
TyMap sessionsToIdxN idxsToPairStructsN ->
(InternalPid prog prog' sessionsToIdxO idxsToPairStructsO,
InternalPid prog prog' sessionsToIdxN idxsToPairStructsN)
makePid (IPid orig@(Pid _ prog prog' _) (p:ps)) childTM = ((IPid orig ps), child)
where
child = IPid (Pid p prog prog' childTM) [x:p | x <- [0..]]
makePid (IPid _ []) _ = error "Out of pids. Interesting."
rootPid :: ( Dual prog prog'
, DualT prog ~ prog'
) =>
TyMap sessionsToIdx idxsToPairStructs -> prog ->
InternalPid prog prog' sessionsToIdx idxsToPairStructs
rootPid tm prog = IPid (Pid [0] prog (dual prog) tm) [[x,0] | x <- [0..]]
newtype InterleavedChain internalPid from to res
= InterleavedChain { runInterleavedChain :: internalPid ->
from ->
IO (res, to, internalPid)
}
myPid :: InterleavedChain (InternalPid prog prog' sessionsToIdx idxsToPairStructs) from from (Pid prog prog' sessionsToIdx idxsToPairStructs)
myPid = InterleavedChain $ \p x -> return (iPidToPid p, x, p)
instance SMonad (InterleavedChain internalPid) where
f ~>> g = InterleavedChain $
\p x -> do { (_, y, p') <- runInterleavedChain f p x
; runInterleavedChain g p' y
}
f ~>>= g = InterleavedChain $
\p x -> do { (a, y, p') <- runInterleavedChain f p x
; runInterleavedChain (g a) p' y
}
sreturn a = InterleavedChain $
\p x -> return (a, x, p)
instance SMonadIO (InterleavedChain internalPid) where
sliftIO f = InterleavedChain $
\p x -> do { a <- f
; return (a, x, p)
}
class BuildPidTyMap prog stlst tymap | prog stlst -> tymap where
type BuildPidTyMapT prog stlst
buildPidTyMap :: prog -> stlst -> IO tymap
instance (BuildPidTyMap' prog stlst (TyMap Nil Nil) tymap) =>
BuildPidTyMap prog stlst tymap where
type BuildPidTyMapT prog stlst = BuildPidTyMapT' prog stlst (TyMap Nil Nil)
buildPidTyMap prog stlst = buildPidTyMap' prog stlst emptyMap
class BuildPidTyMap' prog stlist tymap1 tymap2 | prog stlist tymap1 -> tymap2 where
type BuildPidTyMapT' prog stlist tymap1
buildPidTyMap' :: prog -> stlist -> tymap1 -> IO tymap2
instance BuildPidTyMap' prog Nil acc acc where
type BuildPidTyMapT' prog Nil acc = acc
buildPidTyMap' _ _ m = return m
instance ( BuildPidTyMap' prog nxt
(TyMap keyToIdx' idxToValue') (TyMap keyToIdx'' idxToValue'')
, MapInsert (TyMap keyToIdx idxToValue) init
(MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))))
(TyMap keyToIdx' idxToValue')
, TyList nxt
) =>
BuildPidTyMap' prog (Cons (init, False) nxt) (TyMap keyToIdx idxToValue)
(TyMap keyToIdx'' idxToValue'') where
type BuildPidTyMapT' prog (Cons (init, False) nxt) (TyMap keyToIdx idxToValue)
= BuildPidTyMapT' prog nxt (TyMap (Cons init keyToIdx)
(Cons ((MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog (DualT prog)
((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))))
idxToValue))
buildPidTyMap' prog lst m
= do { mvar <- newMVar Map.empty
; buildPidTyMap' prog nxt (m' mvar)
}
where
(init, FF) = tyHead lst
nxt = tyTail lst
m' :: (MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))) ->
TyMap keyToIdx' idxToValue'
m' mvar = mapInsert init mvar m
instance ( BuildPidTyMap' prog nxt (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue')
, TyList nxt
) =>
BuildPidTyMap' prog (Cons (init, True) nxt) (TyMap keyToIdx idxToValue)
(TyMap keyToIdx' idxToValue') where
type BuildPidTyMapT' prog (Cons (init, True) nxt) (TyMap keyToIdx idxToValue) = BuildPidTyMapT' prog nxt (TyMap keyToIdx idxToValue)
buildPidTyMap' prog lst m = buildPidTyMap' prog (tyTail lst) m
type instance Outgoing prog (Cons (RecvPid False t) nxt) = Outgoing prog nxt
type instance Outgoing prog (Cons (SendPid False t) nxt) = Cons (Pid prog (DualT prog) (LHS (BuildPidTyMapT prog t)) (RHS (BuildPidTyMapT prog t))) (Outgoing prog nxt)
type instance Outgoing prog (Cons (RecvPid True t) nxt) = Outgoing prog nxt
type instance Outgoing prog (Cons (SendPid True t) nxt) = Cons (Pid (DualT prog) prog (LHS (BuildPidTyMapT prog t)) (RHS (BuildPidTyMapT prog t))) (Outgoing prog nxt)
instance ( ExpandPids prog nxt nxt'
, TyList nxt
, TyList nxt'
, BuildPidTyMap progO t (TyMap sessionsToIdx idxsToPairStructs)
, If invert prog' prog progO
, Dual prog prog'
, Dual progO progO'
) =>
ExpandPids prog (Cons (RecvPid invert t) nxt) (Cons (Recv (Pid progO progO' sessionsToIdx idxsToPairStructs)) nxt') where
expandPids prog lst = modifyCons (const undefined) (expandPids prog) lst
instance ( ExpandPids prog nxt nxt'
, TyList nxt
, TyList nxt'
, BuildPidTyMap progO t (TyMap sessionsToIdx idxsToPairStructs)
, If invert prog' prog progO
, Dual prog prog'
, Dual progO progO'
) =>
ExpandPids prog (Cons (SendPid invert t) nxt) (Cons (Send (Pid progO progO' sessionsToIdx idxsToPairStructs)) nxt') where
expandPids prog lst = modifyCons (const undefined) (expandPids prog) lst
type family LHS thing
type instance LHS (TyMap sessionsToIdx idxsToPairStructs) = sessionsToIdx
type family RHS thing
type instance RHS (TyMap sessionsToIdx idxsToPairStructs) = idxsToPairStructs
data PairStruct :: * -> * -> * -> * -> * where
PS ::RawPid ->
(SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) -> IO ()) ->
PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))
instance Eq (PairStruct init prog prog' start) where
(==) (PS x _) (PS y _) = x == y
instance Ord (PairStruct init prog prog' start) where
compare (PS x _) (PS y _) = compare x y
class CreateSession invert init prog prog' fromO fromI progOut progIn
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem where
createSession :: init -> invert -> Pid prog prog' sessionsToIdxThem idxsToPairStructsThem ->
InterleavedChain (InternalPid prog prog' sessionsToIdxMe idxsToPairStructsMe)
(TyMap keyToIdxMe idxToValueMe) (TyMap keyToIdxMe' idxToValueMe') idxOfThem
instance forall init prog prog' fromO fromI progOut progIn
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' .
( ProgramToMVarsOutgoingT prog prog ~ progOut
, ProgramToMVarsOutgoingT prog' prog' ~ progIn
, ProgramToMVarsOutgoing prog prog progOut
, ProgramToMVarsOutgoing prog' prog' progIn
, SWellFormedConfig init (D0 E) prog
, SWellFormedConfig init (D0 E) prog'
, TyListIndex progOut init (MVar (ProgramCell (Cell fromO)))
, TyListIndex progIn init (MVar (ProgramCell (Cell fromI)))
, TyListIndex prog init current'
, ExpandPids prog current' current
, MapLookup (TyMap sessionsToIdxMe idxsToPairStructsMe) init
(MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))))
, MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem
, MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem
(SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe')
) =>
CreateSession False init prog prog' fromO fromI progOut progIn
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem where
createSession init FF (Pid remotePid _ _ _) =
InterleavedChain $
\ipid@(IPid (Pid localPid _ _ localSTMap) _) mp ->
do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog prog'
((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))
= mapLookup localSTMap init
; pidFuncMap <- takeMVar pidFuncMapMVar
; emptyMVar :: MVar (TyMap keyToIdxMe' idxToValueMe') <- newEmptyMVar
; psMVar :: MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))
<- case Map.lookup (localPid, remotePid) pidFuncMap of
Nothing
-> do { empty <- newEmptyMVar
; putMVar pidFuncMapMVar (Map.insert (localPid, remotePid) empty pidFuncMap)
; return empty
}
(Just mv)
-> do { putMVar pidFuncMapMVar pidFuncMap
; return mv
}
; let idxOfThem :: idxOfThem = mapSize mp
ps :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))
= PS localPid (f idxOfThem mp emptyMVar)
; putMVar psMVar ps
; mp' <- takeMVar emptyMVar
; return (idxOfThem, mp', ipid)
}
where
f :: idxOfThem -> (TyMap keyToIdxMe idxToValueMe) ->
MVar (TyMap keyToIdxMe' idxToValueMe') ->
SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) ->
IO ()
f idxOfThem mp mv localST
= do { ((), localST') <- runSessionChain sjump localST
; putMVar mv (mapInsert idxOfThem localST' mp)
}
instance forall init prog prog' fromO fromI progOut progIn
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' currentUX currentUX' .
( ProgramToMVarsOutgoingT prog prog ~ progOut
, ProgramToMVarsOutgoingT prog' prog' ~ progIn
, ProgramToMVarsOutgoing prog prog progOut
, ProgramToMVarsOutgoing prog' prog' progIn
, SWellFormedConfig init (D0 E) prog
, SWellFormedConfig init (D0 E) prog'
, TyListIndex progOut init (MVar (ProgramCell (Cell fromO)))
, TyListIndex progIn init (MVar (ProgramCell (Cell fromI)))
, TyListIndex prog init currentUX
, ExpandPids prog currentUX current
, TyListIndex prog' init currentUX'
, ExpandPids prog' currentUX' current'
, MapLookup (TyMap sessionsToIdxThem idxsToPairStructsThem) init
(MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))))
, MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem
, MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem
(SessionState prog' prog (current', fromI, fromO)) (TyMap keyToIdxMe' idxToValueMe')
) =>
CreateSession True init prog prog' fromO fromI progOut progIn
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem where
createSession init TT (Pid remotePid prog prog' remoteSTMap) =
InterleavedChain $
\ipid@(IPid (Pid localPid _ _ _) _) mp ->
do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog prog'
((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))
= mapLookup remoteSTMap init
; pidFuncMap <- takeMVar pidFuncMapMVar
; mvarsOut <- programToMVarsOutgoing prog prog
; mvarsIn <- programToMVarsOutgoing prog' prog'
; aNotify <- newMVar Nothing
; bNotify <- newMVar Nothing
; let (theirST :: SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))
= SessionState prog prog' mvarsOut mvarsIn undefined aNotify undefined bNotify undefined
(myST :: SessionState prog' prog ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))
= SessionState prog' prog mvarsIn mvarsOut undefined bNotify undefined aNotify undefined
idxOfThem :: idxOfThem = mapSize mp
; case Map.lookup (remotePid, localPid) pidFuncMap of
Nothing
-> do { newEmptyMVar <- newEmptyMVar
; putMVar pidFuncMapMVar (Map.insert (remotePid, localPid) newEmptyMVar pidFuncMap)
; ps <- takeMVar newEmptyMVar
; modifyMVar_ pidFuncMapMVar (return . Map.delete (remotePid, localPid))
; case ps of
(PS _ (f :: SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) -> IO ()))
-> f theirST
}
(Just fullMVar)
-> do { ps <- takeMVar fullMVar
; putMVar pidFuncMapMVar (Map.delete (remotePid, localPid) pidFuncMap)
; case ps of
(PS _ (f :: SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) -> IO ()))
-> f theirST
}
; ((), myST') <- runSessionChain sjump myST
; return (idxOfThem, mapInsert idxOfThem myST' mp, ipid)
}
data MultiReceive :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * where
MultiReceiveNil :: MultiReceive Nil prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
MultiReceiveCons :: (ch, InterleavedChain (InternalPid prog prog' sessionsToIdx idxsToPairStructs)
(TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res) ->
MultiReceive chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
MultiReceive (Cons ch chs) prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
(~|||~) :: ( MapLookup (TyMap keyToIdx idxToValue) ch (SessionState progS progS' ((Cons (Recv t) nxt), fromO, (Cons t nxt')))
) =>
(ch, InterleavedChain (InternalPid prog prog' sessionsToIdx idxsToPairStructs) (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res) ->
MultiReceive chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
MultiReceive (Cons ch chs) prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
(~|||~) (ch, func) nxt = MultiReceiveCons (ch, func) nxt
infixr 5 ~|||~
multiReceive :: forall chs len keyToIdx idxToValue prog prog' sessionsToIdx idxsToPairStructs keyToIdx' idxToValue' res .
( TyListLength chs len
, SmallerThanBool (D0 E) len True
, SetIncomingNotify (TyMap keyToIdx idxToValue) chs
, FindNonEmptyIncoming (TyMap keyToIdx idxToValue) chs
, TypeNumberToInt len
) =>
(MultiReceive chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res) ->
InterleavedChain (InternalPid prog prog' sessionsToIdx idxsToPairStructs) (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res
multiReceive functions =
InterleavedChain $
\ipid mp ->
do { notifyChan <- newChan
; chMaybe <- setIncomingNotify notifyChan mp 0 chs
; case chMaybe of
(Just idx) -> do { unsetIncomingNotify mp chs idx
; runInterleavedChain (walkMultiReceives idx functions) ipid mp
}
Nothing -> blockOnNotifyChan ipid notifyChan mp functions
}
where
chs = undefined :: chs
chsCount = tyNumToInt . tyListLength $ chs
blockOnNotifyChan ipid chan mp functions
= do { readChan chan
; unsetIncomingNotify mp chs chsCount
; idx <- findNonEmptyIncoming mp 0 chs
; runInterleavedChain (walkMultiReceives idx functions) ipid mp
}
class SetIncomingNotify mp idxs where
setIncomingNotify :: Chan () -> mp -> Int -> idxs -> IO (Maybe Int)
unsetIncomingNotify :: mp -> idxs -> Int -> IO ()
instance SetIncomingNotify mp Nil where
setIncomingNotify _ _ _ _ = return Nothing
unsetIncomingNotify _ _ _ = return ()
instance forall keyToIdx idxToValue idx prog prog' current fromO fromI nxt .
( MapLookup (TyMap keyToIdx idxToValue) idx (SessionState prog prog' (current, fromO, fromI))
, SetIncomingNotify (TyMap keyToIdx idxToValue) nxt
, TypeNumberToInt idx
) =>
SetIncomingNotify (TyMap keyToIdx idxToValue) (Cons idx nxt) where
setIncomingNotify chan mp acc idxs
= do { let st = mapLookup mp idx
; isEmpty <- setIncomingNotify' chan st
; if isEmpty
then setIncomingNotify chan mp (acc+1) idxs'
else return . return $ acc
}
where
idxs' = tyTail idxs
idx = tyHead idxs
setIncomingNotify' :: Chan () -> SessionState prog prog' (current, fromO, fromI) -> IO Bool
setIncomingNotify' chan (SessionState _ _ _ _ _ _ _ inNotifyMVar incoming)
= do { swapMVar inNotifyMVar (Just chan)
; isEmptyMVar incoming
}
unsetIncomingNotify mp idxs count
= do { let st = mapLookup mp idx
; unsetIncomingNotify' st
; if 0 == count
then return ()
else unsetIncomingNotify mp idxs' (count 1)
}
where
idx = tyHead idxs
idxs' = tyTail idxs
unsetIncomingNotify' :: SessionState prog prog' (current, fromO, fromI) -> IO ()
unsetIncomingNotify' (SessionState _ _ _ _ _ _ _ inNotifyMVar _)
= do { swapMVar inNotifyMVar Nothing
; return ()
}
class WalkMultiReceives chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res where
walkMultiReceives :: Int -> MultiReceive chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
InterleavedChain (InternalPid prog prog' sessionsToIdx idxsToPairStructs) (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res
instance WalkMultiReceives chs prog prog' sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res where
walkMultiReceives 0 (MultiReceiveCons (_, func) _)
= func
walkMultiReceives n (MultiReceiveCons _ nxt) = walkMultiReceives (n 1) nxt
walkMultiReceives _ _ = error "The Truly Impossible Happened."
class FindNonEmptyIncoming mp idxs where
findNonEmptyIncoming :: mp -> Int -> idxs -> IO Int
instance FindNonEmptyIncoming mp Nil where
findNonEmptyIncoming _ _ _ = error "Wasn't expecting to run out of channels in multiReceive!"
instance forall keyToIdx idxToValue idx nxt prog prog' current fromO fromI .
( FindNonEmptyIncoming (TyMap keyToIdx idxToValue) nxt
, MapLookup (TyMap keyToIdx idxToValue) idx (SessionState prog prog' (current, fromO, fromI))
, TypeNumberToInt idx
) =>
FindNonEmptyIncoming (TyMap keyToIdx idxToValue) (Cons idx nxt) where
findNonEmptyIncoming mp acc idxs
= do { let st = mapLookup mp idx
; isEmpty <- checkIfEmpty st
; if isEmpty
then findNonEmptyIncoming mp (acc+1) idxs'
else return acc
}
where
idxs' = tyTail idxs
idx = tyHead idxs
checkIfEmpty :: SessionState prog prog' (current, fromO, fromI) -> IO Bool
checkIfEmpty (SessionState _ _ _ _ _ _ _ _ incoming) = isEmptyMVar incoming