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

4 files changed, 5 insertions, 5 deletions

diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index 7bdb97cebd..6c340e4597 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -248,7 +248,7 @@ gather (R m)
   gath _ Fail         = Fail
   gath l (Look f)     = Look (\s -> gath l (f s))
   gath l (Result k p) = k (l []) <|> gath l p
-  gath _ (Final _)    = error "do not use readS_to_P in gather!"
+  gath _ (Final _)    = errorWithoutStackTrace "do not use readS_to_P in gather!"
 
 -- ---------------------------------------------------------------------------
 -- Derived operations
diff --git a/libraries/base/Text/Printf.hs b/libraries/base/Text/Printf.hs
index 2ccbc11c2f..4d12e561c7 100644
--- a/libraries/base/Text/Printf.hs
+++ b/libraries/base/Text/Printf.hs
@@ -871,7 +871,7 @@ dfmt c p a d =
 --
 -- @since 4.7.0.0
 perror :: String -> a
-perror s = error $ "printf: " ++ s
+perror s = errorWithoutStackTrace $ "printf: " ++ s
 
 -- | Calls 'perror' to indicate an unknown format letter for
 -- a given type.
diff --git a/libraries/base/Text/Read.hs b/libraries/base/Text/Read.hs
index 0e752c2bbb..2479eb529a 100644
--- a/libraries/base/Text/Read.hs
+++ b/libraries/base/Text/Read.hs
@@ -87,4 +87,4 @@ readMaybe s = case readEither s of
 -- | The 'read' function reads input from a string, which must be
 -- completely consumed by the input process.
 read :: Read a => String -> a
-read s = either error id (readEither s)
+read s = either errorWithoutStackTrace id (readEither s)
diff --git a/libraries/base/Text/Read/Lex.hs b/libraries/base/Text/Read/Lex.hs
index 608bf85de4..ed4d204c86 100644
--- a/libraries/base/Text/Read/Lex.hs
+++ b/libraries/base/Text/Read/Lex.hs
@@ -504,7 +504,7 @@ valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0
       where
         d = d1 * b + d2
     combine _ []  = []
-    combine _ [_] = error "this should not happen"
+    combine _ [_] = errorWithoutStackTrace "this should not happen"
 
 -- Calculate a Rational from the exponent [of 10 to multiply with],
 -- the integral part of the mantissa and the digits of the fractional
@@ -536,7 +536,7 @@ valDig 16 c
   | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
   | otherwise            = Nothing
 
-valDig _ _ = error "valDig: Bad base"
+valDig _ _ = errorWithoutStackTrace "valDig: Bad base"
 
 valDecDig :: Char -> Maybe Int
 valDecDig c