distributed-process-extras 0.2.1.2 → 0.3.0

raw patch · 12 files changed

+220/−240 lines, 12 filesdep +distributed-process-systestdep +exceptionsdep +old-localedep −derivedep −distributed-process-testsdep −template-haskelldep ~basedep ~distributed-processdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: distributed-process-systest, exceptions, old-locale

Dependencies removed: derive, distributed-process-tests, template-haskell, uniplate

Dependency ranges changed: base, distributed-process, mtl, time, transformers

API changes (from Hackage documentation)

Files

• ChangeLog +6/−9
• distributed-process-extras.cabal +40/−35
• src/Control/Concurrent/Utils.hs +27/−50
• src/Control/Distributed/Process/Extras.hs +0/−3
• src/Control/Distributed/Process/Extras/Internal/Types.hs +103/−109
• src/Control/Distributed/Process/Extras/SystemLog.hs +27/−23
• src/Control/Distributed/Process/Extras/Time.hs +1/−1
• src/Control/Distributed/Process/Extras/Timer.hs +5/−1
• tests/TestLog.hs +3/−3
• tests/TestPrimitives.hs +1/−1
• tests/TestQueues.hs +2/−2
• tests/TestTimer.hs +5/−3

@@ -1,3 +1,9 @@+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+ 2016-02-16 Facundo Domínguez <facundo.dominguez@tweag.io> 0.2.1.2  * Update dependency bounds.@@ -8,12 +14,3 @@ * Add compatibility with ghc-7.10. * Fix dependency bounds. * Add missing NFData instances.--# HEAD--* Added initial GenServer module-* Added Timer Module-* Moved time functions into Time.hs-* Added Async API-* Added GenProcess API (subsumes lower level GenServer API)-

