distributed-process 0.6.0 → 0.6.1

raw patch · 6 files changed

+109/−67 lines, 6 filesdep +exceptionsdep ~basedep ~network-transportPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependency ranges changed: base, network-transport

API changes (from Hackage documentation)

Files

• ChangeLog +4/−0
• distributed-process.cabal +8/−7
• src/Control/Distributed/Process.hs +13/−11
• src/Control/Distributed/Process/Internal/Primitives.hs +34/−42
• src/Control/Distributed/Process/Internal/Types.hs +43/−3
• src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs +7/−4

@@ -1,3 +1,7 @@+2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1++* Implement MonadCatch, MonadThrow, MonadMask for Process.+ 2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0  * Have nsendRemote skip the transport for local communication.

@@ -1,5 +1,5 @@ Name:          distributed-process-Version:       0.6.0+Version:       0.6.1 Cabal-Version: >=1.8 Build-Type:    Simple License:       BSD3@@ -54,7 +54,8 @@                      ghc-prim >= 0.2 && < 0.5,                      distributed-static >= 0.2 && < 0.4,                      rank1dynamic >= 0.1 && < 0.4,-                     syb >= 0.3 && < 0.7+                     syb >= 0.3 && < 0.7,+                     exceptions >= 0.5   Exposed-modules:   Control.Distributed.Process,                      Control.Distributed.Process.Closure,                      Control.Distributed.Process.Debug,@@ -107,7 +108,7 @@   Type:            exitcode-stdio-1.0   Build-Depends:   base >= 4.4 && < 5,                    distributed-process,-                   network-transport-tcp >= 0.3 && < 0.5,+                   network-transport-tcp >= 0.3 && < 0.6,                    bytestring >= 0.9 && < 0.11,                    binary >= 0.6.3 && < 0.8   Main-Is:         benchmarks/Throughput.hs@@ -117,7 +118,7 @@   Type:            exitcode-stdio-1.0   Build-Depends:   base >= 4.4 && < 5,                    distributed-process,-                   network-transport-tcp >= 0.3 && < 0.5,+                   network-transport-tcp >= 0.3 && < 0.6,                    bytestring >= 0.9 && < 0.11,                    binary >= 0.6.3 && < 0.8   Main-Is:         benchmarks/Latency.hs@@ -127,7 +128,7 @@   Type:            exitcode-stdio-1.0   Build-Depends:   base >= 4.4 && < 5,                    distributed-process,-                   network-transport-tcp >= 0.3 && < 0.5,+                   network-transport-tcp >= 0.3 && < 0.6,                    bytestring >= 0.9 && < 0.11,                    binary >= 0.6.3 && < 0.8   Main-Is:         benchmarks/Channels.hs@@ -137,7 +138,7 @@   Type:            exitcode-stdio-1.0   Build-Depends:   base >= 4.4 && < 5,                    distributed-process,-                   network-transport-tcp >= 0.3 && < 0.5,+                   network-transport-tcp >= 0.3 && < 0.6,                    bytestring >= 0.9 && < 0.11,                    binary >= 0.6.3 && < 0.8   Main-Is:         benchmarks/Spawns.hs@@ -147,7 +148,7 @@   Type:            exitcode-stdio-1.0   Build-Depends:   base >= 4.4 && < 5,                    distributed-process,-                   network-transport-tcp >= 0.3 && < 0.5,+                   network-transport-tcp >= 0.3 && < 0.6,                    bytestring >= 0.9 && < 0.11,                    binary >= 0.6.3 && < 0.8   Main-Is:         benchmarks/ProcessRing.hs

@@ -159,12 +159,8 @@   , reconnectPort   ) where -#if ! MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif- import Control.Monad.IO.Class (liftIO)-import Control.Applicative ((<$>))+import Control.Applicative import Control.Monad.Reader (ask) import Control.Concurrent.MVar   ( MVar@@ -316,8 +312,14 @@   , spawnSupervised   , call   )-import Control.Exception (SomeException, throw)+import qualified Control.Monad.Catch as Catch +#if MIN_VERSION_base(4,6,0)+import Prelude+#else+import Prelude hiding (catch)+#endif+ -- INTERNAL NOTES -- -- 1.  'send' never fails. If you want to know that the remote process received@@ -413,9 +415,9 @@ -- or duplicate messages sent to the isolated process after it exits. -- Silently dropping messages may not always be the best approach. callLocal :: Process a -> Process a-callLocal proc = mask $ \release -> do-    mv    <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a))-    child <- spawnLocal $ try (release proc) >>= liftIO . putMVar mv-    rs <- liftIO (takeMVar mv) `onException`+callLocal proc = Catch.mask $ \release -> do+    mv    <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))+    child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv+    rs <- liftIO (takeMVar mv) `Catch.onException`             (kill child "exception in parent process" >> liftIO (takeMVar mv))-    either throw return rs+    either Catch.throwM return rs

