git.iko.soy/distributed-process
on master help sign in
Functor/Appl/Alt/Monad ReceivePort instances

Closes #48. Closes #49. Closes #50. Closes #51.

commit14a1d99090c64c1e14cc1b0f7659dca47acdb0bc authorEdsko de Vries <edsko@edsko.net> dateTue 6 Nov 2012, 11:58 (14 years ago) parenta91fb7e
2 files changed+80−17
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+6−3 distributed-process/tests/TestCH.hs+74−14
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+6−3
@@ -82,9 +82,9 @@ import Control.Category ((>>>))
8282import Control.Exception (Exception)
8383import Control.Concurrent (ThreadId)
8484import Control.Concurrent.Chan (Chan)
85−import Control.Concurrent.STM (STM, TVar)
85+import Control.Concurrent.STM (STM)
8686import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
87−import Control.Applicative (Applicative, (<$>), (<*>))
87+import Control.Applicative (Applicative, Alternative, (<$>), (<*>))
8888import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
8989import Control.Monad.IO.Class (MonadIO)
9090import Control.Distributed.Process.Serializable
@@ -262,8 +262,11 @@ newtype SendPort a = SendPort {
262262 deriving (Typeable, Binary, Show, Eq, Ord)
263263
264264-- | The receive end of a typed channel (not serializable)
265+--
266+-- Note that 'ReceivePort' implements 'Functor', 'Applicative', 'Alternative'
267+-- and 'Monad'. This is especially useful when merging receive ports.
265268newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }
266− deriving Typeable
269+ deriving (Typeable, Functor, Applicative, Alternative, Monad)
267270
268271{-
269272data ReceivePort a =
distributed-process/tests/TestCH.hs+74−14
@@ -19,7 +19,7 @@ import Control.Concurrent.MVar
1919import Control.Monad (replicateM_, replicateM, forever)
2020import Control.Exception (SomeException, throwIO)
2121import qualified Control.Exception as Ex (catch)
22−import Control.Applicative ((<$>), (<*>))
22+import Control.Applicative ((<$>), (<*>), pure, (<|>))
2323import qualified Network.Transport as NT (Transport, closeEndPoint)
2424import Network.Socket (sClose)
2525import Network.Transport.TCP
@@ -762,22 +762,82 @@ testReceiveChanTimeout transport = do
762762
763763 takeMVar done
764764
765+-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
766+testReceiveChanFeatures :: NT.Transport -> Assertion
767+testReceiveChanFeatures transport = do
768+ done <- newEmptyMVar
769+
770+ forkTry $ do
771+ localNode <- newLocalNode transport initRemoteTable
772+ runProcess localNode $ do
773+ (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)
774+ (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
775+
776+ -- Test Functor instance
777+
778+ sendChan spInt 2
779+ sendChan spBool False
780+
781+ rp1 <- mergePortsBiased [even <$> rpInt, rpBool]
782+
783+ True <- receiveChan rp1
784+ False <- receiveChan rp1
785+
786+ -- Test Applicative instance
787+
788+ sendChan spInt 3
789+ sendChan spInt 4
790+
791+ let rp2 = pure (+) <*> rpInt <*> rpInt
792+
793+ 7 <- receiveChan rp2
794+
795+ -- Test Alternative instance
796+
797+ sendChan spInt 3
798+ sendChan spBool True
799+
800+ let rp3 = (even <$> rpInt) <|> rpBool
801+
802+ False <- receiveChan rp3
803+ True <- receiveChan rp3
804+
805+ -- Test Monad instance
806+
807+ sendChan spBool True
808+ sendChan spBool False
809+ sendChan spInt 5
810+
811+ let rp4 :: ReceivePort Int
812+ rp4 = do b <- rpBool
813+ if b
814+ then rpInt
815+ else return 7
816+
817+ 5 <- receiveChan rp4
818+ 7 <- receiveChan rp4
819+
820+ liftIO $ putMVar done ()
821+
822+ takeMVar done
823+
765824tests :: (NT.Transport, TransportInternals) -> [Test]
766825tests (transport, transportInternals) = [
767826 testGroup "Basic features" [
768− testCase "Ping" (testPing transport)
769− , testCase "Math" (testMath transport)
770− , testCase "Timeout" (testTimeout transport)
771− , testCase "Timeout0" (testTimeout0 transport)
772− , testCase "SendToTerminated" (testSendToTerminated transport)
773− , testCase "TypedChannnels" (testTypedChannels transport)
774− , testCase "MergeChannels" (testMergeChannels transport)
775− , testCase "Terminate" (testTerminate transport)
776− , testCase "Registry" (testRegistry transport)
777− , testCase "RemoteRegistry" (testRemoteRegistry transport)
778− , testCase "SpawnLocal" (testSpawnLocal transport)
779− , testCase "MatchAny" (testMatchAny transport)
780− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)
827+ testCase "Ping" (testPing transport)
828+ , testCase "Math" (testMath transport)
829+ , testCase "Timeout" (testTimeout transport)
830+ , testCase "Timeout0" (testTimeout0 transport)
831+ , testCase "SendToTerminated" (testSendToTerminated transport)
832+ , testCase "TypedChannnels" (testTypedChannels transport)
833+ , testCase "MergeChannels" (testMergeChannels transport)
834+ , testCase "Terminate" (testTerminate transport)
835+ , testCase "Registry" (testRegistry transport)
836+ , testCase "RemoteRegistry" (testRemoteRegistry transport)
837+ , testCase "SpawnLocal" (testSpawnLocal transport)
838+ , testCase "MatchAny" (testMatchAny transport)
839+ , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)
840+ , testCase "ReceiveChanFeatures" (testReceiveChanFeatures transport)
781841 ]
782842 , testGroup "Monitoring and Linking" [
783843 -- Monitoring processes