packages feed

distributed-process-extras 0.3.0 → 0.3.1

raw patch · 12 files changed

+111/−137 lines, 12 filesdep ~data-accessordep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: data-accessor, time

API changes (from Hackage documentation)

- Control.Distributed.Process.Extras: data ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: __remoteTable :: RemoteTable -> RemoteTable
- Control.Distributed.Process.Extras.Internal.Types: data ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Internal.Types.Message
- Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Internal.Types.ProcessId
- Control.Distributed.Process.Extras.SystemLog: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.SystemLog.LogText
- Control.Distributed.Process.Extras.Timer: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.Timer.Tick
- Control.Distributed.Process.Extras.Timer: instance Control.Distributed.Process.Extras.Internal.Types.NFSerializable Control.Distributed.Process.Extras.Timer.TimerConfig
+ Control.Distributed.Process.Extras: newtype ServerDisconnected
+ Control.Distributed.Process.Extras.Internal.Types: instance (Control.DeepSeq.NFData a, Control.Distributed.Process.Serializable.Serializable a) => Control.Distributed.Process.Extras.Internal.Types.NFSerializable a
+ Control.Distributed.Process.Extras.Internal.Types: instance Control.Distributed.Process.Extras.Internal.Types.Resolvable p => Control.Distributed.Process.Extras.Internal.Types.Killable p
+ Control.Distributed.Process.Extras.Internal.Types: newtype ServerDisconnected
- Control.Distributed.Process.Extras: ServerDisconnected :: !DiedReason -> ServerDisconnected
+ Control.Distributed.Process.Extras: ServerDisconnected :: DiedReason -> ServerDisconnected
- Control.Distributed.Process.Extras.Internal.Types: ServerDisconnected :: !DiedReason -> ServerDisconnected
+ Control.Distributed.Process.Extras.Internal.Types: ServerDisconnected :: DiedReason -> ServerDisconnected

Files