@@ -1,21 +1,21 @@ name:           distributed-process-extras-version:        0.2.1.2+version:        0.3.0 cabal-version:  >=1.8 build-type:     Simple license:        BSD3 license-file:   LICENCE stability:      experimental-Copyright:      Tim Watson 2012 - 2013+Copyright:      Tim Watson 2012 - 2017 Author:         Tim Watson-Maintainer:     Facundo Domínguez <facundo.dominguez@tweag.io>+Maintainer:     Tim Watson <watson.timothy@gmail.com> Stability:      experimental Homepage:       http://github.com/haskell-distributed/distributed-process-extras-Bug-Reports:    https://cloud-haskell.atlassian.net+Bug-Reports:    http://github.com/haskell-distributed/distributed-process-extras/issues synopsis:       Cloud Haskell Extras description:    Supporting library, providing common types and utilities used by the-                various components that make up the distributed-process-platform package.+                various libraries built on top of distributed-process category:       Control-tested-with:    GHC == 7.4.2 GHC == 7.6.2+Tested-With:    GHC==7.10.3 GHC==8.0.1 GHC==8.0.2 data-dir:       "" extra-source-files: ChangeLog @@ -23,29 +23,34 @@   type:      git   location:  https://github.com/haskell-distributed/distributed-process-extras +flag old-locale+  description: If false then depend on time >= 1.5.+               .+               If true then depend on time < 1.5 together with old-locale.+  default: False+ library-  build-depends:-                   base >= 4.4 && < 5,+  build-depends:   base >= 4.6 && < 5,                    data-accessor >= 0.2.2.3,-                   distributed-process >= 0.5.3 && < 0.7,-                   binary >= 0.6.3.0 && < 0.8,+                   distributed-process >= 0.6.6 && < 0.7,+                   binary >= 0.6.3.0 && < 0.9,                    deepseq >= 1.3.0.1 && < 1.6,-                   mtl,+                   mtl >= 2.0 && < 2.4,                    containers >= 0.4 && < 0.6,+                   exceptions >= 0.5,                    hashable >= 1.2.0.5 && < 1.3,                    unordered-containers >= 0.2.3.0 && < 0.3,                    fingertree < 0.2,                    stm >= 2.4 && < 2.5,-                   time > 1.4 && < 1.6,-                   transformers-  if impl(ghc <= 7.5)-    Build-Depends:   template-haskell == 2.7.0.0,-                     derive == 2.5.5,-                     uniplate == 1.6.12,-                     ghc-prim+                   transformers >= 0.2 && < 0.6+  if flag(old-locale)+    Build-Depends:   time < 1.5, old-locale >= 1.0 && <1.1+  else+    Build-Depends:   time >= 1.5   extensions:      CPP-  hs-source-dirs:   src+  other-extensions: ExistentialQuantification   ghc-options:      -Wall+  HS-Source-Dirs:    src   exposed-modules:                    Control.Distributed.Process.Extras,                    Control.Distributed.Process.Extras.Call,@@ -66,11 +71,11 @@   type:            exitcode-stdio-1.0   x-uses-tf:       true   build-depends:-                   base >= 4.4 && < 5,+                   base >= 4.6 && < 5,                    ansi-terminal >= 0.5 && < 0.7,-                   distributed-process >= 0.5.3 && < 0.7,+                   distributed-process >= 0.6.6 && < 0.7,                    distributed-process-extras,-                   distributed-process-tests >= 0.4.2 && < 0.5,+                   distributed-process-systest >= 0.1.0 && < 0.2.0,                    HUnit >= 1.2 && < 2,                    test-framework >= 0.6 && < 0.9,                    test-framework-hunit,@@ -89,16 +94,16 @@   type:            exitcode-stdio-1.0   x-uses-tf:       true   build-depends:-                   base >= 4.4 && < 5,+                   base >= 4.6 && < 5,                    ansi-terminal >= 0.5 && < 0.7,-                   distributed-process >= 0.5.3 && < 0.7,+                   distributed-process >= 0.6.6 && < 0.7,                    distributed-process-extras,-                   distributed-process-tests >= 0.4.2 && < 0.5,+                   distributed-process-systest >= 0.1.0 && < 0.2.0,                    network-transport >= 0.4 && < 0.5,                    mtl,                    containers >= 0.4 && < 0.6,                    network-transport-tcp >= 0.4 && < 0.6,-                   binary >= 0.6.3.0 && < 0.8,+                   binary >= 0.6.3.0 && < 0.9,                    deepseq >= 1.3.0.1 && < 1.6,                    network >= 2.3 && < 2.7,                    HUnit >= 1.2 && < 2,@@ -117,12 +122,12 @@   type:            exitcode-stdio-1.0   x-uses-tf:       true   build-depends:-                   base >= 4.4 && < 5,+                   base >= 4.6 && < 5,                    ansi-terminal >= 0.5 && < 0.7,                    deepseq >= 1.3.0.1 && < 1.6,-                   distributed-process >= 0.5.3 && < 0.7,+                   distributed-process >= 0.6.6 && < 0.7,                    distributed-process-extras,-                   distributed-process-tests >= 0.4.2 && < 0.5,+                   distributed-process-systest >= 0.1.0 && < 0.2.0,                    network-transport >= 0.4 && < 0.5,                    network-transport-tcp >= 0.4 && < 0.6,                    HUnit >= 1.2 && < 2,@@ -143,14 +148,14 @@   type:            exitcode-stdio-1.0 --  x-uses-tf:       true   build-depends:-                   base >= 4.4 && < 5,+                   base >= 4.6 && < 5,                    ansi-terminal >= 0.5 && < 0.7,                    containers,                    hashable,                    unordered-containers >= 0.2.3.0 && < 0.3,-                   distributed-process >= 0.5.3 && < 0.7,+                   distributed-process >= 0.6.6 && < 0.7,                    distributed-process-extras,-                   distributed-process-tests >= 0.4.2 && < 0.5,+                   distributed-process-systest >= 0.1.0 && < 0.2.0,                    distributed-static,                    bytestring,                    data-accessor,@@ -159,11 +164,11 @@                    deepseq >= 1.3.0.1 && < 1.6,                    mtl,                    network-transport-tcp >= 0.4 && < 0.6,-                   binary >= 0.6.3.0 && < 0.8,+                   binary >= 0.6.3.0 && < 0.9,                    network >= 2.3 && < 2.7,                    HUnit >= 1.2 && < 2,                    stm >= 2.3 && < 2.5,-                   time > 1.4 && < 1.6,+                   time > 1.4 && < 1.8,                    test-framework >= 0.6 && < 0.9,                    test-framework-hunit,                    transformers,@@ -171,6 +176,6 @@                    ghc-prim   hs-source-dirs:                    tests-  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind   extensions:      CPP   main-is:         TestLog.hs

