Permalink
Browse files

provide a simple API for choosing debug/trace modes

  • Loading branch information...
hyperthunk committed Jan 24, 2013
1 parent 297458f commit ebd65bbc8595544787357b4df3bc39e770067e41
@@ -61,6 +61,7 @@ Library
Control.Distributed.Process.Internal.Primitives,
Control.Distributed.Process.Internal.CQueue,
Control.Distributed.Process.Internal.Types,
+ Control.Distributed.Process.Internal.Trace,
Control.Distributed.Process.Internal.Closure.BuiltIn,
Control.Distributed.Process.Internal.Messaging,
Control.Distributed.Process.Internal.StrictList,
@@ -145,7 +146,7 @@ Test-Suite TestStats
ScopedTypeVariables,
DeriveDataTypeable,
GeneralizedNewtypeDeriving
- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
+ ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
HS-Source-Dirs: tests
@@ -0,0 +1,53 @@
+
+module Control.Distributed.Process.Internal.Trace
+ ( Tracer
+ , trace -- :: String -> IO ()
+ , traceFormat -- :: (Show a) => (a -> a -> String) -> [a] -> IO ()
+ , eventlog
+ , console
+ ) where
+
+import Control.Concurrent
+ ( ThreadId
+ , forkIO
+ )
+import Control.Concurrent.STM
+ ( TQueue
+ , newTQueueIO
+ , readTQueue
+ , writeTQueue
+ , atomically
+ )
+import Data.List (foldl')
+import Debug.Trace
+ ( traceEventIO
+ )
+
+data Tracer =
+ ConsoleTracer ThreadId (TQueue String)
+ | EventLogTracer (String -> IO ())
+
+eventlog :: IO Tracer
+eventlog = return $ EventLogTracer traceEventIO
+
+console :: IO Tracer
+console = do
+ q <- newTQueueIO
+ tid <- forkIO $ logger q
+ return $ ConsoleTracer tid q
+ where logger q' = do
+ msg <- atomically $ readTQueue q'
+ putStrLn msg
+ logger q'
+
+trace :: Tracer -> String -> IO ()
+trace (ConsoleTracer _ q) msg = atomically $ writeTQueue q msg
+trace (EventLogTracer t) msg = t msg
+
+traceFormat :: (Show a)
+ => Tracer
+ -> (String -> String -> String)
+ -> [a]
+ -> IO ()
+traceFormat t f xs =
+ trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs
@@ -227,6 +227,9 @@ startServiceProcesses node = do
logEvent :: String -> IO ()
logEvent = traceEventIO
+logExit :: ProcessId -> DiedReason -> IO ()
+logExit p r = logEvent $ (show p) ++ " exited: " ++ (show r)
+
-- | Force-close a local node
--
-- TODO: for now we just close the associated endpoint
@@ -274,7 +277,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess
(return . DiedException . (show :: SomeException -> String))
-- [Issue #104]
- logEvent (show reason)
+ logExit pid reason
-- [Unified: Table 4, rules termination and exiting]
modifyMVar_ (localState node) (cleanupProcess pid)

0 comments on commit ebd65bb

Please sign in to comment.