[commit: base] master: Add traceStack :: String -> a -> a (41bf1ae)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/41bf1ae71a791e800260f901dcc5b298d9671b2f

>---------------------------------------------------------------

commit 41bf1ae71a791e800260f901dcc5b298d9671b2f
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Wed Nov 30 10:37:40 2011 +0000

    Add traceStack :: String -> a -> a
    
    -- | like 'trace', but additionally prints a call stack if one is
    -- available.
    --
    -- In the current GHC implementation, the call stack is only
    -- availble if the program was compiled with @-prof@; otherwise
    -- 'traceStack' behaves exactly like 'trace'.  Entries in the call
    -- stack correspond to @SCC@ annotations, so it is a good idea to use
    -- @-fprof-auto@ to add SCC annotations automatically.

>---------------------------------------------------------------

 Debug/Trace.hs |   19 +++++++++++++++++++
 1 files changed, 19 insertions(+), 0 deletions(-)

diff --git a/Debug/Trace.hs b/Debug/Trace.hs
index b843629..706d077 100644
--- a/Debug/Trace.hs
+++ b/Debug/Trace.hs
@@ -23,6 +23,7 @@ module Debug.Trace (
         -- $tracing
         trace,            -- :: String -> a -> a
         traceShow,
+        traceStack,
         traceIO,          -- :: String -> IO ()
         putTraceMsg,
 
@@ -34,10 +35,12 @@ module Debug.Trace (
 
 import Prelude
 import System.IO.Unsafe
+import Control.Monad
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign.C.String
 import qualified GHC.Exts as GHC
+import GHC.Stack
 #else
 import System.IO (hPutStrLn,stderr)
 #endif
@@ -155,3 +158,19 @@ traceEventIO = GHC.traceEventIO
 #else
 traceEventIO msg = (return $! length msg) >> return ()
 #endif
+
+-- | like 'trace', but additionally prints a call stack if one is
+-- available.
+--
+-- In the current GHC implementation, the call stack is only
+-- availble if the program was compiled with @-prof@; otherwise
+-- 'traceStack' behaves exactly like 'trace'.  Entries in the call
+-- stack correspond to @SCC@ annotations, so it is a good idea to use
+-- @-fprof-auto@ to add SCC annotations automatically.
+--
+traceStack :: String -> a -> a
+traceStack str expr = unsafePerformIO $ do
+   traceIO str
+   stack <- currentCallStack
+   when (not (null stack)) $ traceIO (renderStack stack)
+   return expr