Rework the Implicit CallStack solver to handle local lets.

We can't just solve CallStack constraints indiscriminately when they
occur in the RHS of a let-binder. The top-level given CallStack (if
any) will not be in scope, so I've re-worked the CallStack solver as
follows:

1. CallStacks are treated like regular IPs unless one of the following
   two rules apply.

2. In a function call, we push the call-site onto a NEW wanted
   CallStack, which GHC will solve as a regular IP (either directly from a
   given, or by quantifying over it in a local let).

3. If, after the constraint solver is done, any wanted CallStacks
   remain, we default them to the empty CallStack. This rule exists mainly
   to clean up after rule 2 in a top-level binder with no given CallStack.

In rule (2) we have to be careful to emit the new wanted with an
IPOccOrigin instead of an OccurrenceOf origin, so rule (2) doesn't fire
again. This is a bit shady but I've updated the Note to explain the
trick.

Test Plan: validate

Reviewers: simonpj, austin, bgamari, hvr

Reviewed By: simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #10845

1 files changed, 19 insertions, 21 deletions

diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index afd1a50f4a..80761ada75 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -27,9 +27,9 @@ module GHC.Exception
        , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
        , errorCallException, errorCallWithCallStackException
-       , showCallStack, popCallStack, showSrcLoc
          -- re-export CallStack and SrcLoc from GHC.Types
-       , CallStack(..), SrcLoc(..)
+       , CallStack, getCallStack, prettyCallStack
+       , SrcLoc(..), prettySrcLoc
        ) where
 
 import Data.Maybe
@@ -187,7 +187,7 @@ errorCallWithCallStackException :: String -> CallStack -> SomeException
 errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do
   ccsStack <- currentCallStack
   let
-    implicitParamCallStack = showCallStackLines (popCallStack stk)
+    implicitParamCallStack = prettyCallStackLines stk
     ccsCallStack = showCCSStack ccsStack
     stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
   return $ toException (ErrorCallWithLocation s stack)
@@ -196,11 +196,14 @@ showCCSStack :: [String] -> [String]
 showCCSStack [] = []
 showCCSStack stk = "CallStack (from -prof):" : map ("  " ++) (reverse stk)
 
+-- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot
+-- files. See Note [Definition of CallStack]
+
 -- | Pretty print 'SrcLoc'
 --
--- @since 4.9.0.0
-showSrcLoc :: SrcLoc -> String
-showSrcLoc SrcLoc {..}
+-- @since 4.8.1.0
+prettySrcLoc :: SrcLoc -> String
+prettySrcLoc SrcLoc {..}
   = foldr (++) ""
       [ srcLocFile, ":"
       , show srcLocStartLine, ":"
@@ -210,22 +213,17 @@ showSrcLoc SrcLoc {..}
 
 -- | Pretty print 'CallStack'
 --
--- @since 4.9.0.0
-showCallStack :: CallStack -> String
-showCallStack = intercalate "\n" . showCallStackLines
-
-showCallStackLines :: CallStack -> [String]
-showCallStackLines (CallStack stk) =
-    "CallStack (from ImplicitParams):" : map (("  " ++) . showCallSite) stk
+-- @since 4.8.1.0
+prettyCallStack :: CallStack -> String
+prettyCallStack = intercalate "\n" . prettyCallStackLines
+
+prettyCallStackLines :: CallStack -> [String]
+prettyCallStackLines cs = case getCallStack cs of
+  []  -> []
+  stk -> "CallStack (from ImplicitParams):"
+       : map (("  " ++) . prettyCallSite) stk
   where
-    showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
-
--- | Remove the most recent callsite from the 'CallStack'
---
--- @since 4.9.0.0
-popCallStack :: CallStack -> CallStack
-popCallStack (CallStack (_:rest)) = CallStack rest
-popCallStack _ = error "CallStack cannot be empty!"
+    prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc
 
 -- |Arithmetic exceptions.
 data ArithException