[commit: ghc] master: Ensure that GHC.Stack.callStack doesn't fail (84f8e86)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/84f8e86248d47f619a94c68260876a1258e0a931/ghc

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

commit 84f8e86248d47f619a94c68260876a1258e0a931
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Fri Jul 28 18:25:35 2017 -0400

    Ensure that GHC.Stack.callStack doesn't fail
    
    Test Plan: Validate, ensure the `f7` program of `IPLocation` doesn't
    crash.
    
    Reviewers: gridaphobe, austin, hvr
    
    Reviewed By: gridaphobe
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #14028
    
    Differential Revision: https://phabricator.haskell.org/D3795


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

84f8e86248d47f619a94c68260876a1258e0a931
 libraries/base/GHC/Stack.hs                        | 5 ++++-
 testsuite/tests/typecheck/should_run/IPLocation.hs | 6 ++++++
 2 files changed, 10 insertions(+), 1 deletion(-)

diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index f5b175c..1f102c9 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -85,7 +85,10 @@ popCallStack stk = case stk of
 --
 -- @since 4.9.0.0
 callStack :: HasCallStack => CallStack
-callStack = popCallStack ?callStack
+callStack =
+  case ?callStack of
+    EmptyCallStack -> EmptyCallStack
+    _              -> popCallStack ?callStack
 {-# INLINE callStack #-}
 
 -- | Perform some computation without adding new entries to the 'CallStack'.
diff --git a/testsuite/tests/typecheck/should_run/IPLocation.hs b/testsuite/tests/typecheck/should_run/IPLocation.hs
index 75575e0..9647289 100644
--- a/testsuite/tests/typecheck/should_run/IPLocation.hs
+++ b/testsuite/tests/typecheck/should_run/IPLocation.hs
@@ -29,9 +29,15 @@ f6 0 = putStrLn $ prettyCallStack ?loc
 f6 n = f6 (n-1)
        -- recursive functions add a SrcLoc for each recursive call
 
+f7 :: IO ()
+f7 = putStrLn (prettyCallStack $ id (\_ -> callStack) ())
+       -- shouldn't crash. See #14043.
+
+main :: IO ()
 main = do f0
           f1
           f3 (\ () -> putStrLn $ prettyCallStack ?loc)
           f4 (\ () -> putStrLn $ prettyCallStack ?loc)
           f5 (\ () -> putStrLn $ prettyCallStack ?loc3)
           f6 5
+          f7