f962021 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Implement MonadCatch, MonadThrow, MonadMask for Process.

f962021Alexander Vershilov11 years ago

distributed-process.cabal+2−1

compare with master

unifiedsplit

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

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

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

56 rank1dynamic >= 0.1 && < 0.4,

57− syb >= 0.3 && < 0.7

57+ syb >= 0.3 && < 0.7,

58+ exceptions >= 0.5

58 Exposed-modules: Control.Distributed.Process,

59 Exposed-modules: Control.Distributed.Process,

59 Control.Distributed.Process.Closure,

60 Control.Distributed.Process.Closure,

60 Control.Distributed.Process.Debug,

61 Control.Distributed.Process.Debug,

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

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

159 , reconnectPort

160 ) where

161

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

163−import Prelude hiding (catch)

164−#endif

165−

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

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

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

163+import Control.Applicative

168import Control.Monad.Reader (ask)

164import Control.Monad.Reader (ask)

169import Control.Concurrent.MVar

165import Control.Concurrent.MVar

170 ( MVar

166 ( MVar

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

316 , spawnSupervised

312 , spawnSupervised

317 , call

313 , call

318 )

314 )

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

320

322

321-- INTERNAL NOTES

323-- INTERNAL NOTES

322--

324--

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

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

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

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

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

415callLocal :: Process a -> Process a

417callLocal :: Process a -> Process a

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

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

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

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

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

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

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

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

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

422 (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)

137import Control.Monad (when)

138import Control.Monad.Reader (ask)

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

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

140+import Control.Monad.Catch

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

141+ ( Exception

142+ , SomeException

143+ , throwM

144+ , fromException

145+ )

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

146+import qualified Control.Monad.Catch as Catch

147+import Control.Applicative

143import Control.Distributed.Process.Internal.StrictMVar

148import Control.Distributed.Process.Internal.StrictMVar

144 ( StrictMVar

149 ( StrictMVar

145 , modifyMVar

150 , modifyMVar

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

203 , isEncoded

208 , isEncoded

204 , createMessage

209 , createMessage

205 , createUnencodedMessage

210 , createUnencodedMessage

206− , runLocalProcess

207 , ImplicitReconnect( NoImplicitReconnect)

211 , ImplicitReconnect( NoImplicitReconnect)

208 , LocalProcessState

212 , LocalProcessState

209 , LocalSendPortId

213 , LocalSendPortId

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

227 , readTQueue

231 , readTQueue

228 , mkWeakTQueue

232 , mkWeakTQueue

229 )

233 )

234+import Prelude

230

235

231import Unsafe.Coerce

236import Unsafe.Coerce

232

237

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

699

704

700-- | Terminate immediately (throws a ProcessTerminationException)

705-- | Terminate immediately (throws a ProcessTerminationException)

701terminate :: Process a

706terminate :: Process a

702−terminate = liftIO $ throwIO ProcessTerminationException

707+terminate = throwM ProcessTerminationException

703

708

