module Control.Concurrent.Session.Pid
( makePid
, rootPid
, iPidToPid
, myPid
, BuildPidTyMap (..)
, BuildInvertedSessionsSet (..)
, CreateSession (..)
, PidEq (..)
, MultiReceive (MultiReceiveNil)
, (~|||~)
, multiReceive
) where
import Control.Concurrent.Session.Base.Bool
import Control.Concurrent.Session.Base.Number
import Control.Concurrent.Session.Base.Map
import Control.Concurrent.Session.Base.List
import Control.Concurrent.Session.SessionType
import Control.Concurrent.Session.Types
import Control.Concurrent.Session.Runtime
import Control.Concurrent
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
makePid :: InternalPid prog prog' invertedSessionsO sessionsToIdxO idxsToPairStructsO ->
invertedSessionsN -> TyMap sessionsToIdxN idxsToPairStructsN ->
(InternalPid prog prog' invertedSessionsO sessionsToIdxO idxsToPairStructsO,
InternalPid prog prog' invertedSessionsN sessionsToIdxN idxsToPairStructsN)
makePid (IPid orig@(Pid _ _) (p:ps)) _ childTM = ((IPid orig ps), child)
where
child = IPid (Pid p childTM) [x:p | x <- [0..]]
makePid (IPid _ []) _ _ = error "Out of pids. Interesting."
rootPid :: ( Dual prog prog'
, DualT prog ~ prog'
) =>
TyMap sessionsToIdx idxsToPairStructs -> invertedSessions -> prog ->
InternalPid prog prog' invertedSessions sessionsToIdx idxsToPairStructs
rootPid tm _ _ = IPid (Pid [0] tm) [[x,0] | x <- [0..]]
myPid :: InterleavedChain (InternalPid prog prog' invertedSessions sessionsToIdx idxsToPairStructs) from from (Pid prog prog' invertedSessions sessionsToIdx idxsToPairStructs)
myPid = InterleavedChain $ \p x -> return (iPidToPid p, 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 { m' <- buildPidTyMap' prog nxt m
; mvar <- newMVar Map.empty
; return $ f mvar m'
}
where
(init, FF) = tyHead lst
nxt = tyTail lst
f :: (MVar (Map (RawPid, RawPid)
(MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))) ->
TyMap keyToIdx' idxToValue' ->
TyMap keyToIdx'' idxToValue''
f mvar = mapInsert init mvar
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
class BuildInvertedSessionsSet stlist set | stlist -> set where
type BuildInvertedSessionsSetT stlist
buildInvertedSessionsSet :: stlist -> set
instance BuildInvertedSessionsSet Nil Nil where
type BuildInvertedSessionsSetT Nil = Nil
buildInvertedSessionsSet _ = nil
instance ( BuildInvertedSessionsSet nxt set
) =>
BuildInvertedSessionsSet (Cons (init, False) nxt) set where
type BuildInvertedSessionsSetT (Cons (init, False) nxt) = BuildInvertedSessionsSetT nxt
buildInvertedSessionsSet lst = buildInvertedSessionsSet (tyTail lst)
instance ( BuildInvertedSessionsSet nxt set
, TyList set
) =>
BuildInvertedSessionsSet (Cons (init, True) nxt) (Cons init set) where
type BuildInvertedSessionsSetT (Cons (init, True) nxt) = Cons init (BuildInvertedSessionsSetT nxt)
buildInvertedSessionsSet lst = cons (fst . tyHead $ lst) . buildInvertedSessionsSet . tyTail $ lst
instance ( Expand prog nxt nxt'
, ExpandPid prog (SendPid invert idxs) expandedSendPid
) =>
Expand prog (Cons (SendPid invert idxs) nxt) (Cons expandedSendPid nxt') where
type ExpandT prog (Cons (SendPid invert idxs) nxt) = Cons (ExpandPidT prog (SendPid invert idxs)) (ExpandT prog nxt)
instance ( Expand prog nxt nxt'
, ExpandPid prog (RecvPid invert idxs) expandedRecvPid
) =>
Expand prog (Cons (RecvPid invert idxs) nxt) (Cons expandedRecvPid nxt') where
type ExpandT prog (Cons (RecvPid invert idxs) nxt) = Cons (ExpandPidT prog (RecvPid invert idxs)) (ExpandT prog nxt)
class ExpandPid prog pid expanded | prog pid -> expanded where
type ExpandPidT prog pid
instance ( Dual prog prog'
, BuildInvertedSessionsSet idxs invertedSessions
, BuildPidTyMap prog idxs (TyMap sessionsToIdx idxsToPairStructs)
) =>
ExpandPid prog (SendPid False idxs) (Send (SpecialPid, (Pid prog prog' invertedSessions sessionsToIdx idxsToPairStructs))) where
type ExpandPidT prog (SendPid False idxs)
= Send ( SpecialPid
, (Pid prog (DualT prog) (BuildInvertedSessionsSetT idxs) (LHS (BuildPidTyMapT prog idxs)) (RHS (BuildPidTyMapT prog idxs)))
)
instance ( Dual prog prog'
, BuildInvertedSessionsSet idxs invertedSessions
, BuildPidTyMap prog' idxs (TyMap sessionsToIdx idxsToPairStructs)
) =>
ExpandPid prog (SendPid True idxs) (Send (SpecialPid, (Pid prog' prog invertedSessions sessionsToIdx idxsToPairStructs))) where
type ExpandPidT prog (SendPid True idxs)
= Send ( SpecialPid
, (Pid (DualT prog) prog (BuildInvertedSessionsSetT idxs) (LHS (BuildPidTyMapT (DualT prog) idxs)) (RHS (BuildPidTyMapT (DualT prog) idxs)))
)
instance ( Dual prog prog'
, BuildInvertedSessionsSet idxs invertedSessions
, BuildPidTyMap prog idxs (TyMap sessionsToIdx idxsToPairStructs)
) =>
ExpandPid prog (RecvPid False idxs) (Recv (SpecialPid, (Pid prog prog' invertedSessions sessionsToIdx idxsToPairStructs))) where
type ExpandPidT prog (RecvPid False idxs)
= Recv ( SpecialPid
, (Pid prog (DualT prog) (BuildInvertedSessionsSetT idxs) (LHS (BuildPidTyMapT prog idxs)) (RHS (BuildPidTyMapT prog idxs)))
)
instance ( Dual prog prog'
, BuildInvertedSessionsSet idxs invertedSessions
, BuildPidTyMap prog' idxs (TyMap sessionsToIdx idxsToPairStructs)
) =>
ExpandPid prog (RecvPid True idxs) (Recv (SpecialPid, (Pid prog' prog invertedSessions sessionsToIdx idxsToPairStructs))) where
type ExpandPidT prog (RecvPid True idxs)
= Recv ( SpecialPid
, (Pid (DualT prog) prog (BuildInvertedSessionsSetT idxs) (LHS (BuildPidTyMapT (DualT prog) idxs)) (RHS (BuildPidTyMapT (DualT prog) idxs)))
)
type family LHS thing
type instance LHS (TyMap sessionsToIdx idxsToPairStructs) = sessionsToIdx
type family RHS thing
type instance RHS (TyMap sessionsToIdx idxsToPairStructs) = idxsToPairStructs
class CreateSession invert init prog prog'
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where
createSession :: init -> invert -> Pid prog prog' invertedSessionsThem sessionsToIdxThem idxsToPairStructsThem ->
InterleavedChain (InternalPid prog prog' invertedSessionsMe 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' invertedSessionsMe invertedSessionsThem .
( ProgramToMVarsOutgoingT prog prog ~ progOut
, ProgramToMVarsOutgoingT 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'
, Expand 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))))))
, TyListMember invertedSessionsThem init True
, MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem
, MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem
(SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe')
) =>
CreateSession False init prog prog'
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem 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' invertedSessionsMe invertedSessionsThem .
( 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
, Expand prog currentUX current
, TyListIndex prog' init currentUX'
, Expand 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))))))
, TyListMember invertedSessionsMe init True
, MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem
, MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem
(SessionState prog' prog (current', fromI, fromO)) (TyMap keyToIdxMe' idxToValueMe')
) =>
CreateSession True init prog prog'
sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem
keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where
createSession init TT (Pid remotePid 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 mvarsOut mvarsIn undefined aNotify undefined bNotify undefined
(myST :: SessionState prog' prog ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))
= SessionState 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))
; fun ps theirST
}
(Just fullMVar)
-> do { ps <- takeMVar fullMVar
; putMVar pidFuncMapMVar (Map.delete (remotePid, localPid) pidFuncMap)
; fun ps theirST
}
; ((), myST') <- runSessionChain sjump myST
; return (idxOfThem, mapInsert idxOfThem myST' mp, ipid)
}
where
prog = undefined::prog
prog' = undefined::prog'
fun :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) ->
SessionState prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) -> IO ()
fun (PS _ f) theirST = f theirST
data MultiReceive :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * where
MultiReceiveNil :: MultiReceive Nil prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
MultiReceiveCons :: (ch, InterleavedChain (InternalPid prog prog' invertedSessions sessionsToIdx idxsToPairStructs)
(TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res) ->
MultiReceive chs prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
MultiReceive (Cons ch chs) prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
(~|||~) :: ( MapLookup (TyMap keyToIdx idxToValue) ch (SessionState progS progS' ((Cons (Recv (sp, t)) nxt), fromO, (Cons t nxt')))
) =>
(ch, InterleavedChain (InternalPid prog prog' invertedSessions sessionsToIdx idxsToPairStructs) (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res) ->
MultiReceive chs prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
MultiReceive (Cons ch chs) prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res
(~|||~) (ch, func) nxt = MultiReceiveCons (ch, func) nxt
infixr 5 ~|||~
multiReceive :: forall chs len keyToIdx idxToValue prog prog' invertedSessions 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' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res) ->
InterleavedChain (InternalPid prog prog' invertedSessions 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' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res where
walkMultiReceives :: Int -> MultiReceive chs prog prog' invertedSessions sessionsToIdx idxsToPairStructs keyToIdx idxToValue keyToIdx' idxToValue' res ->
InterleavedChain (InternalPid prog prog' invertedSessions sessionsToIdx idxsToPairStructs) (TyMap keyToIdx idxToValue) (TyMap keyToIdx' idxToValue') res
instance WalkMultiReceives chs prog prog' invertedSessions 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