git.iko.soy/distributed-process
on master help sign in
Simplify the implementation of match
d866e29Edsko de Vries
distributed-process/src/Control/Distributed/Process.hs+21−23
compare with master
unifiedsplit
@@ -69,6 +69,7 @@ module Control.Distributed.Process
69 , Match
69 , Match
70 , match
70 , match
71 , matchIf
71 , matchIf
72+ , matchUnknown
72 , receiveWait
73 , receiveWait
73 , receiveTimeout
74 , receiveTimeout
74 -- * Monitoring and linking
75 -- * Monitoring and linking
@@ -122,10 +123,7 @@ import Control.Concurrent.MVar ( newMVar
122 )
123 )
123import Control.Concurrent.Chan (newChan, writeChan)
124import Control.Concurrent.Chan (newChan, writeChan)
124import Control.Distributed.Process.Internal.CQueue (enqueue, dequeue, newCQueue)
125import Control.Distributed.Process.Internal.CQueue (enqueue, dequeue, newCQueue)
125−import Control.Distributed.Process.Serializable ( Serializable
126+import Control.Distributed.Process.Serializable (Serializable, fingerprint)
126− , Fingerprint
127− , fingerprint
128− )
129import qualified Network.Transport as NT ( Transport
127import qualified Network.Transport as NT ( Transport
130 , EndPoint
128 , EndPoint
131 , Connection
129 , Connection
@@ -223,42 +221,42 @@ unlink = postCtrlMsg . Unlink
223-- Matching --
221-- Matching --
224--------------------------------------------------------------------------------
222--------------------------------------------------------------------------------
225
223
226−data Match b =
224+-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
227− forall a. Serializable a => Match Fingerprint (a -> Process b)
225+newtype Match b = Match { unMatch :: Message -> Maybe (Process b) }
228− | forall a. Serializable a => MatchIf Fingerprint (a -> Bool) (a -> Process b)
229
226
227+-- | Match against any message of the right type
230match :: forall a b. Serializable a => (a -> Process b) -> Match b
228match :: forall a b. Serializable a => (a -> Process b) -> Match b
231−match = Match (fingerprint (undefined :: a))
229+match = matchIf (const True)
232
230
231+-- | Match against any message of the right type that satisfies a predicate
233matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
232matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
233+matchIf c p = Match $ \msg ->
234+ let decoded :: a
235+ decoded = decode . messageEncoding $ msg in
234−matchIf = MatchIf (fingerprint (undefined :: a))
236+ if messageFingerprint msg == fingerprint (undefined :: a) && c decoded
237+ then Just . p . decode . messageEncoding $ msg
238+ else Nothing
239+
240+-- | Remove any message from the queue
241+matchUnknown :: Process b -> Match b
242+matchUnknown = Match . const . Just
235
243
244+-- | Test the matches in order against each message in the queue
236receiveWait :: [Match b] -> Process b
245receiveWait :: [Match b] -> Process b
237receiveWait ms = do
246receiveWait ms = do
238 queue <- processQueue <$> ask
247 queue <- processQueue <$> ask
239− Just proc <- liftIO $ dequeue queue Nothing (map evalMatch ms)
248+ Just proc <- liftIO $ dequeue queue Nothing (map unMatch ms)
240 proc
249 proc
241
250
251+-- | Like 'receiveWait' but with a timeout
242receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
252receiveTimeout :: Int -> [Match b] -> Process (Maybe b)
243receiveTimeout t ms = do
253receiveTimeout t ms = do
244 queue <- processQueue <$> ask
254 queue <- processQueue <$> ask
245− mProc <- liftIO $ dequeue queue (Just t) (map evalMatch ms)
255+ mProc <- liftIO $ dequeue queue (Just t) (map unMatch ms)
246 case mProc of
256 case mProc of
247 Nothing -> return Nothing
257 Nothing -> return Nothing
248 Just proc -> Just <$> proc
258 Just proc -> Just <$> proc
249
259
250−evalMatch :: Match b -> Message -> Maybe (Process b)
251−evalMatch (Match fp proc) msg =
252− let decoded = decode . messageEncoding $ msg in
253− if messageFingerprint msg == fp
254− then Just . proc $ decoded
255− else Nothing
256−evalMatch (MatchIf fp cond proc) msg =
257− let decoded = decode . messageEncoding $ msg in
258− if messageFingerprint msg == fp && cond decoded
259− then Just . proc $ decoded
260− else Nothing
261−
262--------------------------------------------------------------------------------
260--------------------------------------------------------------------------------
263-- Auxiliary API --
261-- Auxiliary API --
264--------------------------------------------------------------------------------
262--------------------------------------------------------------------------------