14a1d99 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Functor/Appl/Alt/Monad ReceivePort instances

14a1d99Edsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+6−3

compare with master

unifiedsplit

@@ -82,9 +82,9 @@ import Control.Category ((>>>))

82import Control.Exception (Exception)

83import Control.Concurrent (ThreadId)

84import Control.Concurrent.Chan (Chan)

85−import Control.Concurrent.STM (STM, TVar)

85+import Control.Concurrent.STM (STM)

86import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

87−import Control.Applicative (Applicative, (<$>), (<*>))

87+import Control.Applicative (Applicative, Alternative, (<$>), (<*>))

88import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

89import Control.Monad.IO.Class (MonadIO)

90import Control.Distributed.Process.Serializable

@@ -262,8 +262,11 @@ newtype SendPort a = SendPort {

262 deriving (Typeable, Binary, Show, Eq, Ord)

263

264-- | 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.

265newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }

268newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }

266− deriving Typeable

269+ deriving (Typeable, Functor, Applicative, Alternative, Monad)

267

270

268{-

271{-

269data ReceivePort a =

272data ReceivePort a =

distributed-process/tests/TestCH.hs+74−14

@@ -19,7 +19,7 @@ import Control.Concurrent.MVar

19import Control.Monad (replicateM_, replicateM, forever)

20import Control.Exception (SomeException, throwIO)

21import qualified Control.Exception as Ex (catch)

22−import Control.Applicative ((<$>), (<*>))

22+import Control.Applicative ((<$>), (<*>), pure, (<|>))

23import qualified Network.Transport as NT (Transport, closeEndPoint)

24import Network.Socket (sClose)

25import Network.Transport.TCP

@@ -762,22 +762,82 @@ testReceiveChanTimeout transport = do

762

763 takeMVar done

764

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+

765tests :: (NT.Transport, TransportInternals) -> [Test]

824tests :: (NT.Transport, TransportInternals) -> [Test]

766tests (transport, transportInternals) = [

825tests (transport, transportInternals) = [

767 testGroup "Basic features" [

826 testGroup "Basic features" [

768− testCase "Ping" (testPing transport)

827+ testCase "Ping" (testPing transport)

769− , testCase "Math" (testMath transport)

828+ , testCase "Math" (testMath transport)

770− , testCase "Timeout" (testTimeout transport)

829+ , testCase "Timeout" (testTimeout transport)

771− , testCase "Timeout0" (testTimeout0 transport)

830+ , testCase "Timeout0" (testTimeout0 transport)

772− , testCase "SendToTerminated" (testSendToTerminated transport)

831+ , testCase "SendToTerminated" (testSendToTerminated transport)

773− , testCase "TypedChannnels" (testTypedChannels transport)

832+ , testCase "TypedChannnels" (testTypedChannels transport)

774− , testCase "MergeChannels" (testMergeChannels transport)

833+ , testCase "MergeChannels" (testMergeChannels transport)

775− , testCase "Terminate" (testTerminate transport)

834+ , testCase "Terminate" (testTerminate transport)

776− , testCase "Registry" (testRegistry transport)

835+ , testCase "Registry" (testRegistry transport)

777− , testCase "RemoteRegistry" (testRemoteRegistry transport)

836+ , testCase "RemoteRegistry" (testRemoteRegistry transport)

778− , testCase "SpawnLocal" (testSpawnLocal transport)

837+ , testCase "SpawnLocal" (testSpawnLocal transport)

779− , testCase "MatchAny" (testMatchAny transport)

838+ , testCase "MatchAny" (testMatchAny transport)

780− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)

839+ , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)

840+ , testCase "ReceiveChanFeatures" (testReceiveChanFeatures transport)

781 ]

841 ]

782 , testGroup "Monitoring and Linking" [

842 , testGroup "Monitoring and Linking" [

783 -- Monitoring processes

843 -- Monitoring processes