@@ -76,13 +76,25 @@ data BlockSpec =
76 | Blocking
76 | Blocking
77 | Timeout Int
77 | Timeout Int
81+-- They can be either a message match or a channel match.
79data MatchOn m a
82data MatchOn m a
80 = MatchMsg (m -> Maybe a)
83 = MatchMsg (m -> Maybe a)
81 | MatchChan (STM a)
84 | MatchChan (STM a)
82 deriving (Functor)
85 deriving (Functor)
87+-- Lists of chunks of matches
89+-- Two consecutive chunks never have the same kind of matches. i.e. if one chunk
90+-- contains message matches then the next one must contain channel matches and
84type MatchChunks m a = [Either [m -> Maybe a] [STM a]]
92type MatchChunks m a = [Either [m -> Maybe a] [STM a]]
94+-- Splits a list of matches into chunks.
96+-- > concatMap (either (map MatchMsg) (map MatchChan)) . chunkMatches == id
86chunkMatches :: [MatchOn m a] -> MatchChunks m a
98chunkMatches :: [MatchOn m a] -> MatchChunks m a
87chunkMatches [] = []
99chunkMatches [] = []
88chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest
100chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest
@@ -90,6 +102,7 @@ chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest
90chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest
102chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest
91 where (chk, rest) = spanMatchChan ms
103 where (chk, rest) = spanMatchChan ms
105+-- | @spanMatchMsg = first (map (\(MatchMsg x) -> x)) . span isMatchMsg@
93spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a])
106spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a])
94spanMatchMsg [] = ([],[])
107spanMatchMsg [] = ([],[])
95spanMatchMsg (m : ms)
108spanMatchMsg (m : ms)
@@ -97,6 +110,7 @@ spanMatchMsg (m : ms)
97 | otherwise = ([], m:ms)
110 | otherwise = ([], m:ms)
98 where !(msgs,rest) = spanMatchMsg ms
111 where !(msgs,rest) = spanMatchMsg ms
113+-- | @spanMatchMsg = first (map (\(MatchChan x) -> x)) . span isMatchChan@
100spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a])
114spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a])
101spanMatchChan [] = ([],[])
115spanMatchChan [] = ([],[])
102spanMatchChan (m : ms)
116spanMatchChan (m : ms)
@@ -128,6 +142,7 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus
128 -- Decrement counter is smth is returned from the queue,
142 -- Decrement counter is smth is returned from the queue,
129 -- this is safe to use as method is called under a mask
143 -- this is safe to use as method is called under a mask
130 -- and there is no 'unmasked' operation inside
144 -- and there is no 'unmasked' operation inside
145+ decrementJust :: IO (Maybe (Either a a)) -> IO (Maybe a)
131 decrementJust f =
146 decrementJust f =
132 traverse (either return (\x -> decrement >> return x)) =<< f
147 traverse (either return (\x -> decrement >> return x)) =<< f
133 decrement = atomically $ modifyTVar' size pred
148 decrement = atomically $ modifyTVar' size pred
@@ -144,6 +159,10 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus
144 arr' <- grabNew arr
159 arr' <- grabNew arr
145 goCheck chunks arr'
160 goCheck chunks arr'
162+ -- Yields the value of the first succesful STM transaction as
163+ -- @Just (Left v)@. If all transactions fail, yields the value of the second
165+ waitChans :: [STM a] -> STM (Maybe (Either a a)) -> STM (Maybe (Either a a))
147 waitChans ports on_block =
166 waitChans ports on_block =
148 foldr orElse on_block (map (fmap (Just . Left)) ports)
167 foldr orElse on_block (map (fmap (Just . Left)) ports)
@@ -152,6 +171,10 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus
152 -- mailbox. For channel matches, we do a non-blocking check at
171 -- mailbox. For channel matches, we do a non-blocking check at
153 -- this point.
172 -- this point.
174+ -- Yields @Just (Left a)@ when a channel is matched, @Just (Right a)@
175+ -- when a message is matched and @Nothing@ when there are no messages and we
155 goCheck :: MatchChunks m a
178 goCheck :: MatchChunks m a
156 -> StrictList m -- messages to check, in this order
179 -> StrictList m -- messages to check, in this order
157 -> IO (Maybe (Either a a))
180 -> IO (Maybe (Either a a))
@@ -250,6 +273,7 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus
250 checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)
273 checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)
251 checkArrived matches list = go list Nil
274 checkArrived matches list = go list Nil
276+ -- @go xs ys@ searches for a message match in @append xs ys@
253 go Nil Nil = (Nil, Nothing)
277 go Nil Nil = (Nil, Nothing)
254 go Nil r = go r Nil
278 go Nil r = go r Nil
255 go (Append xs ys) tl = go xs (append ys tl)
279 go (Append xs ys) tl = go xs (append ys tl)