[project @ 2004-02-15 13:04:47 by krasimir]

Added support for tracers

diff --git a/Debug/Trace.hs b/Debug/Trace.hs
index 79d44c7..e5905b1 100644 (file)
--- a/Debug/Trace.hs
+++ b/Debug/Trace.hs
@@ -12,9 +12,25 @@
 --
 -----------------------------------------------------------------------------
 
+#ifndef __HUGS__
+#include "config.h"
+#endif
+
 module Debug.Trace (
        -- * Tracing
-       trace -- :: String -> a -> a
+       
+       -- ** Tracers
+       -- | The tracer is a function that monitors the trace messages.
+       fileTracer,       -- :: Handle -> String -> IO ()
+#ifdef mingw32_TARGET_OS
+       winDebugTracer,   -- :: String -> IO ()
+#endif
+       addTracer,        -- :: String -> (String -> IO ()) -> IO ()
+       removeTracer,     -- :: String -> IO ()
+       
+       -- ** Messages
+       putTraceMsg,      -- :: String -> IO ()
+       trace             -- :: String -> a -> a
   ) where
 
 import Prelude
@@ -26,10 +42,55 @@ import GHC.IOBase
 import GHC.Handle
 #endif
 
+import Foreign.C.String
+
+{-# NOINLINE tracers #-}
+tracers :: IORef [(String, String -> IO ())]
+tracers = unsafePerformIO (newIORef [("defaultTracer", fileTracer stderr)])
+
+-- | A tracer function that outputs the message to a file
+fileTracer :: Handle     -- ^ file handle
+           -> String     -- ^ trace message
+           -> IO ()
+fileTracer handle msg = do
+   hPutStr handle msg
+   hPutChar handle '\n'
+
+#ifdef mingw32_TARGET_OS
+-- | A tracer function that outputs the message to the debuger (Windows only)
+winDebugTracer :: String  -- ^ trace message
+               -> IO ()
+winDebugTracer msg = do
+   withCString (msg++"\n") outputDebugString
+
+foreign import ccall unsafe "OutputDebugStringA"
+  outputDebugString :: CString -> IO ()
+#endif
+
+-- | Registering a new tracer
+addTracer :: String             -- ^ the tracer name
+          -> (String -> IO ())  -- ^ tracer
+          -> IO ()
+addTracer name tracer = do
+       ts <- readIORef tracers
+       writeIORef tracers ((name,tracer):filter (\(n,l) -> n /= name) ts)
+
+-- | Removing the tracer with the given name
+removeTracer :: String -> IO ()
+removeTracer name = do
+       ts <- readIORef tracers
+       writeIORef tracers (filter (\(n,l) -> n /= name) ts)
+
+-- | 'putTraceMsg' function outputs the trace message from IO monad.
+putTraceMsg :: String -> IO ()
+putTraceMsg msg = do
+       ts <- readIORef tracers
+       mapM_ (\(n,l) -> l msg) ts
+
 {-# NOINLINE trace #-}
 {-|
-When called, 'trace' prints the string in its first argument to
-standard error, before returning the second argument as its result.
+When called, 'trace' outputs the string in its first argument using the
+installed tracers, before returning the second argument as its result.
 The 'trace' function is not referentially transparent, and should only
 be used for debugging, or for monitoring execution. Some
 implementations of 'trace' may decorate the string that\'s output to
@@ -37,14 +98,5 @@ indicate that you\'re tracing.
 -}
 trace :: String -> a -> a
 trace string expr = unsafePerformIO $ do
-    hPutStr stderr string
-    hPutChar stderr '\n'
-#ifdef __GLASGOW_HASKELL__
-    fd <- withHandle_ "trace" stderr $ (return.haFD)
-    postTraceHook fd
-#endif
+    putTraceMsg string
     return expr
-
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall "PostTraceHook" postTraceHook :: Int -> IO ()
-#endif