16d87d7 · distributed-process

git.iko.soy/distributed-process

Merge pull request #274 from haskell-distributed/monad-catch

Implement MonadCatch, MonadThrow, MonadMask for Process.

commit16d87d7a5a2936628bd8699155ab785b71e8d058 authorAlexander Vershilov <alexander.vershilov@gmail.com> dateWed 2 Mar 2016, 12:52 (11 years ago) parentd0b7885 f962021

5 files changed+99−61

compare with master

unifiedsplit

distributed-process.cabal+2−1 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

distributed-process.cabal+2−1

@@ -54,7 +54,8 @@ Library

5454 ghc-prim >= 0.2 && < 0.5,

5555 distributed-static >= 0.2 && < 0.4,

5656 rank1dynamic >= 0.1 && < 0.4,

57− syb >= 0.3 && < 0.7

57+ syb >= 0.3 && < 0.7,

58+ exceptions >= 0.5

5859 Exposed-modules: Control.Distributed.Process,

5960 Control.Distributed.Process.Closure,

6061 Control.Distributed.Process.Debug,

src/Control/Distributed/Process.hs+13−11

@@ -159,12 +159,8 @@ module Control.Distributed.Process

159159 , reconnectPort

160160 ) where

161161

162−#if ! MIN_VERSION_base(4,6,0)

163−import Prelude hiding (catch)

164−#endif

165−

166162import Control.Monad.IO.Class (liftIO)

167−import Control.Applicative ((<$>))

163+import Control.Applicative

168164import Control.Monad.Reader (ask)

169165import Control.Concurrent.MVar

170166 ( MVar

@@ -316,7 +312,13 @@ import Control.Distributed.Process.Internal.Spawn

316312 , spawnSupervised

317313 , call

318314 )

319−import Control.Exception (SomeException, throw)

315+import qualified Control.Monad.Catch as Catch

316+

317+#if MIN_VERSION_base(4,6,0)

318+import Prelude

319+#else

320+import Prelude hiding (catch)

321+#endif

320322

321323-- INTERNAL NOTES

322324--

@@ -413,9 +415,9 @@ spawnChannelLocal proc = do

413415-- or duplicate messages sent to the isolated process after it exits.

414416-- Silently dropping messages may not always be the best approach.

415417callLocal :: Process a -> Process a

416−callLocal proc = mask $ \release -> do

417− mv <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a))

418− child <- spawnLocal $ try (release proc) >>= liftIO . putMVar mv

419− rs <- liftIO (takeMVar mv) `onException`

418+callLocal proc = Catch.mask $ \release -> do

419+ mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

420+ child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

421+ rs <- liftIO (takeMVar mv) `Catch.onException`

420422 (kill child "exception in parent process" >> liftIO (takeMVar mv))

421− either throw return rs

423+ either Catch.throwM return rs

src/Control/Distributed/Process/Internal/Primitives.hs+34−42

@@ -137,9 +137,14 @@ import System.Timeout (timeout)

137137import Control.Monad (when)

138138import Control.Monad.Reader (ask)

139139import Control.Monad.IO.Class (liftIO)

140−import Control.Applicative ((<$>))

141−import Control.Exception (Exception(..), throw, throwIO, SomeException)

142−import qualified Control.Exception as Ex (catch, mask, mask_, try)

140+import Control.Monad.Catch

141+ ( Exception

142+ , SomeException

143+ , throwM

144+ , fromException

145+ )

146+import qualified Control.Monad.Catch as Catch

147+import Control.Applicative

143148import Control.Distributed.Process.Internal.StrictMVar

144149 ( StrictMVar

145150 , modifyMVar

@@ -203,7 +208,6 @@ import Control.Distributed.Process.Internal.Types

203208 , isEncoded

204209 , createMessage

205210 , createUnencodedMessage

206− , runLocalProcess

207211 , ImplicitReconnect( NoImplicitReconnect)

208212 , LocalProcessState

209213 , LocalSendPortId

@@ -227,6 +231,7 @@ import Control.Distributed.Process.Internal.WeakTQueue

227231 , readTQueue

228232 , mkWeakTQueue

229233 )

234+import Prelude

230235

231236import Unsafe.Coerce

232237

@@ -699,7 +704,7 @@ instance Exception ProcessTerminationException

699704

700705-- | Terminate immediately (throws a ProcessTerminationException)

701706terminate :: Process a

702−terminate = liftIO $ throwIO ProcessTerminationException

707+terminate = throwM ProcessTerminationException

703708

