Allow CallStacks to be frozen

This introduces "freezing," an operation which prevents further
locations from being appended to a CallStack.  Library authors may want
to prevent CallStacks from exposing implementation details, as a matter
of hygiene. For example, in

```
head [] = error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

including the call-site of `error` in `head` is not strictly necessary
as the error message already specifies clearly where the error came
from.

So we add a function `freezeCallStack` that wraps an existing CallStack,
preventing further call-sites from being pushed onto it. In other words,

```
pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack
```

Now we can define `head` to not produce a CallStack at all

```
head [] =
  let ?callStack = freezeCallStack emptyCallStack
  in error "head: empty list"

ghci> head []
*** Exception: head: empty list
CallStack (from implicit params):
  error, called at ...
```

---

1. We add the `freezeCallStack` and `emptyCallStack` and update the
   definition of `CallStack` to support this functionality.

2. We add `errorWithoutStackTrace`, a variant of `error` that does not
   produce a stack trace, using this feature. I think this is a sensible
   wrapper function to provide in case users want it.

3. We replace uses of `error` in base with `errorWithoutStackTrace`. The
   rationale is that base does not export any functions that use CallStacks
   (except for `error` and `undefined`) so there's no way for the stack
   traces (from Implicit CallStacks) to include user-defined functions.
   They'll only contain the call to `error` itself. As base already has a
   good habit of providing useful error messages that name the triggering
   function, the stack trace really just adds noise to the error. (I don't
   have a strong opinion on whether we should include this third commit,
   but the change was very mechanical so I thought I'd include it anyway in
   case there's interest)

4. Updates tests in `array` and `stm` submodules

Test Plan: ./validate, new test is T11049

Reviewers: simonpj, nomeata, goldfire, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1628

GHC Trac Issues: #11049

14 files changed, 24 insertions, 18 deletions

diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index e8cb351fcc..6b943590f6 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1613,3 +1613,4 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
 /timeout/calibrate.out
 /timeout/dist/
 /timeout/install-inplace/
+/tests/typecheck/should_run/T11049
diff --git a/testsuite/tests/array/should_run/arr003.stderr b/testsuite/tests/array/should_run/arr003.stderr
index a0d56ed0a6..8f3945286b 100644
--- a/testsuite/tests/array/should_run/arr003.stderr
+++ b/testsuite/tests/array/should_run/arr003.stderr
@@ -1,3 +1 @@
 arr003: Ix{Int}.index: Index (4) out of range ((1,3))
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/Arr.hs:176:5 in base:GHC.Arr
diff --git a/testsuite/tests/array/should_run/arr004.stderr b/testsuite/tests/array/should_run/arr004.stderr
index e109855a71..b69cbf5b62 100644
--- a/testsuite/tests/array/should_run/arr004.stderr
+++ b/testsuite/tests/array/should_run/arr004.stderr
@@ -1,3 +1 @@
 arr004: (Array.!): undefined array element
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/Arr.hs:402:16 in base:GHC.Arr
diff --git a/testsuite/tests/array/should_run/arr007.stderr b/testsuite/tests/array/should_run/arr007.stderr
index 4c02cecf6e..feaa5d8363 100644
--- a/testsuite/tests/array/should_run/arr007.stderr
+++ b/testsuite/tests/array/should_run/arr007.stderr
@@ -1,3 +1 @@
 arr007: Ix{Int}.index: Index (1) out of range ((1,0))
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/Arr.hs:176:5 in base:GHC.Arr
diff --git a/testsuite/tests/array/should_run/arr008.stderr b/testsuite/tests/array/should_run/arr008.stderr
index 5355a07162..f926f7288c 100644
--- a/testsuite/tests/array/should_run/arr008.stderr
+++ b/testsuite/tests/array/should_run/arr008.stderr
@@ -1,3 +1 @@
 arr008: Ix{Int}.index: Index (2) out of range ((0,1))
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/Arr.hs:176:5 in base:GHC.Arr
diff --git a/testsuite/tests/ffi/should_run/fptrfail01.stderr b/testsuite/tests/ffi/should_run/fptrfail01.stderr
index cf29208275..db50b2e01b 100644
--- a/testsuite/tests/ffi/should_run/fptrfail01.stderr
+++ b/testsuite/tests/ffi/should_run/fptrfail01.stderr
@@ -1,3 +1 @@
 fptrfail01: GHC.ForeignPtr: attempt to mix Haskell and C finalizers in the same ForeignPtr
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/ForeignPtr.hs:361:17 in base:GHC.ForeignPtr
diff --git a/testsuite/tests/ghci.debugger/scripts/break009.stdout b/testsuite/tests/ghci.debugger/scripts/break009.stdout
index 49515cf98f..d7f2d65ab5 100644
--- a/testsuite/tests/ghci.debugger/scripts/break009.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break009.stdout
@@ -2,5 +2,3 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11
 Stopped in Main.main, ../Test6.hs:5:8-11
 _result :: a2 = _
 *** Exception: Prelude.head: empty list
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/List.hs:999:3 in base:GHC.List
diff --git a/testsuite/tests/ghci/scripts/T10501.stderr b/testsuite/tests/ghci/scripts/T10501.stderr
index 7fffbe8231..65d24a08ca 100644
--- a/testsuite/tests/ghci/scripts/T10501.stderr
+++ b/testsuite/tests/ghci/scripts/T10501.stderr
@@ -1,7 +1,5 @@
 *** Exception: Prelude.head: empty list
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/List.hs:999:3 in base:GHC.List
 *** Exception: Prelude.undefined
 CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err
+  error, called at libraries/base/GHC/Err.hs:50:14 in base:GHC.Err
   undefined, called at <interactive>:1:17 in interactive:Ghci1
diff --git a/testsuite/tests/simplCore/should_compile/EvalTest.stdout b/testsuite/tests/simplCore/should_compile/EvalTest.stdout
index b536c541c0..8bc22a42f2 100644
--- a/testsuite/tests/simplCore/should_compile/EvalTest.stdout
+++ b/testsuite/tests/simplCore/should_compile/EvalTest.stdout
@@ -1 +1 @@
-rght [Dmd=<S,U>] :: AList a
+rght [Dmd=<S,U>] :: AList a1
diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr
index b4d5b8df84..8cf8d452ce 100644
--- a/testsuite/tests/th/TH_exn2.stderr
+++ b/testsuite/tests/th/TH_exn2.stderr
@@ -2,7 +2,5 @@
 TH_exn2.hs:1:1: error:
     Exception when trying to run compile-time code:
       Prelude.tail: empty list
-CallStack (from ImplicitParams):
-  error, called at libraries/base/GHC/List.hs:999:3 in base:GHC.List
     Code: do { ds <- [d| |];
                return (tail ds) }
diff --git a/testsuite/tests/typecheck/should_run/T11049.hs b/testsuite/tests/typecheck/should_run/T11049.hs
new file mode 100644
index 0000000000..bc389d7315
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T11049.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE ImplicitParams, RankNTypes #-}
+import GHC.Stack
+
+foo :: (?callStack :: CallStack) => [Int]
+foo = map (srcLocStartLine . snd) (getCallStack ?callStack)
+
+bar1 :: [Int]
+bar1 = foo
+
+bar2 :: [Int]
+bar2 = let ?callStack = freezeCallStack ?callStack in foo
+
+main :: IO ()
+main = do
+  print bar1
+  print bar2
+  withFrozenCallStack (error "look ma, no stack!")
diff --git a/testsuite/tests/typecheck/should_run/T11049.stderr b/testsuite/tests/typecheck/should_run/T11049.stderr
new file mode 100644
index 0000000000..ed264c6174
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T11049.stderr
@@ -0,0 +1 @@
+T11049: look ma, no stack!
diff --git a/testsuite/tests/typecheck/should_run/T11049.stdout b/testsuite/tests/typecheck/should_run/T11049.stdout
new file mode 100644
index 0000000000..96e1119831
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T11049.stdout
@@ -0,0 +1,2 @@
+[8]
+[]
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 1c4f234d19..138ac58ecc 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -111,4 +111,5 @@ test('T9497c-run', [exit_code(1)], compile_and_run, ['-fdefer-type-errors -fno-w
 test('T9858c', normal, compile_and_run, [''])
 test('T9858d', normal, compile_and_run, [''])
 test('T10284', exit_code(1), compile_and_run, [''])
+test('T11049', exit_code(1), compile_and_run, [''])
 test('T11230', normal, compile_and_run, [''])