ChangeLog view
@@ -1,5 +1,15 @@ 2017-02-05 Tim Watson <watson.timothy @ google mail service dot com> 0.3.0 +* re-implement whereIsRemote in terms of whereIsRemoteAsync+* re-implement whereisOrStart to avoid leaking zombie processes+* implement general NFSerializable instances+* make Resolvable instance of (NodeId, String) exception safe+* remove dependency on data-accessor+* Relax upper bound on time for testing+* documentation fixes and improvements++2017-02-05 Tim Watson <watson.timothy @ google mail service dot com> 0.3.0+ * Update dependency bounds - drop support for distributed-process < 0.6.6 * Drop support for GHC < 7.10 * Fixes for testing with latest stack and CI changes
distributed-process-extras.cabal view
@@ -1,5 +1,5 @@ name:           distributed-process-extras-version:        0.3.0+version:        0.3.1 cabal-version:  >=1.8 build-type:     Simple license:        BSD3@@ -31,7 +31,6 @@  library   build-depends:   base >= 4.6 && < 5,-                   data-accessor >= 0.2.2.3,                    distributed-process >= 0.6.6 && < 0.7,                    binary >= 0.6.3.0 && < 0.9,                    deepseq >= 1.3.0.1 && < 1.6,@@ -168,7 +167,7 @@                    network >= 2.3 && < 2.7,                    HUnit >= 1.2 && < 2,                    stm >= 2.3 && < 2.5,-                   time > 1.4 && < 1.8,+                   time > 1.4 && < 1.9,                    test-framework >= 0.6 && < 0.9,                    test-framework-hunit,                    transformers,
src/Control/Distributed/Process/Extras.hs view
@@ -33,6 +33,13 @@ semantics of these operations, and therefore the /unsafe/ moniker will remain in place, in one form or another, for all functions and modules that use them. +[Addressing/Interaction Tools]++The various type classes exposed here, along with some common data types (such+as @Shutdown@, @ServerDisconnected@, etc.) are intended to simplify your CH+programs, and facilitate easily plugging code into higher level libraries such+as distributed-process-client-server and distributed-process-supervisor.+ [Error/Exception Handling]  It is /important/ not to be too general when catching exceptions in@@ -110,12 +117,9 @@ import Control.Distributed.Process.Extras.UnsafePrimitives import Control.Distributed.Process.Extras.Internal.Primitives hiding (__remoteTable) import qualified Control.Distributed.Process.Extras.Internal.Primitives (__remoteTable)-import qualified Control.Distributed.Process.Extras.Internal.Types      (__remoteTable)  -- remote table  __remoteTable :: RemoteTable -> RemoteTable __remoteTable =-  Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable .-  Control.Distributed.Process.Extras.Internal.Types.__remoteTable-+  Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable
src/Control/Distributed/Process/Extras/Internal/Primitives.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Distributed.Process.Extras.Internal.Primitives--- Copyright   :  (c) Tim Watson 2013, Parallel Scientific (Jeff Epstein) 2012+-- Copyright   :  (c) Tim Watson 2013 - 2017, Parallel Scientific (Jeff Epstein) 2012 -- License     :  BSD3 (see the file LICENSE) -- -- Maintainers :  Jeff Epstein, Tim Watson@@ -56,7 +56,7 @@   ) where  import Control.Concurrent (myThreadId, throwTo)-import Control.Distributed.Process hiding (monitor)+import Control.Distributed.Process hiding (monitor, finally, catch) import qualified Control.Distributed.Process as P (monitor) import Control.Distributed.Process.Closure (seqCP, remotable, mkClosure) import Control.Distributed.Process.Serializable (Serializable)@@ -71,6 +71,7 @@   , whereisRemote   ) import Control.Monad (void)+import Control.Monad.Catch (finally, catchIf) import Data.Maybe (isJust, fromJust)  -- utility@@ -96,9 +97,12 @@                   (\_ -> return ())         ] +-- | deliver = flip sendTo deliver :: (Addressable a, Serializable m) => m -> a -> Process () deliver = flip sendTo +-- | True if getProcessInfo /= Nothing+-- NB: only works for local processes. isProcessAlive :: ProcessId -> Process Bool isProcessAlive pid = getProcessInfo pid >>= \info -> return $ info /= Nothing @@ -133,7 +137,7 @@       matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)               (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr))     , matchChan recvStart (\() -> return pid)-    ]+    ] `finally` (unmonitor mRef)  -- | Node local version of 'Control.Distributed.Process.spawnLink'. -- Note that this is just the sequential composition of 'spawn' and 'link'.@@ -182,31 +186,20 @@ -- is started. This is a handy way to start per-node named servers. -- whereisOrStart :: String -> Process () -> Process ProcessId-whereisOrStart name proc =-  do mpid <- whereis name-     case mpid of-       Just pid -> return pid-       Nothing ->-         do caller <- getSelfPid-            pid <- spawnLocal $-                 do self <- getSelfPid-                    register name self-                    send caller (RegisterSelf,self)-                    () <- expect-                    proc-            ref <- P.monitor pid-            ret <- receiveWait-               [ matchIf (\(ProcessMonitorNotification aref _ _) -> ref == aref)-                         (\(ProcessMonitorNotification _ _ _) -> return Nothing),-                 matchIf (\(RegisterSelf,apid) -> apid == pid)-                         (\(RegisterSelf,_) -> return $ Just pid)-               ]-            case ret of-              Nothing -> whereisOrStart name proc-              Just somepid ->-                do unmonitor ref-                   send somepid ()-                   return somepid+whereisOrStart name proc = do+  (sigStart, recvStart) <- newChan+  (_, mRef) <- spawnMonitorLocal $ do+    us <- getSelfPid+    catchIf (\(ProcessRegistrationException _ r) -> isJust r)+            (register name us >> sendChan sigStart us)+            (\(ProcessRegistrationException _ rPid) ->+                sendChan sigStart $ fromJust rPid)+    proc+  receiveWait [+      matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+              (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr))+    , matchChan recvStart return+    ] `finally` (unmonitor mRef)  registerSelf :: (String, ProcessId) -> Process () registerSelf (name,target) =@@ -287,4 +280,3 @@     matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r')                          (\(ProcessMonitorNotification _ _ d) -> do                              return (Left (ExitOther (show d))))-
src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs view
@@ -1,15 +1,3 @@--------------------------------------------------------------------------------- |--- Module      :  Control.Distributed.Process.Extras.Internal.Queue.SeqQ--- Copyright   :  (c) Tim Watson 2012 - 2013--- License     :  BSD3 (see the file LICENSE)------ Maintainer  :  Tim Watson <watson.timothy@gmail.com>--- Stability   :  experimental------ A simple FIFO queue implementation backed by @Data.Sequence@.------------------------------------------------------------------------------- module Control.Distributed.Process.Extras.Internal.Queue.SeqQ   ( SeqQ   , empty@@ -21,6 +9,8 @@   )   where +-- A simple FIFO queue implementation backed by @Data.Sequence@.+ import Data.Sequence   ( Seq   , ViewR(..)@@ -63,4 +53,3 @@   case (viewr (q s)) of     EmptyR -> Nothing     a      -> Just a-
src/Control/Distributed/Process/Extras/Internal/Types.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE DeriveDataTypeable     #-} {-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE StandaloneDeriving     #-}-{-# LANGUAGE TemplateHaskell        #-} {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE DefaultSignatures      #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}  -- | Types used throughout the Extras package --@@ -32,8 +30,6 @@   , ExitReason(..)   , ServerDisconnected(..)   , NFSerializable-    -- remote table-  , __remoteTable   ) where  import Control.Concurrent.MVar@@ -42,19 +38,15 @@   , modifyMVar   ) import Control.DeepSeq (NFData(..), ($!!))-import Control.Distributed.Process hiding (send)+import Control.Distributed.Process hiding (send, catch) import qualified Control.Distributed.Process as P   ( send   , unsafeSend   , unsafeNSend   )-import Control.Distributed.Process.Closure-  ( remotable-  , mkClosure-  , functionTDict-  ) import Control.Distributed.Process.Serializable-+import Control.Exception (SomeException)+import Control.Monad.Catch (catch) import Data.Binary import Data.Foldable (traverse_) import Data.Typeable (Typeable)@@ -73,10 +65,9 @@ -- behaviour by using /unsafe/ primitives in this way. -- class (NFData a, Serializable a) => NFSerializable a+instance (NFData a, Serializable a) => NFSerializable a -instance NFSerializable ProcessId instance (NFSerializable a) => NFSerializable (SendPort a)-instance NFSerializable Message  -- | Tags provide uniqueness for messages, so that they can be -- matched with their response.@@ -98,14 +89,20 @@ getTag :: TagPool -> Process Tag getTag tp = liftIO $ modifyMVar tp (\tag -> return (tag+1,tag)) -$(remotable ['whereis])---- | A synchronous version of 'whereis', this relies on 'call'--- to perform the relevant monitoring of the remote node.+-- | A synchronous version of 'whereis', this monitors the remote node+-- and returns @Nothing@ if the node goes down (since a remote node failing+-- or being non-contactible has the same effect as a process not being+-- registered from the caller's point of view). whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)-whereisRemote node name =-  call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name)-+whereisRemote node name = do+  mRef <- monitorNode node+  whereisRemoteAsync node name+  receiveWait [ matchIf (\(NodeMonitorNotification ref nid _) -> ref == mRef &&+                                                                 nid == node)+                        (\NodeMonitorNotification{} -> return Nothing)+              , matchIf (\(WhereIsReply n _) -> n == name)+                        (\(WhereIsReply _ mPid) -> return mPid)+              ]  -- | Wait cancellation message. data CancelWait = CancelWait@@ -158,6 +155,8 @@   exitProc :: (Resolvable p, Serializable m) => p -> m -> Process ()   exitProc r m = resolve r >>= traverse_ (flip exit $ m) +instance Resolvable p => Killable p+ -- | resolve the Resolvable or die with specified msg plus details of what didn't resolve resolveOrDie  :: (Resolvable a) => a -> String -> Process ProcessId resolveOrDie resolvable failureMsg = do@@ -185,7 +184,8 @@   unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]"  instance Resolvable (NodeId, String) where-  resolve (nid, pname) = whereisRemote nid pname+  resolve (nid, pname) =+    whereisRemote nid pname `catch` (\(_ :: SomeException) -> return Nothing)   unresolvableMessage (n, s) =     "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" @@ -220,8 +220,8 @@   unsafeSendTo name msg = P.unsafeNSend name $!! msg  instance Routable (NodeId, String) where-  sendTo  (nid, pname) msg   = nsendRemote nid pname msg-  unsafeSendTo               = sendTo -- because serialisation *must* take place+  sendTo  (nid, pname) = nsendRemote nid pname+  unsafeSendTo         = sendTo -- because serialisation *must* take place  instance Routable (Message -> Process ()) where   sendTo f       = f . wrapMessage@@ -269,7 +269,7 @@ -- useful exit reasons  -- | Given when a server is unobtainable.-data ServerDisconnected = ServerDisconnected !DiedReason+newtype ServerDisconnected = ServerDisconnected DiedReason   deriving (Typeable, Generic) instance Binary ServerDisconnected where instance NFData ServerDisconnected where
src/Control/Distributed/Process/Extras/Internal/Unsafe.hs view
@@ -1,11 +1,20 @@ {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}  -- | If you don't know exactly what this module is for and precisely -- how to use the types within, you should move on, quickly! --+-- [Implementation Notes]+-- This module provides facilities for forcibly sending non-serializable+-- data via cloud haskell's messaging primitives, such as @send@ et al.+-- Of course, if you attmept to do this when interacting with a remote process,+-- your application will break.+--+-- NB: this module will be deprecated in the next dot release, pending rewrite+-- of the libraries that currently rely on it, to use the new supporting APIs+-- for STM interactions in distributed-process-client-server.+-- module Control.Distributed.Process.Extras.Internal.Unsafe   ( -- * Copying non-serializable data     PCopy()@@ -125,4 +134,3 @@ matchInputStream (ReadSTM stm) = matchSTM stm return matchInputStream Null          = match (\NullInputStream -> do                                            error "NullInputStream")-
src/Control/Distributed/Process/Extras/Monitoring.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Distributed.Process.Extras.Monitoring--- Copyright   :  (c) Tim Watson 2013 - 2014+-- Copyright   :  (c) Tim Watson 2013 - 2017 -- License     :  BSD3 (see the file LICENSE) -- -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>@@ -136,4 +136,3 @@      nodeUp = NodeUp . NodeId     nodeDown = NodeDown . NodeId-
src/Control/Distributed/Process/Extras/SystemLog.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Distributed.Process.Extras.SystemLog--- Copyright   :  (c) Tim Watson 2013 - 2014+-- Copyright   :  (c) Tim Watson 2013 - 2017 -- License     :  BSD3 (see the file LICENSE) -- -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>@@ -86,18 +86,10 @@   ( Resolvable(..)   , Routable(..)   , Addressable-  , NFSerializable   ) import Control.Distributed.Process.Serializable import Control.Exception (SomeException) import Control.Monad.Catch (catch)-import Data.Accessor-  ( Accessor-  , accessor-  , (^:)-  , (^=)-  , (^.)-  ) import Data.Binary import Data.Typeable (Typeable) import GHC.Generics@@ -142,11 +134,11 @@ instance Binary AddFormatter  data LogState =-  LogState { output      :: !(String -> Process ())-           , cleanup     :: !(Process ())-           , _level      :: !LogLevel-           , _format     :: !(String -> Process String)-           , _formatters :: ![Message -> Process (Maybe String)]+  LogState { output     :: !(String -> Process ())+           , cleanup    :: !(Process ())+           , level      :: !LogLevel+           , format     :: !(String -> Process String)+           , formatters :: ![Message -> Process (Maybe String)]            }  data LogMessage =@@ -166,7 +158,6 @@   unsafeSendTo _ = mxNotify  type LogText = String-instance NFSerializable LogText  newtype LogClient = LogClient { agent :: ProcessId } instance Resolvable LogClient where@@ -206,7 +197,7 @@        -> l        -> String        -> Process ()-report f l = f l +report f l = f l  client :: Process (Maybe LogClient) client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient)@@ -269,17 +260,17 @@ systemLog o c l f = go $ LogState o c l f defaultFormatters   where     go :: LogState -> Process ProcessId-    go st = do+    go st =       mxAgentWithFinalize mxLogId st [             -- these are the messages we're /really/ interested in-            (mxSink $ \(m :: LogMessage) -> do+            (mxSink $ \(m :: LogMessage) ->                 case m of-                  (LogMessage msg lvl) -> do+                  (LogMessage msg lvl) ->                     mxGetLocal >>= outputMin lvl msg >> mxReceive                   (LogData dat lvl) -> handleRawMsg dat lvl)              -- complex messages rely on properly registered formatters-          , (mxSink $ \(ev :: MxEvent) -> do+          , (mxSink $ \(ev :: MxEvent) ->                 case ev of                   (MxUser msg) -> handleRawMsg msg Debug                   -- we treat trace/log events like regular log events at@@ -289,14 +280,14 @@              -- command message handling           , (mxSink $ \(SetLevel lvl) ->-                mxGetLocal >>= mxSetLocal . (level ^= lvl) >> mxReceive)+                mxGetLocal >>= \st' -> mxSetLocal st' { level = lvl } >> mxReceive)           , (mxSink $ \(AddFormatter f') -> do                 fmt <- liftMX $ catch (unClosure f' >>= return . Just)                                       (\(_ :: SomeException) -> return Nothing)                 case fmt of                   Nothing -> mxReady                   Just mf -> do-                    mxUpdateLocal (formatters ^: (mf:))+                    mxUpdateLocal (\s -> s { formatters = mf:formatters s })                     mxReceive)         ] runCleanup @@ -309,15 +300,15 @@         Just str -> outputMin lvl' str st >> mxReceive         Nothing  -> mxReceive  -- we cannot format a Message, so we ignore it -    handleEvent (MxConnected    _ ep) = do+    handleEvent (MxConnected    _ ep) =           mxGetLocal >>= outputMin Notice-                                   ("Endpoint: " ++ (show ep) ++ " Disconnected")-    handleEvent (MxDisconnected _ ep) = do+                                   ("Endpoint: " ++ show ep ++ " Disconnected")+    handleEvent (MxDisconnected _ ep) =           mxGetLocal >>= outputMin Notice-                                   ("Endpoint " ++ (show ep) ++ " Connected")+                                   ("Endpoint " ++ show ep ++ " Connected")     handleEvent _                     = return () -    formatMsg m st = let fms = st ^. formatters in formatMsg' m fms+    formatMsg m LogState{..} = let fms = formatters in formatMsg' m fms      formatMsg' _ []     = return Nothing     formatMsg' m (f':fs) = do@@ -326,22 +317,12 @@         ok@(Just _) -> return ok         Nothing     -> formatMsg' m fs -    outputMin minLvl msgData st =-      case minLvl >= (st ^. level) of-        True  -> liftMX $ ((st ^. format) msgData >>= (output st))+    outputMin minLvl msgData LogState{..} =+      case minLvl >= level of+        True  -> liftMX (format msgData >>= output)         False -> return ()      defaultFormatters = [basicDataFormat]  basicDataFormat :: Message -> Process (Maybe String) basicDataFormat = unwrapMessage--level :: Accessor LogState LogLevel-level = accessor _level (\l s -> s { _level = l })--format :: Accessor LogState LogFormat-format = accessor _format (\f s -> s { _format = f })--formatters :: Accessor LogState [Message -> Process (Maybe String)]-formatters = accessor _formatters (\n' st -> st { _formatters = n' })-
src/Control/Distributed/Process/Extras/Timer.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE PatternGuards      #-}-{-# LANGUAGE TemplateHaskell    #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Control.Distributed.Process.Extras.Timer--- Copyright   :  (c) Tim Watson 2012+-- Copyright   :  (c) Tim Watson 2012 - 2017 -- License     :  BSD3 (see the file LICENSE) -- -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>@@ -42,6 +40,7 @@ import Control.Distributed.Process.Extras.UnsafePrimitives (send) import Control.Distributed.Process.Extras.Internal.Types (NFSerializable) import Control.Distributed.Process.Extras.Time+import Control.Monad (unless, void) import Data.Binary import Data.Typeable (Typeable) import Prelude hiding (init)@@ -57,7 +56,6 @@ instance Binary TimerConfig where instance NFData TimerConfig where   rnf tc = tc `seq` ()-instance NFSerializable TimerConfig  -- | represents a 'tick' event that timers can generate data Tick = Tick@@ -65,7 +63,6 @@ instance Binary Tick where instance NFData Tick where   rnf t = t `seq` ()-instance NFSerializable Tick  data SleepingPill = SleepingPill     deriving (Typeable, Generic, Eq, Show)@@ -99,7 +96,7 @@           -> a           -> Process TimerRef sendAfter t pid msg = runAfter t proc-  where proc = do { send pid msg }+  where proc = send pid msg  -- | runs the supplied process action(s) after @t@ has elapsed runAfter :: TimeInterval -> Process () -> Process TimerRef@@ -138,11 +135,11 @@ -- out, after which the timer will continue running. To stop a long-running -- timer permanently, you should use 'cancelTimer' instead. resetTimer :: TimerRef -> Process ()-resetTimer = (flip send) Reset+resetTimer = flip send Reset  -- | permanently cancels a timer cancelTimer :: TimerRef -> Process ()-cancelTimer = (flip send) Cancel+cancelTimer = flip send Cancel  -- | cancels a running timer and flushes any viable timer messages from the -- process' message queue. This function should only be called by the process@@ -155,9 +152,9 @@     return ()   where performFlush mRef Infinity  = receiveWait $ filters mRef         performFlush mRef NoDelay   = performFlush mRef (Delay $ microSeconds 0)-        performFlush mRef (Delay i) = receiveTimeout (asTimeout i) (filters mRef) >> return ()+        performFlush mRef (Delay i) = void (receiveTimeout (asTimeout i) (filters mRef))         filters mRef = [-                matchIf (\x -> x == ignore)+                matchIf (== ignore)                         (\_ -> return ())               , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef == mRef')                         (\_ -> return ()) ]@@ -178,7 +175,6 @@     case cancel of         Nothing     -> runProc cancelOnReset         Just Cancel -> return ()-        Just Reset  -> if cancelOnReset then return ()-                                        else runTimer t proc cancelOnReset+        Just Reset  -> unless cancelOnReset $ runTimer t proc cancelOnReset   where runProc True  = proc         runProc False = proc >> runTimer t proc cancelOnReset
src/Control/Distributed/Process/Extras/UnsafePrimitives.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Distributed.Process.Extras.UnsafePrimitives--- Copyright   :  (c) Tim Watson 2013+-- Copyright   :  (c) Tim Watson 2013 - 2017 -- License     :  BSD3 (see the file LICENSE) -- -- Maintainer  :  Tim Watson <watson.timothy@gmail.com>@@ -60,4 +60,3 @@ -- | Create an unencoded @Message@ for any @Serializable@ type. wrapMessage :: NFSerializable a => a -> Message wrapMessage msg = Unsafe.wrapMessage $!! msg-
tests/TestTimer.hs view
@@ -16,7 +16,6 @@ import Control.Distributed.Process import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable()-import Control.Distributed.Process.Extras (NFSerializable) import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Distributed.Process.SysTest.Utils@@ -28,9 +27,7 @@  import GHC.Generics --- orphan instance instance NFData Ping where-instance NFSerializable Ping  testSendAfter :: TestResult Bool -> Process () testSendAfter result =@@ -66,7 +63,7 @@   pid <- periodically delay noop   ref <- monitor pid   _ <- getProcessInfo pid-  +   cancelTimer pid    _ <- receiveWait [