[commit: base] master: add errorWithStackTrace (e1d28c1)

[Simon Marlow]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/e1d28c19f7a6b3a9f0e3584f0315b4b2c5235de6

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

commit e1d28c19f7a6b3a9f0e3584f0315b4b2c5235de6
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Aug 9 09:10:32 2012 +0100

    add errorWithStackTrace
    
    -- | Like the function 'error', but appends a stack trace to the error
    -- message if one is available.
    errorWithStackTrace :: String -> a

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

 GHC/Stack.hsc |   11 +++++++++++
 1 files changed, 11 insertions(+), 0 deletions(-)

diff --git a/GHC/Stack.hsc b/GHC/Stack.hsc
index 80e4c9f..849a48c 100644
--- a/GHC/Stack.hsc
+++ b/GHC/Stack.hsc
@@ -17,6 +17,7 @@ module GHC.Stack (
     -- * Call stack
     currentCallStack,
     whoCreated,
+    errorWithStackTrace,
 
     -- * Internals
     CostCentreStack,
@@ -40,6 +41,7 @@ import GHC.Base
 import GHC.Ptr
 import GHC.Foreign as GHC
 import GHC.IO.Encoding
+import GHC.Exception
 
 #define PROFILING
 #include "Rts.h"
@@ -106,3 +108,12 @@ whoCreated obj = do
 
 renderStack :: [String] -> String
 renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)
+
+-- | Like the function 'error', but appends a stack trace to the error
+-- message if one is available.
+errorWithStackTrace :: String -> a
+errorWithStackTrace x = unsafeDupablePerformIO $ do
+   stack <- ccsToStrings =<< getCurrentCCS x
+   if null stack
+      then throwIO (ErrorCall x)
+      else throwIO (ErrorCall (x ++ '\n' : renderStack stack))