704709-- [Issue #110]

705710-- | Die immediately - throws a 'ProcessExitException' with the given @reason@.

@@ -709,7 +714,7 @@ die reason = do

709714-- could be decoded by a handler passed to 'catchExit', re-thrown or even

710715-- passed to another process via the tracing mechanism.

711716 pid <- getSelfPid

712− liftIO $ throwIO (ProcessExitException pid (createMessage reason))

717+ throwM (ProcessExitException pid (createMessage reason))

713718

714719-- | Forceful request to kill a process. Where 'exit' provides an exception

715720-- that can be caught and handled, 'kill' throws an unexposed exception type

@@ -742,12 +747,12 @@ catchExit :: forall a b . (Show a, Serializable a)

742747 => Process b

743748 -> (ProcessId -> a -> Process b)

744749 -> Process b

745−catchExit act exitHandler = catch act handleExit

750+catchExit act exitHandler = Catch.catch act handleExit

746751 where

747752 handleExit ex@(ProcessExitException from msg) =

748753 if messageFingerprint msg == fingerprint (undefined :: a)

749754 then exitHandler from decoded

750− else liftIO $ throwIO ex

755+ else throwM ex

751756 where

752757 decoded :: a

753758 -- Make sure the value is fully decoded so that we don't hang to

@@ -766,12 +771,12 @@ catchExit act exitHandler = catch act handleExit

766771catchesExit :: Process b

767772 -> [(ProcessId -> Message -> (Process (Maybe b)))]

768773 -> Process b

769−catchesExit act handlers = catch act ((flip handleExit) handlers)

774+catchesExit act handlers = Catch.catch act ((flip handleExit) handlers)

770775 where

771776 handleExit :: ProcessExitException

772777 -> [(ProcessId -> Message -> Process (Maybe b))]

773778 -> Process b

774− handleExit ex [] = liftIO $ throwIO ex

779+ handleExit ex [] = throwM ex

775780 handleExit ex@(ProcessExitException from msg) (h:hs) = do

776781 r <- h from msg

777782 case r of

@@ -936,56 +941,43 @@ unmonitor ref = do

936941

937942-- | Lift 'Control.Exception.catch'

938943catch :: Exception e => Process a -> (e -> Process a) -> Process a

939−catch p h = do

940− lproc <- ask

941− liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

944+catch = Catch.catch

945+{-# DEPRECATED catch "Use Control.Monad.Catch.catch instead" #-}

942946

943947-- | Lift 'Control.Exception.try'

944948try :: Exception e => Process a -> Process (Either e a)

945−try p = do

946− lproc <- ask

947− liftIO $ Ex.try (runLocalProcess lproc p)

949+try = Catch.try

950+{-# DEPRECATED try "Use Control.Monad.Catch.mask_ instead" #-}

948951

949952-- | Lift 'Control.Exception.mask'

950953mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

951−mask p = do

952− lproc <- ask

953− liftIO $ Ex.mask $ \restore ->

954− runLocalProcess lproc (p (liftRestore restore))

955− where

956− liftRestore :: (forall a. IO a -> IO a)

957− -> (forall a. Process a -> Process a)

958− liftRestore restoreIO = \p2 -> do

959− ourLocalProc <- ask

960− liftIO $ restoreIO $ runLocalProcess ourLocalProc p2

954+mask = Catch.mask

955+{-# DEPRECATED mask "Use Control.Monad.Catch.mask_ instead" #-}

961956

962957-- | Lift 'Control.Exception.mask_'

963958mask_ :: Process a -> Process a

964−mask_ p = do

965− lproc <- ask

966− liftIO $ Ex.mask_ $ runLocalProcess lproc p

959+mask_ = Catch.mask_

960+{-# DEPRECATED mask_ "Use Control.Monad.Catch.mask_ instead" #-}

967961

968962-- | Lift 'Control.Exception.onException'

969963onException :: Process a -> Process b -> Process a

970−onException p what = p `catch` \e -> do _ <- what

971− liftIO $ throwIO (e :: SomeException)

964+onException = Catch.onException

965+{-# DEPRECATED onException "Use Control.Monad.Catch.onException instead" #-}

972966

973967-- | Lift 'Control.Exception.bracket'

974968bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c

975−bracket before after thing =

976− mask $ \restore -> do

977− a <- before

978− r <- restore (thing a) `onException` after a

979− _ <- after a

980− return r

969+bracket = Catch.bracket

970+{-# DEPRECATED bracket "Use Control.Monad.Catch.bracket instead" #-}

981971

982972-- | Lift 'Control.Exception.bracket_'

983973bracket_ :: Process a -> Process b -> Process c -> Process c

984−bracket_ before after thing = bracket before (const after) (const thing)

974+bracket_ = Catch.bracket_

975+{-# DEPRECATED bracket_ "Use Control.Monad.Catch.bracket_ instead" #-}

985976

986977-- | Lift 'Control.Exception.finally'

987978finally :: Process a -> Process b -> Process a

988−finally a sequel = bracket_ (return ()) sequel a

979+finally = Catch.finally

980+{-# DEPRECATED finally "Use Control.Monad.Catch.finally instead" #-}

989981

990982-- | You need this when using 'catches'

991983data Handler a = forall e . Exception e => Handler (e -> Process a)

@@ -995,10 +987,10 @@ instance Functor Handler where

995987

996988-- | Lift 'Control.Exception.catches'

997989catches :: Process a -> [Handler a] -> Process a

998−catches proc handlers = proc `catch` catchesHandler handlers

990+catches proc handlers = proc `Catch.catch` catchesHandler handlers

999991

1000992catchesHandler :: [Handler a] -> SomeException -> Process a

1001−catchesHandler handlers e = foldr tryHandler (throw e) handlers

993+catchesHandler handlers e = foldr tryHandler (throwM e) handlers

1002994 where tryHandler (Handler handler) res

1003995 = case fromException e of

1004996 Just e' -> handler e'

@@ -1138,7 +1130,7 @@ unregister label = do

11381130handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process ()

11391131handleRegistrationReply label ok owner =

11401132 when (not ok) $

1141− liftIO $ throwIO $ ProcessRegistrationException label owner

1133+ throwM $ ProcessRegistrationException label owner

11421134

11431135-- | Remove a process from a remote registry (asynchronous).

11441136--

src/Control/Distributed/Process/Internal/Types.hs+43−3

@@ -4,6 +4,9 @@

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE DeriveGeneric #-}

66{-# LANGUAGE CPP #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE Rank2Types #-}

710

811-- | Types used throughout the Cloud Haskell framework

912--

@@ -112,11 +115,12 @@ import Control.Concurrent (ThreadId)

112115import Control.Concurrent.Chan (Chan)

113116import Control.Concurrent.STM (STM)

114117import Control.Concurrent.STM.TChan (TChan)

118+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))

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

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

120+import Control.Applicative

117121import Control.Monad.Fix (MonadFix)

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

119−import Control.Monad.IO.Class (MonadIO)

123+import Control.Monad.IO.Class (MonadIO(..))

120124import Control.Distributed.Process.Serializable

121125 ( Fingerprint

122126 , Serializable

@@ -139,6 +143,7 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a

139143

140144import Data.Hashable

141145import GHC.Generics

146+import Prelude

142147

143148--------------------------------------------------------------------------------

144149-- Node and process identifiers --

@@ -345,7 +350,42 @@ data LocalProcessState = LocalProcessState

345350newtype Process a = Process {

346351 unProcess :: ReaderT LocalProcess IO a

347352 }

348− deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative, MonadFix)

353+ deriving ( Applicative

354+ , Functor

355+ , Monad

356+ , MonadFix

357+ , MonadIO

358+ , MonadReader LocalProcess

359+ , Typeable

360+ )

361+

362+instance MonadThrow Process where

363+ throwM = liftIO . throwIO

364+instance MonadCatch Process where

365+ catch p h = do

366+ lproc <- ask

367+ liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

368+instance MonadMask Process where

369+ mask p = do

370+ lproc <- ask

371+ liftIO $ mask $ \restore ->

372+ runLocalProcess lproc (p (liftRestore restore))

373+ where

374+ liftRestore :: (forall a. IO a -> IO a)

375+ -> (forall a. Process a -> Process a)

376+ liftRestore restoreIO = \p2 -> do

377+ ourLocalProc <- ask

378+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2

379+ uninterruptibleMask p = do

380+ lproc <- ask

381+ liftIO $ uninterruptibleMask $ \restore ->

382+ runLocalProcess lproc (p (liftRestore restore))

383+ where

384+ liftRestore :: (forall a. IO a -> IO a)

385+ -> (forall a. Process a -> Process a)

386+ liftRestore restoreIO = \p2 -> do

387+ ourLocalProc <- ask

388+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2

349389

350390--------------------------------------------------------------------------------

351391-- Typed channels --

src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs+7−4

@@ -11,7 +11,7 @@ module Control.Distributed.Process.Management.Internal.Trace.Tracer

1111 , eventLogTracer

1212 ) where

1313

14−import Control.Applicative ((<$>))

14+import Control.Applicative

1515import Control.Concurrent.Chan (writeChan)

1616import Control.Concurrent.MVar

1717 ( MVar

@@ -21,9 +21,7 @@ import Control.Distributed.Process.Internal.CQueue

2121 ( CQueue

2222 )

2323import Control.Distributed.Process.Internal.Primitives

24− ( catch

25− , finally

26− , die

24+ ( die

2725 , receiveWait

2826 , forward

2927 , sendChan

@@ -63,6 +61,10 @@ import Control.Distributed.Process.Internal.Types

6361

6462import Control.Monad.IO.Class (liftIO)

6563import Control.Monad.Reader (ask)

64+import Control.Monad.Catch

65+ ( catch

66+ , finally

67+ )

6668

6769import Data.Set (Set)

6870import qualified Data.Set as Set

@@ -73,6 +75,7 @@ import Data.Maybe (fromMaybe)

7375import Data.Time.Clock (getCurrentTime)

7476import Data.Time.Format (formatTime)

7577import Debug.Trace (traceEventIO)

78+import Prelude

7679

7780#if ! MIN_VERSION_base(4,6,0)

7881import Prelude hiding (catch)