ca136cb · distributed-process

git.iko.soy/distributed-process

on master help sign in

Implement MonadCatch, MonadThrow, MonadMask for Process.

ca136cbAlexander Vershilov11 years ago

distributed-process.cabal+2−1

compare with master

unifiedsplit

@@ -56,7 +56,8 @@ Library

56 rank1dynamic >= 0.1 && < 0.4,

57 syb >= 0.3 && < 0.7,

58 transformers-base >= 0.3 && < 0.5,

59− monad-control >= 0.4

59+ monad-control >= 0.4,

60+ exceptions >= 0.5

60 Exposed-modules: Control.Distributed.Process,

61 Exposed-modules: Control.Distributed.Process,

61 Control.Distributed.Process.Closure,

62 Control.Distributed.Process.Closure,

62 Control.Distributed.Process.Debug,

63 Control.Distributed.Process.Debug,

src/Control/Distributed/Process/Internal/Primitives.hs+8−61

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

137import Control.Monad (when)

138import Control.Monad.Reader (ask)

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

140+import Control.Monad.Catch hiding (Handler, catches)

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

141import Control.Applicative ((<$>))

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

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

143import Control.Distributed.Process.Internal.StrictMVar

142import Control.Distributed.Process.Internal.StrictMVar

144 ( StrictMVar

143 ( StrictMVar

145 , modifyMVar

144 , modifyMVar

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

699

698

700-- | Terminate immediately (throws a ProcessTerminationException)

699-- | Terminate immediately (throws a ProcessTerminationException)

701terminate :: Process a

700terminate :: Process a

702−terminate = liftIO $ throwIO ProcessTerminationException

701+terminate = throwM ProcessTerminationException

703

702

704-- [Issue #110]

703-- [Issue #110]

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

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

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

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

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

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

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

711 pid <- getSelfPid

710 pid <- getSelfPid

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

711+ throwM (ProcessExitException pid (createMessage reason))

713

712

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

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

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

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

@@ -747,7 +746,7 @@ catchExit act exitHandler = catch act handleExit

747 handleExit ex@(ProcessExitException from msg) =

746 handleExit ex@(ProcessExitException from msg) =

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

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

749 then exitHandler from decoded

748 then exitHandler from decoded

750− else liftIO $ throwIO ex

749+ else throwM ex

751 where

750 where

752 decoded :: a

751 decoded :: a

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

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

@@ -771,7 +770,7 @@ catchesExit act handlers = catch act ((flip handleExit) handlers)

771 handleExit :: ProcessExitException

770 handleExit :: ProcessExitException

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

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

773 -> Process b

772 -> Process b

774− handleExit ex [] = liftIO $ throwIO ex

773+ handleExit ex [] = throwM ex

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

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

776 r <- h from msg

775 r <- h from msg

777 case r of

776 case r of

@@ -934,71 +933,19 @@ unmonitor ref = do

934-- Exception handling --

933-- Exception handling --

935--------------------------------------------------------------------------------

934--------------------------------------------------------------------------------

936

935

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

938−catch :: 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)

942−

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

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

945−try p = do

946− lproc <- ask

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

948−

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

950−mask :: ((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

961−

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

963−mask_ :: Process a -> Process a

964−mask_ p = do

965− lproc <- ask

966− liftIO $ Ex.mask_ $ runLocalProcess lproc p

967−

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

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

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

971− liftIO $ throwIO (e :: SomeException)

972−

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

974−bracket :: 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

981−

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

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

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

985−

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

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

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

989−

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

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

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

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

992

938

993instance Functor Handler where

939instance Functor Handler where

994 fmap f (Handler h) = Handler (fmap f . h)

940 fmap f (Handler h) = Handler (fmap f . h)

995

941

942+

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

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

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

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

998catches proc handlers = proc `catch` catchesHandler handlers

945catches proc handlers = proc `catch` catchesHandler handlers

999

946

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

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

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

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

1002 where tryHandler (Handler handler) res

949 where tryHandler (Handler handler) res

1003 = case fromException e of

950 = case fromException e of

1004 Just e' -> handler e'

951 Just e' -> handler e'

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

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

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

1139handleRegistrationReply label ok owner =

1086handleRegistrationReply label ok owner =

1140 when (not ok) $

1087 when (not ok) $

1141− liftIO $ throwIO $ ProcessRegistrationException label owner

1088+ throwM $ ProcessRegistrationException label owner

1142

1089

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

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

1144--

1091--

src/Control/Distributed/Process/Internal/Types.hs+21

@@ -6,6 +6,7 @@

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE Rank2Types #-}

10-- | Types used throughout the Cloud Haskell framework

11-- | Types used throughout the Cloud Haskell framework

11--

12--

@@ -114,6 +115,7 @@ import Control.Concurrent (ThreadId)

114import Control.Concurrent.Chan (Chan)

115import Control.Concurrent.Chan (Chan)

115import Control.Concurrent.STM (STM)

116import Control.Concurrent.STM (STM)

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

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

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

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

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

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

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

119import Control.Monad.Fix (MonadFix)

121import Control.Monad.Fix (MonadFix)

@@ -358,6 +360,25 @@ newtype Process a = Process {

358

360

359instance MonadBase IO Process where

361instance MonadBase IO Process where

360 liftBase = liftIO

362 liftBase = liftIO

363+instance MonadThrow Process where

364+ throwM = liftIO . throwIO

365+instance MonadCatch Process where

366+ catch p h = do

367+ lproc <- ask

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

369+instance MonadMask Process where

370+ mask p = do

371+ lproc <- ask

372+ liftIO $ mask $ \restore ->

373+ runLocalProcess lproc (p (liftRestore restore))

374+ where

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

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

377+ liftRestore restoreIO = \p2 -> do

378+ ourLocalProc <- ask

379+ liftIO $ restoreIO $ runLocalProcess ourLocalProc p2

380+

381+

361

382

362newtype StMProcess a = StMProcess { unStMProcess :: StM (ReaderT LocalProcess IO) a }

383newtype StMProcess a = StMProcess { unStMProcess :: StM (ReaderT LocalProcess IO) a }

363

384