X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Debug%2FTrace.hs;h=ebacb6c3d7fa28d37e385a2d240c97b2bd4d8d78;hb=HEAD;hp=00af949724e5343f691156bf0362c64cfa7e978a;hpb=74f9531c9030985a0adcec184f562218dd8aab7c;p=ghc-base.git diff --git a/Debug/Trace.hs b/Debug/Trace.hs index 00af949..ebacb6c 100644 --- a/Debug/Trace.hs +++ b/Debug/Trace.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : Debug.Trace @@ -12,89 +14,59 @@ -- ----------------------------------------------------------------------------- -#ifndef __HUGS__ -#include "config.h" -#endif - module Debug.Trace ( - -- * Tracing - - -- ** 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 + -- * Tracing + putTraceMsg, -- :: String -> IO () + trace, -- :: String -> a -> a + traceShow ) where import Prelude -import Data.IORef import System.IO.Unsafe -import System.IO -#ifdef mingw32_TARGET_OS +#ifdef __GLASGOW_HASKELL__ import Foreign.C.String +#else +import System.IO (hPutStrLn,stderr) #endif -{-# 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. +-- Usually the output stream is 'System.IO.stderr' but if the function is called +-- from Windows GUI application then the output will be directed to the Windows +-- debug console. putTraceMsg :: String -> IO () putTraceMsg msg = do - ts <- readIORef tracers - mapM_ (\(n,l) -> l msg) ts +#ifndef __GLASGOW_HASKELL__ + hPutStrLn stderr msg +#else + withCString "%s\n" $ \cfmt -> + withCString msg $ \cmsg -> + debugBelch cfmt cmsg + +-- don't use debugBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h debugBelch2" + debugBelch :: CString -> CString -> IO () +#endif {-# NOINLINE trace #-} {-| -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 -indicate that you\'re tracing. +When called, 'trace' outputs the string in its first argument, 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 indicate that you\'re tracing. The function is implemented on +top of 'putTraceMsg'. -} trace :: String -> a -> a trace string expr = unsafePerformIO $ do putTraceMsg string return expr + +{-| +Like 'trace', but uses 'show' on the argument to convert it to a 'String'. + +> traceShow = trace . show +-} +traceShow :: (Show a) => a -> b -> b +traceShow = trace . show