704-- [Issue #110]

709-- [Issue #110]

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

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

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

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

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

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

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

711 pid <- getSelfPid

716 pid <- getSelfPid

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

717+ throwM (ProcessExitException pid (createMessage reason))

713

718

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

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

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

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

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

742 => Process b

747 => Process b

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

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

744 -> Process b

749 -> Process b

745−catchExit act exitHandler = catch act handleExit

750+catchExit act exitHandler = Catch.catch act handleExit

746 where

751 where

747 handleExit ex@(ProcessExitException from msg) =

752 handleExit ex@(ProcessExitException from msg) =

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

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

749 then exitHandler from decoded

754 then exitHandler from decoded

750− else liftIO $ throwIO ex

755+ else throwM ex

751 where

756 where

752 decoded :: a

757 decoded :: a

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

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

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

766catchesExit :: Process b

771catchesExit :: Process b

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

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

768 -> Process b

773 -> Process b

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

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

770 where

775 where

771 handleExit :: ProcessExitException

776 handleExit :: ProcessExitException

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

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

773 -> Process b

778 -> Process b

774− handleExit ex [] = liftIO $ throwIO ex

779+ handleExit ex [] = throwM ex

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

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

776 r <- h from msg

781 r <- h from msg

777 case r of

782 case r of

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

936

941

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

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

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

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

939−catch p h = do

944+catch = Catch.catch

940− lproc <- ask

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

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

942

946

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

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

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

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

945−try p = do

949+try = Catch.try

946− lproc <- ask

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

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

948

951

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

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

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

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

951−mask p = do

954+mask = Catch.mask

952− lproc <- ask

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

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

961

956

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

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

963mask_ :: Process a -> Process a

958mask_ :: Process a -> Process a

964−mask_ p = do

959+mask_ = Catch.mask_

965− lproc <- ask

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

966− liftIO $ Ex.mask_ $ runLocalProcess lproc p

967

961

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

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

969onException :: Process a -> Process b -> Process a

963onException :: Process a -> Process b -> Process a

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

964+onException = Catch.onException

971− liftIO $ throwIO (e :: SomeException)

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

972

966

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

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

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

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

975−bracket before after thing =

969+bracket = Catch.bracket

976− mask $ \restore -> do

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

977− a <- before

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

979− _ <- after a

980− return r

981

971

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

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

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

973bracket_ :: 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" #-}

985

976

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

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

987finally :: Process a -> Process b -> Process a

978finally :: 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" #-}

989

981

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

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

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

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

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

995

987

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

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

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

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

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

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

999

991

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

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

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

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

1002 where tryHandler (Handler handler) res

994 where tryHandler (Handler handler) res

1003 = case fromException e of

995 = case fromException e of

1004 Just e' -> handler e'

996 Just e' -> handler e'

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

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

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

1139handleRegistrationReply label ok owner =

1131handleRegistrationReply label ok owner =

1140 when (not ok) $

1132 when (not ok) $

1141− liftIO $ throwIO $ ProcessRegistrationException label owner

1133+ throwM $ ProcessRegistrationException label owner

1142

1134

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

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

1144--

1136--

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

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

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE DeriveGeneric #-}

6{-# LANGUAGE CPP #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE Rank2Types #-}

8-- | Types used throughout the Cloud Haskell framework

11-- | Types used throughout the Cloud Haskell framework

9--

12--

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

112import Control.Concurrent.Chan (Chan)

115import Control.Concurrent.Chan (Chan)

113import Control.Concurrent.STM (STM)

116import Control.Concurrent.STM (STM)

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

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

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

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

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

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

120+import Control.Applicative

117import Control.Monad.Fix (MonadFix)

121import Control.Monad.Fix (MonadFix)

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

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

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

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

120import Control.Distributed.Process.Serializable

124import Control.Distributed.Process.Serializable

121 ( Fingerprint

125 ( Fingerprint

122 , Serializable

126 , Serializable

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

139

143

140import Data.Hashable

144import Data.Hashable

141import GHC.Generics

145import GHC.Generics

146+import Prelude

142

147

143--------------------------------------------------------------------------------

148--------------------------------------------------------------------------------

144-- Node and process identifiers --

149-- Node and process identifiers --

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

345newtype Process a = Process {

350newtype Process a = Process {

346 unProcess :: ReaderT LocalProcess IO a

351 unProcess :: ReaderT LocalProcess IO a

347 }

352 }

353+ deriving ( Applicative

354+ , Functor

355+ , Monad

356+ , MonadFix

357+ , MonadIO

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

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

349

389

350--------------------------------------------------------------------------------

390--------------------------------------------------------------------------------

351-- Typed channels --

391-- 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

11 , eventLogTracer

12 ) where

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

14+import Control.Applicative

15import Control.Concurrent.Chan (writeChan)

16import Control.Concurrent.MVar

17 ( MVar

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

21 ( CQueue

22 )

23import Control.Distributed.Process.Internal.Primitives

24− ( catch

25− , finally

26− , die

24+ ( die

27 , receiveWait

25 , receiveWait

28 , forward

26 , forward

29 , sendChan

27 , sendChan

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

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

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

65import Control.Monad.Reader (ask)

63import Control.Monad.Reader (ask)

64+import Control.Monad.Catch

65+ ( catch

66+ , finally

67+ )

67import Data.Set (Set)

69import Data.Set (Set)

68import qualified Data.Set as Set

70import qualified Data.Set as Set

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

73import Data.Time.Clock (getCurrentTime)

75import Data.Time.Clock (getCurrentTime)

74import Data.Time.Format (formatTime)

76import Data.Time.Format (formatTime)

75import Debug.Trace (traceEventIO)

77import Debug.Trace (traceEventIO)

78+import Prelude

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

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

78import Prelude hiding (catch)

81import Prelude hiding (catch)