@@ -79,6 +79,7 @@ module Control.Distributed.Process.Internal.Primitives
7979 , withMonitor
8080 , withMonitor_
8181 -- * Logging
82+ , SayMessage(..)
8283 , say
8384 -- * Registry
8485 , register
@@ -126,8 +127,9 @@ module Control.Distributed.Process.Internal.Primitives
126127import Prelude hiding (catch)
127128#endif
128129
129−import Data.Binary (decode)
130−import Data.Time.Clock (getCurrentTime)
130+import Data.Binary (Binary(..), Put, Get, decode)
131+import Data.Time.Clock (getCurrentTime, UTCTime(..))
132+import Data.Time.Calendar (Day(..))
131133import Data.Time.Format (formatTime)
132134#if MIN_VERSION_time(1,5,0)
133135import Data.Time.Format (defaultTimeLocale)
@@ -1077,17 +1079,52 @@ unlinkPortAsync (SendPort cid) =
10771079-- Logging --
10781080--------------------------------------------------------------------------------
10791081
1082+data SayMessage = SayMessage { sayTime :: UTCTime
1083+ , sayProcess :: ProcessId
1084+ , sayMessage :: String }
1085+ deriving (Typeable)
1086+
1087+-- There is sadly no Show UTCTime instance
1088+instance Show SayMessage where
1089+ showsPrec p msg =
1090+ showParen (p >= 11)
1091+ $ showString "SayMessage "
1092+ . showString (formatTime defaultTimeLocale "%c" (sayTime msg))
1093+ . showChar ' '
1094+ . showsPrec 11 (sayProcess msg) . showChar ' '
1095+ . showsPrec 11 (sayMessage msg) . showChar ' '
1096+
1097+instance Binary SayMessage where
1098+ put s = do
1099+ putUTCTime (sayTime s)
1100+ put (sayProcess s)
1101+ put (sayMessage s)
1102+ get = SayMessage <$> getUTCTime <*> get <*> get
1103+
1104+-- Sadly there is no Binary UTCTime instance
1105+putUTCTime :: UTCTime -> Put
1106+putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do
1107+ put day
1108+ put (toRational tod)
1109+
1110+getUTCTime :: Get UTCTime
1111+getUTCTime = do
1112+ day <- get
1113+ tod <- get
1114+ return $! UTCTime (ModifiedJulianDay day)
1115+ (fromRational tod)
1116+
10801117-- | Log a string
10811118--
1082−-- @say message@ sends a message (time, pid of the current process, message)
1083−-- to the process registered as 'logger'. By default, this process simply
1084−-- sends the string to 'stderr'. Individual Cloud Haskell backends might
1085−-- replace this with a different logger process, however.
1119+-- @say message@ sends a message of type 'SayMessage' with the current time and
1120+-- 'ProcessId' of the current process to the process registered as @logger@. By
1121+-- default, this process simply sends the string to @stderr@. Individual Cloud
1122+-- Haskell backends might replace this with a different logger process, however.
10861123say :: String -> Process ()
10871124say string = do
10881125 now <- liftIO getCurrentTime
10891126 us <- getSelfPid
1090− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)
1127+ nsend "logger" (SayMessage now us string)
10911128
10921129--------------------------------------------------------------------------------
10931130-- Registry --