distributed-process 0.2.1.2 → 0.2.1.3

raw patch · 6 files changed

+76/−14 lines, 6 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• distributed-process.cabal +1/−1
• src/Control/Distributed/Process.hs +39/−2
• src/Control/Distributed/Process/Closure.hs +1/−1
• src/Control/Distributed/Process/Internal/Closure/CP.hs +2/−8
• src/Control/Distributed/Process/Internal/TypeRep.hs +14/−2
• tests/TestCH.hs +19/−0

@@ -1,5 +1,5 @@ Name:          distributed-process -Version:       0.2.1.2+Version:       0.2.1.3 Cabal-Version: >=1.8 Build-Type:    Simple License:       BSD3 

@@ -89,6 +89,9 @@   , spawnMonitor   , spawnChannel   , DidSpawn(..)+    -- * Local versions of spawn+  , spawnLocal+  , spawnChannelLocal   ) where  @@ -121,6 +124,7 @@   , SerializableDict(..)   , SendPortId(..)   , WhereIsReply(..)+  , procMsg   ) import Control.Distributed.Process.Internal.Closure.CP   ( cpSeq@@ -190,6 +194,8 @@   , spawnAsync   ) import Control.Distributed.Process.Serializable (Serializable)+import Control.Distributed.Process.Internal.MessageT (getLocalNode)+import Control.Distributed.Process.Node (forkProcess)  -- INTERNAL NOTES -- @@ -256,6 +262,11 @@ --------------------------------------------------------------------------------  -- | Spawn a process+--+-- For more information about 'Closure', see+-- "Control.Distributed.Process.Closure". +--+-- See also 'call'.  spawn :: NodeId -> Closure (Process ()) -> Process ProcessId spawn nid proc = do   us   <- getSelfPid@@ -299,8 +310,13 @@  -- | Run a process remotely and wait for it to reply -- --- We monitor the remote process; if it dies before it can send a reply, we die--- too+-- We monitor the remote process: if it dies before it can send a reply, we die+-- too.+--+-- For more information about 'Static', 'SerializableDict', and 'Closure', see+-- "Control.Distributed.Process.Closure". +--+-- See also 'spawn'.  call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a call dict nid proc = do    us <- getSelfPid@@ -345,3 +361,24 @@              (cpSend (sdictSendPort dict) pid `cpSplit` proc)            `cpBind`              cpCancelL++--------------------------------------------------------------------------------+-- Local versions of spawn                                                    --+--------------------------------------------------------------------------------++-- | Spawn a process on the local node+spawnLocal :: Process () -> Process ProcessId+spawnLocal proc = do+  node <- procMsg $ getLocalNode+  liftIO $ forkProcess node proc++-- | Create a new typed channel, spawn a process on the local node, passing it+-- the receive port, and return the send port+spawnChannelLocal :: Serializable a+                  => (ReceivePort a -> Process ()) +                  -> Process (SendPort a)+spawnChannelLocal proc = do +  node <- procMsg $ getLocalNode+  (sport, rport) <- newChan+  _ <- liftIO $ forkProcess node (proc rport)+  return sport

@@ -122,7 +122,7 @@ -- then a serialization dictionary is automatically created for you, which you -- can access with ----- > $(functionDict 'f) :: Static (SerializableDict T1)+-- > $(functionSDict 'f) :: Static (SerializableDict T1) -- -- This is the dictionary that 'mkClosure' uses. --

@@ -29,7 +29,6 @@ import Data.Binary (encode) import Data.ByteString.Lazy (ByteString) import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)-import Data.Typeable.Internal (TypeRep(..)) import Control.Applicative ((<$>)) import Control.Monad ((>=>)) import Control.Distributed.Process.Serializable (Serializable)@@ -77,6 +76,7 @@   , dynTypeRep   , dynKleisli   )+import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)  -------------------------------------------------------------------------------- -- Setup: A number of functions that we will pass to 'remotable'              --@@ -123,18 +123,12 @@     Nothing  -> fail "Derived.unClosure: resolveClosure failed"     Just dyn -> return dyn --- | Work around a bug in Typeable--- (http://hackage.haskell.org/trac/ghc/ticket/5692)-compareWithoutFingerprint :: TypeRep -> TypeRep -> Bool-compareWithoutFingerprint (TypeRep _ con ts) (TypeRep _ con' ts') -  = con == con' && all (uncurry compareWithoutFingerprint) (zip ts ts')- -- | Remove a 'Dynamic' constructor, provided that the recorded type matches the -- type of the first static argument (the value of that argument is not used) unDynamic :: Static a -> Process Dynamic -> Process a unDynamic (Static label) pdyn = do   Dynamic typ val <- pdyn-  if compareWithoutFingerprint typ (typeOfStaticLabel label) -- typ == typeOfStaticLabel label +  if typ `compareTypeRep` typeOfStaticLabel label      then return (unsafeCoerce# val)     else fail $ "unDynamic: cannot match "               ++ show typ

@@ -1,6 +1,6 @@--- | 'Binary' instances for 'TypeRep'+-- | 'Binary' instances for 'TypeRep', and 'TypeRep' equality (bug workaround) {-# OPTIONS_GHC -fno-warn-orphans #-}-module Control.Distributed.Process.Internal.TypeRep () where+module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where  import Control.Applicative ((<$>), (<*>)) import Data.Binary (Binary(get, put))@@ -19,3 +19,15 @@   put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name   get = TyCon <$> get <*> get <*> get <*> get +-- | Compare two type representations+--+-- For base >= 4.6 this compares fingerprints, but older versions of base+-- have a bug in the fingerprint construction +-- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)+compareTypeRep :: TypeRep -> TypeRep -> Bool+#if ! MIN_VERSION_base(4,6,0)+compareTypeRep (TypeRep _ con ts) (TypeRep _ con' ts') +  = con == con' && all (uncurry compareTypeRep) (zip ts ts')+#else+compareTypeRep = (==)+#endif

@@ -560,6 +560,24 @@     True <- return $ pingServer == pid'     return () +testSpawnLocal :: NT.Transport -> IO ()+testSpawnLocal transport = do+  node <- newLocalNode transport initRemoteTable++  runProcess node $ do+    us <- getSelfPid++    pid <- spawnLocal $ do+      sport <- expect+      sendChan sport (1234 :: Int)++    sport <- spawnChannelLocal $ \rport -> do+      (1234 :: Int) <- receiveChan rport+      send us ()++    send pid sport+    expect+ main :: IO () main = do   Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters@@ -574,6 +592,7 @@     , ("Terminate",        testTerminate        transport)     , ("Registry",         testRegistry         transport)     , ("RemoteRegistry",   testRemoteRegistry   transport)+    , ("SpawnLocal",       testSpawnLocal       transport)       -- Monitoring processes       --       -- The "missing" combinations in the list below don't make much sense, as