From 84f8e86248d47f619a94c68260876a1258e0a931 Mon Sep 17 00:00:00 2001
From: Ben Gamari <bgamari.foss@gmail.com>
Date: Fri, 28 Jul 2017 18:25:35 -0400
Subject: [PATCH] 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
---
 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 f5b175c0bb..1f102c9f9b 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 75575e0d16..964728934e 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
-- 
GitLab