@@ -1,65 +1,42 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-+{-# LANGUAGE ExistentialQuantification #-} module Control.Concurrent.Utils   ( Lock()-  , Exclusive(..)-  , Synchronised(..)+  , mkExclusiveLock+  , mkQLock   , withLock   ) where -import Control.Distributed.Process-  ( Process-  )-import qualified Control.Distributed.Process as Process (catch)-import Control.Exception (SomeException, throw)-import qualified Control.Exception as Exception (catch)+import Control.Monad.Catch (MonadMask)+import qualified Control.Monad.Catch as Catch import Control.Concurrent.MVar-  ( MVar-  , tryPutMVar-  , newMVar+  ( newMVar   , takeMVar+  , putMVar   )+import Control.Concurrent.QSem import Control.Monad.IO.Class (MonadIO, liftIO) -newtype Lock = Lock { mvar :: MVar () }--class Exclusive a where-  new          :: IO a-  acquire      :: (MonadIO m) => a -> m ()-  release      :: (MonadIO m) => a -> m ()--instance Exclusive Lock where-  new       = return . Lock =<< newMVar ()-  acquire   = liftIO . takeMVar . mvar-  release l = liftIO (tryPutMVar (mvar l) ()) >> return ()--class Synchronised e m where-  synchronised :: (Exclusive e, Monad m) => e -> m b -> m b+-- | Opaque lock.+data Lock = forall l . Lock l (l -> IO ()) (l -> IO ()) -  synchronized :: (Exclusive e, Monad m) => e -> m b -> m b-  synchronized = synchronised+-- | Take a lock.+acquire :: MonadIO m => Lock -> m ()+acquire (Lock l acq _) = liftIO $ acq l -instance Synchronised Lock IO where-  synchronised = withLock+-- | Release lock.+release :: MonadIO m => Lock -> m ()+release (Lock l _ rel) = liftIO $ rel l -instance Synchronised Lock Process where-  synchronised = withLockP+-- | Create exclusive lock. Only one process could take such lock.+mkExclusiveLock :: IO Lock+mkExclusiveLock = Lock <$> newMVar () <*> pure takeMVar <*> pure (flip putMVar ()) -withLockP :: (Exclusive e) => e -> Process a -> Process a-withLockP excl act = do-  Process.catch (do { liftIO $ acquire excl-                    ; result <- act-                    ; liftIO $ release excl-                    ; return result-                    })-                (\(e :: SomeException) -> (liftIO $ release excl) >> throw e)+-- | Create quantity lock. A fixed number of processes can take this lock simultaniously.+mkQLock :: Int -> IO Lock+mkQLock n = Lock <$> newQSem n <*> pure waitQSem <*> pure signalQSem -withLock :: (Exclusive e) => e -> IO a -> IO a-withLock excl act = do-  Exception.catch (do { acquire excl-                      ; result <- act-                      ; release excl-                      ; return result-                      })-                  (\(e :: SomeException) -> release excl >> throw e)+-- | Run action under a held lock.+withLock :: (MonadMask m, MonadIO m) => Lock -> m a -> m a+withLock excl =+  Catch.bracket_  (acquire excl)+                  (release excl)

@@ -51,7 +51,6 @@   (     -- * Exported Types     Addressable-  , sendToRecipient   , Resolvable(..)   , Routable(..)   , Linkable(..)@@ -97,8 +96,6 @@ import Control.Distributed.Process (RemoteTable) import Control.Distributed.Process.Extras.Internal.Types   ( NFSerializable-  , sendToRecipient-  , NFSerializable   , Recipient(..)   , Shutdown(..)   , ExitReason(..)

@@ -3,10 +3,9 @@ {-# LANGUAGE StandaloneDeriving     #-} {-# LANGUAGE TemplateHaskell        #-} {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE OverlappingInstances   #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}  -- | Types used throughout the Extras package --@@ -22,7 +21,6 @@   , Resolvable(..)   , Routable(..)   , Addressable-  , sendToRecipient   , Recipient(..)   , RegisterSelf(..)     -- * Interactions@@ -58,6 +56,7 @@ import Control.Distributed.Process.Serializable  import Data.Binary+import Data.Foldable (traverse_) import Data.Typeable (Typeable) import GHC.Generics @@ -74,8 +73,11 @@ -- 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. type Tag = Int@@ -96,6 +98,15 @@ 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.+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)+whereisRemote node name =+  call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name)++ -- | Wait cancellation message. data CancelWait = CancelWait     deriving (Eq, Show, Typeable, Generic)@@ -128,154 +139,137 @@ instance Binary ExitReason where instance NFData ExitReason where --- | A simple means of mapping to a receiver.-data Recipient =-    Pid !ProcessId-  | Registered !String-  | RemoteRegistered !String !NodeId---  | ProcReg !ProcessId !String---  | RemoteProcReg NodeId String---  | GlobalReg String-  deriving (Typeable, Generic, Show, Eq)-instance Binary Recipient where-instance NFData Recipient where-  rnf (Pid p) = rnf p `seq` ()-  rnf (Registered s) = rnf s `seq` ()-  rnf (RemoteRegistered s n) = rnf s `seq` rnf n `seq` ()---- useful exit reasons---- | Given when a server is unobtainable.-data ServerDisconnected = ServerDisconnected !DiedReason-  deriving (Typeable, Generic)-instance Binary ServerDisconnected where-instance NFData ServerDisconnected where--$(remotable ['whereis])---- | A synchronous version of 'whereis', this relies on 'call'--- to perform the relevant monitoring of the remote node.-whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)-whereisRemote node name =-  call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name)--sendToRecipient :: (Serializable m) => Recipient -> m -> Process ()-sendToRecipient (Pid p) m                = P.send p m-sendToRecipient (Registered s) m         = nsend s m-sendToRecipient (RemoteRegistered s n) m = nsendRemote n s m--unsafeSendToRecipient :: (NFSerializable m) => Recipient -> m -> Process ()-unsafeSendToRecipient (Pid p) m                = P.unsafeSend p $!! m-unsafeSendToRecipient (Registered s) m         = P.unsafeNSend s $!! m-unsafeSendToRecipient (RemoteRegistered s n) m = nsendRemote n s m--baseAddressableErrorMessage :: (Routable a) => a -> String+baseAddressableErrorMessage :: (Resolvable a) => a -> String baseAddressableErrorMessage _ = "CannotResolveAddressable"  -- | Class of things to which a @Process@ can /link/ itself. class Linkable a where   -- | Create a /link/ with the supplied object.-  linkTo :: a -> Process ()+  linkTo :: (Resolvable a) => a -> Process ()+  linkTo r = resolve r >>= traverse_ link +-- | Class of things that can be killed (or instructed to exit).+class Killable p where+  -- | Kill (instruct to exit) generic process, using 'kill' primitive.+  killProc :: Resolvable p => p -> String -> Process ()+  killProc r s = resolve r >>= traverse_ (flip kill $ s)++  -- | Kill (instruct to exit) generic process, using 'exit' primitive.+  exitProc :: (Resolvable p, Serializable m) => p -> m -> Process ()+  exitProc r m = resolve r >>= traverse_ (flip exit $ m)++-- | 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+  result <- resolve resolvable+  case result of+    Nothing  -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable+    Just pid -> return pid+ -- | Class of things that can be resolved to a 'ProcessId'. -- class Resolvable a where   -- | Resolve the reference to a process id, or @Nothing@ if resolution fails   resolve :: a -> Process (Maybe ProcessId) --- | Class of things that can be killed (or instructed to exit).-class Killable a where-  killProc :: a -> String -> Process ()-  exitProc :: (Serializable m) => a -> m -> Process ()+  -- | Unresolvable @Addressable@ Message+  unresolvableMessage :: (Resolvable a) => a -> String+  unresolvableMessage = baseAddressableErrorMessage -instance Killable ProcessId where-  killProc = kill-  exitProc = exit+instance Resolvable ProcessId where+  resolve p = return (Just p)+  unresolvableMessage p  = "CannotResolvePid[" ++ (show p) ++ "]" -instance Resolvable r => Killable r where-  killProc r s = resolve r >>= maybe (return ()) (flip kill $ s)-  exitProc r m = resolve r >>= maybe (return ()) (flip exit $ m)+instance Resolvable String where+  resolve = whereis+  unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" --- | Provides a unified API for addressing processes.----class Routable a where-  -- | Send a message to the target asynchronously-  sendTo  :: (Serializable m) => a -> m -> Process ()+instance Resolvable (NodeId, String) where+  resolve (nid, pname) = whereisRemote nid pname+  unresolvableMessage (n, s) =+    "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" -  -- | Send some @NFData@ message to the target asynchronously,-  -- forcing evaluation (i.e., @deepseq@) beforehand.-  unsafeSendTo :: (NFSerializable m) => a -> m -> Process ()+-- Provide a unified API for addressing processes. -  -- | Unresolvable @Addressable@ Message-  unresolvableMessage :: a -> String-  unresolvableMessage = baseAddressableErrorMessage+-- | Class of things that you can route/send serializable message to+class Routable a where -instance (Resolvable a) => Routable a where+  -- | Send a message to the target asynchronously+  sendTo  :: (Serializable m, Resolvable a) => a -> m -> Process ()   sendTo a m = do     mPid <- resolve a     maybe (die (unresolvableMessage a))           (\p -> P.send p m)           mPid +  -- | Send some @NFData@ message to the target asynchronously,+  -- forcing evaluation (i.e., @deepseq@) beforehand.+  unsafeSendTo :: (NFSerializable m, Resolvable a) => a -> m -> Process ()   unsafeSendTo a m = do     mPid <- resolve a     maybe (die (unresolvableMessage a))           (\p -> P.unsafeSend p $!! m)           mPid -  -- | Unresolvable Addressable Message-  unresolvableMessage = baseAddressableErrorMessage--instance Resolvable Recipient where-  resolve (Pid                p) = return (Just p)-  resolve (Registered         n) = whereis n-  resolve (RemoteRegistered s n) = whereisRemote n s--instance Routable Recipient where-  sendTo = sendToRecipient-  unsafeSendTo = unsafeSendToRecipient--  unresolvableMessage (Pid                p) = unresolvableMessage p-  unresolvableMessage (Registered         n) = unresolvableMessage n-  unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s)--instance Resolvable ProcessId where-  resolve p = return (Just p)- instance Routable ProcessId where   sendTo                 = P.send   unsafeSendTo pid msg   = P.unsafeSend pid $!! msg-  unresolvableMessage p  = "CannotResolvePid[" ++ (show p) ++ "]" -instance Resolvable String where-  resolve = whereis- instance Routable String where   sendTo                = nsend   unsafeSendTo name msg = P.unsafeNSend name $!! msg-  unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" -instance Resolvable (NodeId, String) where-  resolve (nid, pname) = whereisRemote nid pname- instance Routable (NodeId, String) where   sendTo  (nid, pname) msg   = nsendRemote nid pname msg   unsafeSendTo               = sendTo -- because serialisation *must* take place-  unresolvableMessage (n, s) =-    "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]"  instance Routable (Message -> Process ()) where   sendTo f       = f . wrapMessage   unsafeSendTo f = f . unsafeWrapMessage  class (Resolvable a, Routable a) => Addressable a-instance (Resolvable a, Routable a) => Addressable a+instance Addressable ProcessId --- TODO: this probably belongs somewhere other than in ..Types.--- | resolve the Resolvable or die with specified msg plus details of what didn't resolve-resolveOrDie  :: (Routable a, Resolvable a) => a -> String -> Process ProcessId-resolveOrDie resolvable failureMsg = do-  result <- resolve resolvable-  case result of-    Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable-    Just pid -> return pid+-- | A simple means of mapping to a receiver.+data Recipient =+    Pid !ProcessId+  | Registered !String+  | RemoteRegistered !String !NodeId+--  | ProcReg !ProcessId !String+--  | RemoteProcReg NodeId String+--  | GlobalReg String+  deriving (Typeable, Generic, Show, Eq)+instance Binary Recipient where+instance NFData Recipient where+  rnf (Pid p) = rnf p `seq` ()+  rnf (Registered s) = rnf s `seq` ()+  rnf (RemoteRegistered s n) = rnf s `seq` rnf n `seq` ()++instance Resolvable Recipient where+  resolve (Pid                p) = return (Just p)+  resolve (Registered         n) = whereis n+  resolve (RemoteRegistered s n) = whereisRemote n s++  unresolvableMessage (Pid                p) = unresolvableMessage p+  unresolvableMessage (Registered         n) = unresolvableMessage n+  unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s)++-- although we have an instance of Routable for Resolvable, it really+-- makes no sense to do remote lookups on a pid, only to then send to it!+instance Routable Recipient where++  sendTo (Pid p)                m = P.send p m+  sendTo (Registered s)         m = nsend s m+  sendTo (RemoteRegistered s n) m = nsendRemote n s m++  unsafeSendTo (Pid p)                m = P.unsafeSend p $!! m+  unsafeSendTo (Registered s)         m = P.unsafeNSend s $!! m+  unsafeSendTo (RemoteRegistered s n) m = nsendRemote n s m++-- useful exit reasons++-- | Given when a server is unobtainable.+data ServerDisconnected = ServerDisconnected !DiedReason+  deriving (Typeable, Generic)+instance Binary ServerDisconnected where+instance NFData ServerDisconnected where

@@ -4,9 +4,8 @@ {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstrainedClassMethods #-}  ----------------------------------------------------------------------------- -- |@@ -44,7 +43,7 @@   , LogFormat   , LogClient   , LogChan-  , LogText(..)+  , LogText   , ToLog(..)   , Logger(..)     -- * Mx Agent Configuration / Startup@@ -69,7 +68,7 @@   ) where  import Control.DeepSeq (NFData(..))-import Control.Distributed.Process+import Control.Distributed.Process hiding (catch) import Control.Distributed.Process.Management   ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser)   , MxAgentId(..)@@ -86,9 +85,12 @@ import Control.Distributed.Process.Extras   ( Resolvable(..)   , Routable(..)+  , Addressable+  , NFSerializable   ) import Control.Distributed.Process.Serializable import Control.Exception (SomeException)+import Control.Monad.Catch (catch) import Data.Accessor   ( Accessor   , accessor@@ -156,25 +158,27 @@  type LogFormat = String -> Process String -type LogChan = ()+type LogChanT = ()++newtype LogChan = LogChan LogChanT instance Routable LogChan where   sendTo       _ = mxNotify   unsafeSendTo _ = mxNotify -data LogText = LogText { txt :: !String }+type LogText = String+instance NFSerializable LogText  newtype LogClient = LogClient { agent :: ProcessId } instance Resolvable LogClient where   resolve = return . Just . agent+instance Routable LogClient  class ToLog m where-  toLog :: m -> Process (LogLevel -> LogMessage)+  toLog :: (Serializable m) => m -> Process (LogLevel -> LogMessage)+  toLog = return . LogData . unsafeWrapMessage  instance ToLog LogText where-  toLog = return . LogMessage . txt--instance (Serializable a) => ToLog a where-  toLog = return . LogData . unsafeWrapMessage+  toLog = return . LogMessage  instance ToLog Message where   toLog = return . LogData@@ -195,46 +199,46 @@ mxLogId = MxAgentId logProcessName  logChannel :: LogChan-logChannel = ()+logChannel = LogChan ()  report :: (Logger l)        => (l -> LogText -> Process ())        -> l        -> String        -> Process ()-report f l = f l . LogText+report f l = f l   client :: Process (Maybe LogClient) client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient) -debug :: (Logger l, ToLog m) => l -> m -> Process ()+debug :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () debug l m = sendLog l m Debug -info :: (Logger l, ToLog m) => l -> m -> Process ()+info :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () info l m = sendLog l m Info -notice :: (Logger l, ToLog m) => l -> m -> Process ()+notice :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () notice l m = sendLog l m Notice -warning :: (Logger l, ToLog m) => l -> m -> Process ()+warning :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () warning l m = sendLog l m Warning -error :: (Logger l, ToLog m) => l -> m -> Process ()+error :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () error l m = sendLog l m Error -critical :: (Logger l, ToLog m) => l -> m -> Process ()+critical :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () critical l m = sendLog l m Critical -alert :: (Logger l, ToLog m) => l -> m -> Process ()+alert :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () alert l m = sendLog l m Alert -emergency :: (Logger l, ToLog m) => l -> m -> Process ()+emergency :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () emergency l m = sendLog l m Emergency -sendLog :: (Logger l, ToLog m) => l -> m -> LogLevel -> Process ()+sendLog :: (Logger l, Serializable m, ToLog m) => l -> m -> LogLevel -> Process () sendLog a m lv = toLog m >>= \m' -> logMessage a $ m' lv -addFormatter :: (Routable r)+addFormatter :: (Addressable r)              => r              -> Closure (Message -> Process (Maybe String))              -> Process ()

@@ -155,7 +155,7 @@  {-# INLINE hoursPerDay #-} hoursPerDay :: Int-hoursPerDay = 60+hoursPerDay = 24  {-# INLINE minutesPerHour #-} minutesPerHour :: Int

@@ -36,7 +36,7 @@   , flushTimer   ) where -import Control.DeepSeq (NFData)+import Control.DeepSeq (NFData(..)) import Control.Distributed.Process hiding (send) import Control.Distributed.Process.Serializable import Control.Distributed.Process.Extras.UnsafePrimitives (send)@@ -56,12 +56,16 @@     deriving (Typeable, Generic, Eq, Show) 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     deriving (Typeable, Generic, Eq, Show) instance Binary Tick where instance NFData Tick where+  rnf t = t `seq` ()+instance NFSerializable Tick  data SleepingPill = SleepingPill     deriving (Typeable, Generic, Eq, Show)

@@ -13,7 +13,7 @@ import Control.Distributed.Process.Extras hiding (__remoteTable) import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger, error) import Control.Distributed.Process.Extras.SystemLog hiding (Logger, error)-import Control.Distributed.Process.Tests.Internal.Utils+import Control.Distributed.Process.SysTest.Utils import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer import Control.Monad (void)@@ -59,7 +59,7 @@   where     writeLog chan = liftIO . atomically . writeTChan chan -testLogLevels :: (Log.Logger logger, ToLog tL)+testLogLevels :: (Log.Logger logger, NFSerializable tL, ToLog tL)               => MVar ()               -> TChan String               -> logger@@ -126,7 +126,7 @@       testCase l (delayedAssertion ("Expected up to " ++ l)                   ln True $ testLogLevels lck chan ch' Debug lvl rdr) -    simpleShowToLog = (LogText . show)+    simpleShowToLog = show     messageToLog    = unsafeWrapMessage . show     messageRaw      = unsafeWrapMessage 

@@ -27,7 +27,7 @@ import Test.Framework.Providers.HUnit (testCase) import Network.Transport.TCP import qualified Network.Transport as NT-import Control.Distributed.Process.Tests.Internal.Utils+import Control.Distributed.Process.SysTest.Utils  testLinkingWithNormalExits :: TestResult DiedReason -> Process () testLinkingWithNormalExits result = do

@@ -47,8 +47,8 @@       Just (a', q2) = FIFO.dequeue q1       Just (b', q3) = FIFO.dequeue q2       Just (c', q4) = FIFO.dequeue q3-      Nothing       = FIFO.dequeue q4-  in q4 `seq` [a',b',c'] == [a,b,c]  -- why seq here? to shut the compiler up.+      d             = FIFO.dequeue q4+  in (d == Nothing) && (q4 `seq` [a',b',c'] == [a,b,c])  -- why seq here? to shut the compiler up.  prop_enqueue_empty :: String -> Bool prop_enqueue_empty s =

@@ -16,9 +16,10 @@ 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.Tests.Internal.Utils+import Control.Distributed.Process.SysTest.Utils  import Test.Framework (Test, testGroup, defaultMain) import Test.Framework.Providers.HUnit (testCase)@@ -29,6 +30,7 @@  -- orphan instance instance NFData Ping where+instance NFSerializable Ping  testSendAfter :: TestResult Bool -> Process () testSendAfter result =@@ -63,8 +65,8 @@   let delay = milliSeconds 50   pid <- periodically delay noop   ref <- monitor pid--  sleep $ seconds 1+  _ <- getProcessInfo pid+     cancelTimer pid    _ <- receiveWait [