Make CallStacks work better with RebindableSyntax

As #19918 pointed out, the CallStack mechanism didn't work well with
RebindableSyntax.

This patch improves matters.  See GHC.Tc.Types.Evidence
     Note [Overview of implicit CallStacks]

* New predicate isPushCallStackOrigin distinguishes when a CallStack
  constraint should be solved "directly" or by pushing an item on the
  stack.

* The constructor EvCsPushCall now has a FastString, which can
  describe not only a function call site, but also things like
  "the literal 42" or "an if-then-else expression".

* I also fixed #20126 thus:
     exprCtOrigin (HsIf {}) = IfThenElseOrigin
  (Previously it was "can't happen".)

7 files changed, 111 insertions, 43 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 24b8247b32..011a527d53 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1050,13 +1050,15 @@ names 'getField' and 'setField' are whatever in-scope names they are.
 -}
 
 -- See Note [Rebindable syntax and HsExpansion] just above.
-data HsExpansion a b
-  = HsExpanded a b
+data HsExpansion orig expanded
+  = HsExpanded orig expanded
   deriving Data
 
 -- | Just print the original expression (the @a@).
 instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
-  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
+  ppr (HsExpanded orig expanded)
+    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+                 (ppr orig)
 
 
 {-
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index d04944661d..e898b74be5 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -185,10 +185,10 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn
         ; let r_ty = mkTyVarTy r_tv
         ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
                   (TcRnUnknownMessage $ mkPlainError noHints $ text "Predicate type of `ifThenElse' depends on result type")
-        ; (pred', fun')
-            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
-                                       (mkCheckExpType r_ty) $ \ _ _ ->
-               tcCheckMonoExpr pred pred_ty
+        ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun
+                              (map synKnownType [pred_ty, r_ty, r_ty])
+                              (mkCheckExpType r_ty) $ \ _ _ ->
+                           tcCheckMonoExpr pred pred_ty
 
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index a17b7f0204..162ef60cbc 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -153,7 +153,7 @@ canClassNC ev cls tys
 
   | isWanted ev
   , Just ip_name <- isCallStackPred cls tys
-  , OccurrenceOf func <- ctLocOrigin loc
+  , isPushCallStackOrigin orig
   -- If we're given a CallStack constraint that arose from a function
   -- call, we need to push the current call-site onto the stack instead
   -- of solving it directly from a given.
@@ -170,7 +170,8 @@ canClassNC ev cls tys
 
          -- Then we solve the wanted by pushing the call-site
          -- onto the newly emitted CallStack
-       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
+       ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
+                                  (ctLocSpan loc) (ctEvExpr new_ev)
        ; solveCallStack ev ev_cs
 
        ; canClass new_ev cls tys
@@ -184,6 +185,7 @@ canClassNC ev cls tys
   where
     has_scs cls = not (null (classSCTheta cls))
     loc  = ctEvLoc ev
+    orig = ctLocOrigin loc
     pred = ctEvPred ev
     fds  = classHasFds cls
 
diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs
index 0ff06e21c1..1636bbede4 100644
--- a/compiler/GHC/Tc/Solver/Types.hs
+++ b/compiler/GHC/Tc/Solver/Types.hs
@@ -138,7 +138,7 @@ findDict m loc cls tys
   = Nothing
 
   | Just {} <- isCallStackPred cls tys
-  , OccurrenceOf {} <- ctLocOrigin loc
+  , isPushCallStackOrigin (ctLocOrigin loc)
   = Nothing             -- See Note [Solving CallStack constraints]
 
   | otherwise
@@ -219,13 +219,15 @@ constraints, but it seemed more direct to deal with the lookup.
 
 Note [Solving CallStack constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.
+
 Suppose f :: HasCallStack => blah.  Then
 
 * Each call to 'f' gives rise to
     [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f
   with a CtOrigin that says "OccurrenceOf f".
   Remember that HasCallStack is just shorthand for
-    IP "callStack CallStack
+    IP "callStack" CallStack
   See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
 
 * We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by
@@ -239,7 +241,7 @@ Suppose f :: HasCallStack => blah.  Then
 
 So we must be careful /not/ to solve 's1' from the Givens.  Again,
 we ensure this by arranging that findDict always misses when looking
-up souch constraints.
+up such constraints.
 -}
 
 {- *********************************************************************
diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs
index ad380ec0a2..e55a930774 100644
--- a/compiler/GHC/Tc/Types/EvTerm.hs
+++ b/compiler/GHC/Tc/Types/EvTerm.hs
@@ -21,7 +21,6 @@ import GHC.Core.Make
 import GHC.Core.Utils
 
 import GHC.Types.SrcLoc
-import GHC.Types.Name
 import GHC.Types.TyThing
 
 -- Used with Opt_DeferTypeErrors
@@ -71,5 +70,5 @@ evCallStack cs = do
         return (pushCS nameExpr locExpr (Cast tm ip_co))
 
   case cs of
-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
-    EvCsEmpty -> return emptyCS
+    EvCsPushCall fs loc tm -> mkPush fs loc tm
+    EvCsEmpty              -> return emptyCS
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index 4bda7e5354..7dd8dfef67 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -77,7 +77,6 @@ import GHC.Builtin.Names
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Core.Predicate
-import GHC.Types.Name
 import GHC.Data.Pair
 import GHC.Types.Basic
 
@@ -90,6 +89,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Outputable
 
 import GHC.Data.Bag
+import GHC.Data.FastString
+
 import qualified Data.Data as Data
 import GHC.Types.SrcLoc
 import Data.IORef( IORef )
@@ -654,9 +655,14 @@ data EvTypeable
 data EvCallStack
   -- See Note [Overview of implicit CallStacks]
   = EvCsEmpty
-  | EvCsPushCall Name RealSrcSpan EvExpr
-    -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at
-    -- @loc@, in a calling context @stk@.
+  | EvCsPushCall
+        FastString   -- Usually the name of the function being called
+                     --   but can also be "the literal 42"
+                     --   or "an if-then-else expression", etc
+        RealSrcSpan  -- Location of the call
+        EvExpr       -- Rest of the stack
+    -- ^ @EvCsPushCall origin loc stk@ represents a call from @origin@,
+    --  occurring at @loc@, in a calling context @stk@.
   deriving Data.Data
 
 {-
@@ -740,7 +746,7 @@ Conclusion: a new wanted coercion variable should be made mutable.
 
 
 Note [Overview of implicit CallStacks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 (See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations)
 
 The goal of CallStack evidence terms is to reify locations
@@ -753,8 +759,11 @@ to constraints of type GHC.Stack.Types.HasCallStack, an alias
 Implicit parameters of type GHC.Stack.Types.CallStack (the name is not
 important) are solved in three steps:
 
-1. Occurrences of CallStack IPs are solved directly from the given IP,
-   just like a regular IP. For example, the occurrence of `?stk` in
+1. Explicit, user-written occurrences of `?stk :: CallStack`
+   which have IPOccOrigin, are solved directly from the given IP,
+   just like a regular IP; see GHC.Tc.Solver.Interact.interactDict.
+
+   For example, the occurrence of `?stk` in
 
      error :: (?stk :: CallStack) => String -> a
      error s = raise (ErrorCall (s ++ prettyCallStack ?stk))
@@ -765,30 +774,42 @@ important) are solved in three steps:
    append the current call-site to it. For example, consider a
    call to the callstack-aware `error` above.
 
-     undefined :: (?stk :: CallStack) => a
-     undefined = error "undefined!"
+     foo :: (?stk :: CallStack) => a
+     foo = error "undefined!"
 
    Here we want to take the given `?stk` and append the current
    call-site, before passing it to `error`. In essence, we want to
-   rewrite `error "undefined!"` to
+   rewrite `foo "undefined!"` to
 
-     let ?stk = pushCallStack <error's location> ?stk
-     in error "undefined!"
+     let ?stk = pushCallStack <foo's location> ?stk
+     in foo "undefined!"
 
-   We achieve this effect by emitting a NEW wanted
+   We achieve this as follows:
 
-     [W] d :: IP "stk" CallStack
+   * At a call of foo :: (?stk :: CallStack) => blah
+     we emit a Wanted
+        [W] d1 : IP "stk" CallStack
+     with CtOrigin = OccurrenceOf "foo"
 
-   from which we build the evidence term
+   * We /solve/ this constraint, in GHC.Tc.Solver.Canonical.canClassNC
+     by emitting a NEW Wanted
+        [W] d2 :: IP "stk" CallStack
+     with CtOrigin = IPOccOrigin
 
-     EvCsPushCall "error" <error's location> (EvId d)
+     and solve d1 = EvCsPushCall "foo" <foo's location> (EvId d1)
 
-   that we use to solve the call to `error`. The new wanted `d` will
-   then be solved per rule (1), ie as a regular IP.
+   * The new Wanted, for `d2` will be solved per rule (1), ie as a regular IP.
 
-   (see GHC.Tc.Solver.Interact.interactDict)
+3. We use the predicate isPushCallStackOrigin to identify whether we
+   want to do (1) solve directly, or (2) push and then solve directly.
+   Key point (see #19918): the CtOrigin where we want to push an item on the
+   call stack can include IfThenElseOrigin etc, when RebindableSyntax is
+   involved.  See the defn of fun_orig in GHC.Tc.Gen.App.tcInstFun; it is
+   this CtOrigin that is pinned on the constraints generated by functions
+   in the "expansion" for rebindable syntax. c.f. GHC.Rename.Expr
+   Note [Handling overloaded and rebindable constructs]
 
-3. We default any insoluble CallStacks to the empty CallStack. Suppose
+4. We default any insoluble CallStacks to the empty CallStack. Suppose
    `undefined` did not request a CallStack, ie
 
      undefinedNoStk :: a
@@ -1042,8 +1063,8 @@ instance Outputable EvTerm where
 instance Outputable EvCallStack where
   ppr EvCsEmpty
     = text "[]"
-  ppr (EvCsPushCall name loc tm)
-    = ppr (name,loc) <+> text ":" <+> ppr tm
+  ppr (EvCsPushCall orig loc tm)
+    = ppr (orig,loc) <+> text ":" <+> ppr tm
 
 instance Outputable EvTypeable where
   ppr (EvTypeableTyCon ts _)  = text "TyCon" <+> ppr ts
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 371093a183..e66a83f5bb 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -18,11 +18,15 @@ module GHC.Tc.Types.Origin (
   -- CtOrigin
   CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
   isVisibleOrigin, toInvisibleOrigin,
-  pprCtOrigin, isGivenOrigin
+  pprCtOrigin, isGivenOrigin,
+
+  -- CtOrigin and CallStack
+  isPushCallStackOrigin, callStackOriginFS
 
   ) where
 
 import GHC.Prelude
+import GHC.Utils.Misc (HasCallStack)
 
 import GHC.Tc.Utils.TcType
 
@@ -432,7 +436,6 @@ data CtOrigin
   | MCompOrigin         -- Arising from a monad comprehension
   | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a
                                 -- monad comprehension
-  | IfOrigin            -- Arising from an if statement
   | ProcOrigin          -- Arising from a proc expression
   | AnnOrigin           -- An annotation
 
@@ -450,6 +453,7 @@ data CtOrigin
   | TypeHoleOrigin OccName   -- from a type hole (partial type signature)
   | PatCheckOrigin      -- normalisation of a type during pattern-match checking
   | ListOrigin          -- An overloaded list
+  | IfThenElseOrigin    -- An if-then-else expression
   | BracketOrigin       -- An overloaded quotation bracket
   | StaticOrigin        -- A static form
   | Shouldn'tHappenOrigin String
@@ -521,7 +525,7 @@ exprCtOrigin (SectionR _ _ _)     = SectionOrigin
 exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
 exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
 exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf {})           = Shouldn'tHappenOrigin "if expression"
+exprCtOrigin (HsIf {})           = IfThenElseOrigin
 exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
 exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
 exprCtOrigin (HsDo {})           = DoOrigin
@@ -639,7 +643,7 @@ pprCtOrigin simple_origin
   = ctoHerald <+> pprCtO simple_origin
 
 -- | Short one-liners
-pprCtO :: CtOrigin -> SDoc
+pprCtO :: HasCallStack => CtOrigin -> SDoc
 pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]
 pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]
 pprCtO AppOrigin             = text "an application"
@@ -651,7 +655,6 @@ pprCtO ExprSigOrigin         = text "an expression type signature"
 pprCtO PatSigOrigin          = text "a pattern type signature"
 pprCtO PatOrigin             = text "a pattern"
 pprCtO ViewPatOrigin         = text "a view pattern"
-pprCtO IfOrigin              = text "an if expression"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
@@ -672,8 +675,47 @@ pprCtO (ExprHoleOrigin occ)  = text "a use of" <+> quotes (ppr occ)
 pprCtO (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ)
 pprCtO PatCheckOrigin        = text "a pattern-match completeness check"
 pprCtO ListOrigin            = text "an overloaded list"
+pprCtO IfThenElseOrigin      = text "an if-then-else expression"
 pprCtO StaticOrigin          = text "a static form"
 pprCtO NonLinearPatternOrigin = text "a non-linear pattern"
 pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
 pprCtO BracketOrigin         = text "a quotation bracket"
-pprCtO _                     = panic "pprCtOrigin"
+
+-- These ones are handled by pprCtOrigin, but we nevertheless sometimes
+-- get here via callStackOriginFS, when doing ambiguity checks
+-- A bit silly, but no great harm
+pprCtO (GivenOrigin {})             = text "a given constraint"
+pprCtO (SpecPragOrigin {})          = text "a SPECIALISE pragma"
+pprCtO (FunDepOrigin1 {})           = text "a functional dependency"
+pprCtO (FunDepOrigin2 {})           = text "a functional dependency"
+pprCtO (TypeEqOrigin {})            = text "a type equality"
+pprCtO (KindEqOrigin {})            = text "a kind equality"
+pprCtO (DerivOriginDC {})           = text "a deriving clause"
+pprCtO (DerivOriginCoerce {})       = text "a derived method"
+pprCtO (DoPatOrigin {})             = text "a do statement"
+pprCtO (MCompPatOrigin {})          = text "a monad comprehension pattern"
+pprCtO (Shouldn'tHappenOrigin note) = text note
+pprCtO (ProvCtxtOrigin {})          = text "a provided constraint"
+pprCtO (InstProvidedOrigin {})      = text "a provided constraint"
+pprCtO (CycleBreakerOrigin orig)    = pprCtO orig
+
+{- *********************************************************************
+*                                                                      *
+             CallStacks and CtOrigin
+
+    See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+*                                                                      *
+********************************************************************* -}
+
+isPushCallStackOrigin :: CtOrigin -> Bool
+-- Do we want to solve this IP constraint directly (return False)
+-- or push the call site (return True)
+-- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence
+isPushCallStackOrigin (IPOccOrigin {}) = False
+isPushCallStackOrigin _                = True
+
+
+callStackOriginFS :: CtOrigin -> FastString
+-- This is the string that appears in the CallStack
+callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun)
+callStackOriginFS orig               = mkFastString (showSDocUnsafe (pprCtO orig))