@@ -137,9 +137,14 @@ import Control.Monad (when) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO)-import Control.Applicative ((<$>))-import Control.Exception (Exception(..), throw, throwIO, SomeException)-import qualified Control.Exception as Ex (catch, mask, mask_, try)+import Control.Monad.Catch+  ( Exception+  , SomeException+  , throwM+  , fromException+  )+import qualified Control.Monad.Catch as Catch+import Control.Applicative import Control.Distributed.Process.Internal.StrictMVar   ( StrictMVar   , modifyMVar@@ -203,7 +208,6 @@   , isEncoded   , createMessage   , createUnencodedMessage-  , runLocalProcess   , ImplicitReconnect( NoImplicitReconnect)   , LocalProcessState   , LocalSendPortId@@ -227,6 +231,7 @@   , readTQueue   , mkWeakTQueue   )+import Prelude  import Unsafe.Coerce @@ -699,7 +704,7 @@  -- | Terminate immediately (throws a ProcessTerminationException) terminate :: Process a-terminate = liftIO $ throwIO ProcessTerminationException+terminate = throwM ProcessTerminationException  -- [Issue #110] -- | Die immediately - throws a 'ProcessExitException' with the given @reason@.@@ -709,7 +714,7 @@ -- could be decoded by a handler passed to 'catchExit', re-thrown or even -- passed to another process via the tracing mechanism.   pid <- getSelfPid-  liftIO $ throwIO (ProcessExitException pid (createMessage reason))+  throwM (ProcessExitException pid (createMessage reason))  -- | Forceful request to kill a process. Where 'exit' provides an exception -- that can be caught and handled, 'kill' throws an unexposed exception type@@ -742,12 +747,12 @@                        => Process b                        -> (ProcessId -> a -> Process b)                        -> Process b-catchExit act exitHandler = catch act handleExit+catchExit act exitHandler = Catch.catch act handleExit   where     handleExit ex@(ProcessExitException from msg) =         if messageFingerprint msg == fingerprint (undefined :: a)           then exitHandler from decoded-          else liftIO $ throwIO ex+          else throwM ex      where        decoded :: a        -- Make sure the value is fully decoded so that we don't hang to@@ -766,12 +771,12 @@ catchesExit :: Process b             -> [(ProcessId -> Message -> (Process (Maybe b)))]             -> Process b-catchesExit act handlers = catch act ((flip handleExit) handlers)+catchesExit act handlers = Catch.catch act ((flip handleExit) handlers)   where     handleExit :: ProcessExitException                -> [(ProcessId -> Message -> Process (Maybe b))]                -> Process b-    handleExit ex [] = liftIO $ throwIO ex+    handleExit ex [] = throwM ex     handleExit ex@(ProcessExitException from msg) (h:hs) = do       r <- h from msg       case r of@@ -936,56 +941,43 @@  -- | Lift 'Control.Exception.catch' catch :: Exception e => Process a -> (e -> Process a) -> Process a-catch p h = do-  lproc <- ask-  liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)+catch = Catch.catch+{-# DEPRECATED catch "Use Control.Monad.Catch.catch instead" #-}  -- | Lift 'Control.Exception.try' try :: Exception e => Process a -> Process (Either e a)-try p = do-  lproc <- ask-  liftIO $ Ex.try (runLocalProcess lproc p)+try = Catch.try+{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}  -- | Lift 'Control.Exception.mask' mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b-mask p = do-    lproc <- ask-    liftIO $ Ex.mask $ \restore ->-      runLocalProcess lproc (p (liftRestore restore))-  where-    liftRestore :: (forall a. IO a -> IO a)-                -> (forall a. Process a -> Process a)-    liftRestore restoreIO = \p2 -> do-      ourLocalProc <- ask-      liftIO $ restoreIO $ runLocalProcess ourLocalProc p2+mask = Catch.mask+{-# DEPRECATED mask "Use Control.Monad.Catch.mask_ instead" #-}  -- | Lift 'Control.Exception.mask_' mask_ :: Process a -> Process a-mask_ p = do-   lproc <- ask-   liftIO $ Ex.mask_ $ runLocalProcess lproc p+mask_ = Catch.mask_+{-# DEPRECATED mask_ "Use Control.Monad.Catch.mask_ instead" #-}  -- | Lift 'Control.Exception.onException' onException :: Process a -> Process b -> Process a-onException p what = p `catch` \e -> do _ <- what-                                        liftIO $ throwIO (e :: SomeException)+onException = Catch.onException+{-# DEPRECATED onException "Use Control.Monad.Catch.onException instead" #-}  -- | Lift 'Control.Exception.bracket' bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c-bracket before after thing =-  mask $ \restore -> do-    a <- before-    r <- restore (thing a) `onException` after a-    _ <- after a-    return r+bracket = Catch.bracket+{-# DEPRECATED bracket "Use Control.Monad.Catch.bracket instead" #-}  -- | Lift 'Control.Exception.bracket_' bracket_ :: Process a -> Process b -> Process c -> Process c-bracket_ before after thing = bracket before (const after) (const thing)+bracket_ = Catch.bracket_+{-# DEPRECATED bracket_ "Use Control.Monad.Catch.bracket_ instead" #-}  -- | Lift 'Control.Exception.finally' finally :: Process a -> Process b -> Process a-finally a sequel = bracket_ (return ()) sequel a+finally = Catch.finally+{-# DEPRECATED finally "Use Control.Monad.Catch.finally instead" #-}  -- | You need this when using 'catches' data Handler a = forall e . Exception e => Handler (e -> Process a)@@ -995,10 +987,10 @@  -- | Lift 'Control.Exception.catches' catches :: Process a -> [Handler a] -> Process a-catches proc handlers = proc `catch` catchesHandler handlers+catches proc handlers = proc `Catch.catch` catchesHandler handlers  catchesHandler :: [Handler a] -> SomeException -> Process a-catchesHandler handlers e = foldr tryHandler (throw e) handlers+catchesHandler handlers e = foldr tryHandler (throwM e) handlers     where tryHandler (Handler handler) res               = case fromException e of                 Just e' -> handler e'@@ -1138,7 +1130,7 @@ handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process () handleRegistrationReply label ok owner =   when (not ok) $-     liftIO $ throwIO $ ProcessRegistrationException label owner+     throwM $ ProcessRegistrationException label owner  -- | Remove a process from a remote registry (asynchronous). --

@@ -4,6 +4,9 @@ {-# LANGUAGE GADTs  #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}  -- | Types used throughout the Cloud Haskell framework --@@ -112,11 +115,12 @@ import Control.Concurrent.Chan (Chan) import Control.Concurrent.STM (STM) import Control.Concurrent.STM.TChan (TChan)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..)) import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)-import Control.Applicative (Applicative, Alternative, (<$>), (<*>))+import Control.Applicative import Control.Monad.Fix (MonadFix) import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO(..)) import Control.Distributed.Process.Serializable   ( Fingerprint   , Serializable@@ -139,6 +143,7 @@  import Data.Hashable import GHC.Generics+import Prelude  -------------------------------------------------------------------------------- -- Node and process identifiers                                               --@@ -345,7 +350,42 @@ newtype Process a = Process {     unProcess :: ReaderT LocalProcess IO a   }-  deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative, MonadFix)+  deriving ( Applicative+           , Functor+           , Monad+           , MonadFix+           , MonadIO+           , MonadReader LocalProcess+           , Typeable+           )++instance MonadThrow Process where+  throwM = liftIO . throwIO+instance MonadCatch Process where+  catch p h = do+    lproc <- ask+    liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)+instance MonadMask Process where+  mask p = do+      lproc <- ask+      liftIO $ mask $ \restore ->+        runLocalProcess lproc (p (liftRestore restore))+    where+      liftRestore :: (forall a. IO a -> IO a)+                  -> (forall a. Process a -> Process a)+      liftRestore restoreIO = \p2 -> do+        ourLocalProc <- ask+        liftIO $ restoreIO $ runLocalProcess ourLocalProc p2+  uninterruptibleMask p = do+      lproc <- ask+      liftIO $ uninterruptibleMask $ \restore ->+        runLocalProcess lproc (p (liftRestore restore))+    where+      liftRestore :: (forall a. IO a -> IO a)+                  -> (forall a. Process a -> Process a)+      liftRestore restoreIO = \p2 -> do+        ourLocalProc <- ask+        liftIO $ restoreIO $ runLocalProcess ourLocalProc p2  -------------------------------------------------------------------------------- -- Typed channels                                                             --

@@ -11,7 +11,7 @@   , eventLogTracer   ) where -import Control.Applicative ((<$>))+import Control.Applicative import Control.Concurrent.Chan (writeChan) import Control.Concurrent.MVar   ( MVar@@ -21,9 +21,7 @@   ( CQueue   ) import Control.Distributed.Process.Internal.Primitives-  ( catch-  , finally-  , die+  ( die   , receiveWait   , forward   , sendChan@@ -63,6 +61,10 @@  import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask)+import Control.Monad.Catch+  ( catch+  , finally+  )  import Data.Set (Set) import qualified Data.Set as Set@@ -73,6 +75,7 @@ import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) import Debug.Trace (traceEventIO)+import Prelude  #if ! MIN_VERSION_base(4,6,0) import Prelude hiding (catch)