Don't infer CallStacks

We originally wanted CallStacks to be opt-in, but dealing with let
binders complicated things, forcing us to infer CallStacks. It turns
out that the inference is actually unnecessary though, we can let the
wanted CallStacks bubble up to the outer context by refusing to
quantify over them. Eventually they'll be solved from a given CallStack
or defaulted to the empty CallStack if they reach the top.

So this patch prevents GHC from quantifying over CallStacks, getting us
back to the original plan. There's a small ugliness to do with
PartialTypeSignatures, if the partial theta contains a CallStack
constraint, we *do* want to quantify over the CallStack; the user asked
us to!

Note that this means that

  foo :: _ => CallStack
  foo = getCallStack callStack

will be an *empty* CallStack, since we won't infer a CallStack for the
hole in the theta. I think this is the right move though, since we want
CallStacks to be opt-in. One can always write

  foo :: (HasCallStack, _) => CallStack
  foo = getCallStack callStack

to get the CallStack and still have GHC infer the rest of the theta.

Test Plan: ./validate

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj, bgamari

Subscribers: bitemyapp, thomie

Projects: #ghc

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

GHC Trac Issues: #11573

2 files changed, 11 insertions, 11 deletions

diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index 5f2034e2d2..f5b175c0bb 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -74,9 +74,9 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do
 -- @since 4.9.0.0
 popCallStack :: CallStack -> CallStack
 popCallStack stk = case stk of
-  EmptyCallStack       -> errorWithoutStackTrace "popCallStack: empty stack"
-  PushCallStack _ stk' -> stk'
-  FreezeCallStack _    -> stk
+  EmptyCallStack         -> errorWithoutStackTrace "popCallStack: empty stack"
+  PushCallStack _ _ stk' -> stk'
+  FreezeCallStack _      -> stk
 {-# INLINE popCallStack #-}
 
 -- | Return the current 'CallStack'.
diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs
index 1fead13051..33b24a4af6 100644
--- a/libraries/base/GHC/Stack/Types.hs
+++ b/libraries/base/GHC/Stack/Types.hs
@@ -131,7 +131,7 @@ type HasCallStack = (?callStack :: CallStack)
 -- @since 4.8.1.0
 data CallStack
   = EmptyCallStack
-  | PushCallStack ([Char], SrcLoc) CallStack
+  | PushCallStack [Char] SrcLoc CallStack
   | FreezeCallStack CallStack
     -- ^ Freeze the stack at the given @CallStack@, preventing any further
     -- call-sites from being pushed onto it.
@@ -145,16 +145,16 @@ data CallStack
 -- @since 4.8.1.0
 getCallStack :: CallStack -> [([Char], SrcLoc)]
 getCallStack stk = case stk of
-  EmptyCallStack        -> []
-  PushCallStack cs stk' -> cs : getCallStack stk'
-  FreezeCallStack stk'  -> getCallStack stk'
+  EmptyCallStack            -> []
+  PushCallStack fn loc stk' -> (fn,loc) : getCallStack stk'
+  FreezeCallStack stk'      -> getCallStack stk'
 
 -- | Convert a list of call-sites to a 'CallStack'.
 --
 -- @since 4.9.0.0
 fromCallSiteList :: [([Char], SrcLoc)] -> CallStack
-fromCallSiteList (c:cs) = PushCallStack c (fromCallSiteList cs)
-fromCallSiteList []     = EmptyCallStack
+fromCallSiteList ((fn,loc):cs) = PushCallStack fn loc (fromCallSiteList cs)
+fromCallSiteList []            = EmptyCallStack
 
 -- Note [Definition of CallStack]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -178,9 +178,9 @@ fromCallSiteList []     = EmptyCallStack
 --
 -- @since 4.9.0.0
 pushCallStack :: ([Char], SrcLoc) -> CallStack -> CallStack
-pushCallStack cs stk = case stk of
+pushCallStack (fn, loc) stk = case stk of
   FreezeCallStack _ -> stk
-  _                 -> PushCallStack cs stk
+  _                 -> PushCallStack fn loc stk
 {-# INLINE pushCallStack #-}