Improve error reporting in generated code

Our error reporting in generated code (via desugaring before
typechecking) only worked when the generated code was just a simple
call. This commit makes it work in nested cases.

6 files changed, 100 insertions, 61 deletions

diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 597af3d778..be0b12a278 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -20,7 +20,7 @@ module GHC.Rename.Utils (
         mkFieldEnv,
         badQualBndrErr, typeAppErr, badFieldConErr,
         wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
-        genHsIntegralLit, genHsTyLit,
+        genHsIntegralLit, genHsTyLit, genSimpleConPat,
 
         newLocalBndrRn, newLocalBndrsRn,
 
@@ -676,3 +676,13 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
 
 genHsTyLit :: FastString -> HsType GhcRn
 genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
+
+genSimpleConPat :: Name -> [Name] -> LPat GhcRn
+-- The pattern (C x1 .. xn)
+genSimpleConPat con args
+  = wrapGenSpan $ ConPat { pat_con_ext = noExtField
+                         , pat_con     = wrapGenSpan con
+                         , pat_args    = PrefixCon [] (map genVarPat args) }
+
+genVarPat :: Name -> LPat GhcRn
+genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 86aac8d99d..e8cf8ce097 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -46,7 +46,7 @@ import GHC.Hs
 
 import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Constraint
-import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc)
+import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType
@@ -1913,7 +1913,7 @@ pprTcSolverReportMsg _
             , mismatch_item = item
             , mismatch_ty1  = ty1
             , mismatch_ty2  = ty2 })
-  = addArising (errorItemOrigin item) msg
+  = addArising (errorItemCtLoc item) msg
   where
     msg
       | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||
@@ -1979,7 +1979,7 @@ pprTcSolverReportMsg ctxt
                   , teq_mismatch_expected = exp
                   , teq_mismatch_actual   = act
                   , teq_mismatch_what     = mb_thing })
-  = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
+  = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
   where
     msg
       | isUnliftedTypeKind act, isLiftedTypeKind exp
@@ -2155,7 +2155,7 @@ pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =
 pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =
   let givens = getUserGivens ctxt
   in if null givens
-     then addArising (errorItemOrigin item) $
+     then addArising (errorItemCtLoc item) $
             sep [ text "Unbound implicit parameter" <> plural preds
                 , nest 2 (pprParendTheta preds) ]
      else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)
@@ -2171,9 +2171,9 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
   where
     main_msg
       | null useful_givens
-      = addArising orig (no_instance_msg <+> missing)
+      = addArising ct_loc (no_instance_msg <+> missing)
       | otherwise
-      = vcat (addArising orig (no_deduce_msg <+> missing)
+      = vcat (addArising ct_loc (no_deduce_msg <+> missing)
               : pp_givens useful_givens)
 
     supplementary = case mb_extra of
@@ -2181,7 +2181,8 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
         -> Left []
       Just (CND_Extra level ty1 ty2)
         -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
-    orig = errorItemOrigin item
+    ct_loc = errorItemCtLoc item
+    orig   = ctLocOrigin ct_loc
     wanteds = map errorItemPred (item:others)
 
     no_instance_msg =
@@ -2203,7 +2204,7 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
 
 pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) =
   pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+>
-  pprArising (errorItemOrigin item) $$
+  pprArising (errorItemCtLoc item) $$
   text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)
   <+> text "from being solved."
 pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
@@ -2304,7 +2305,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
 
 pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =
   vcat
-    [ addArising orig $
+    [ addArising ct_loc $
         (text "Overlapping instances for"
         <+> pprType (mkClassPred clas tys))
     , ppUnless (null matching_givens) $
@@ -2339,7 +2340,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
                            , text "when compiling the other instance declarations"]
                ])]
   where
-    orig            = errorItemOrigin item
+    ct_loc          = errorItemCtLoc item
+    orig            = ctLocOrigin ct_loc
     pred            = errorItemPred item
     (clas, tys)     = getClassPredTys pred
     tyCoVars        = tyCoVarsOfTypesList tys
@@ -2363,7 +2365,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
                                           && isJust (tcMatchTys tys tys')
                      Nothing -> False
 pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
-  vcat [ addArising orig (text "Unsafe overlapping instances for"
+  vcat [ addArising ct_loc (text "Unsafe overlapping instances for"
                   <+> pprType (mkClassPred clas tys))
        , sep [text "The matching instance is:",
               nest 2 (pprInstance $ head matches)]
@@ -2375,7 +2377,7 @@ pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
               ]
        ]
   where
-    orig        = errorItemOrigin item
+    ct_loc      = errorItemCtLoc item
     pred        = errorItemPred item
     (clas, tys) = getClassPredTys pred
 
@@ -2906,20 +2908,28 @@ levelString :: TypeOrKind -> String
 levelString TypeLevel = "type"
 levelString KindLevel = "kind"
 
-pprArising :: CtOrigin -> SDoc
+pprArising :: CtLoc -> SDoc
 -- Used for the main, top-level error message
 -- We've done special processing for TypeEq, KindEq, givens
-pprArising (TypeEqOrigin {})         = empty
-pprArising (KindEqOrigin {})         = empty
-pprArising (AmbiguityCheckOrigin {}) = empty  -- the "In the ambiguity check" context
-                                              -- is sufficient; this would just be
-                                              -- repetitive
-pprArising orig | isGivenOrigin orig = empty
-                | otherwise          = pprCtOrigin orig
+pprArising ct_loc
+  | in_generated_code = empty  -- See Note ["Arising from" messages in generated code]
+  | suppress_origin   = empty
+  | otherwise         = pprCtOrigin orig
+  where
+    orig = ctLocOrigin ct_loc
+    in_generated_code = lclEnvInGeneratedCode (ctLocEnv ct_loc)
+    suppress_origin
+      | isGivenOrigin orig = True
+      | otherwise          = case orig of
+          TypeEqOrigin {}         -> True -- We've done special processing
+          KindEqOrigin {}         -> True -- for TypeEq, KindEq, givens
+          AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context
+                                          -- is sufficient; more would be repetitive
+          _ -> False
 
 -- Add the "arising from..." part to a message
-addArising :: CtOrigin -> SDoc -> SDoc
-addArising orig msg = hang msg 2 (pprArising orig)
+addArising :: CtLoc -> SDoc -> SDoc
+addArising ct_loc msg = hang msg 2 (pprArising ct_loc)
 
 pprWithArising :: [Ct] -> SDoc
 -- Print something like
@@ -2931,7 +2941,7 @@ pprWithArising []
   = panic "pprWithArising"
 pprWithArising (ct:cts)
   | null cts
-  = addArising (ctLocOrigin loc) (pprTheta [ctPred ct])
+  = addArising loc (pprTheta [ctPred ct])
   | otherwise
   = vcat (map ppr_one (ct:cts))
   where
@@ -2939,6 +2949,19 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprCtLoc (ctLoc ct'))
 
+{- Note ["Arising from" messages in generated code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider code generated when we desugar code before typechecking;
+see Note [Rebindable syntax and HsExpansion].
+
+In this code, constraints may be generated, but we don't want to
+say "arising from a call of foo" if 'foo' doesn't appear in the
+users code.  We leave the actual CtOrigin untouched (partly because
+it is generated in many, many places), but suppress the "Arising from"
+message for constraints that originate in generated code.
+-}
+
+
 {- *********************************************************************
 *                                                                      *
                            SkolemInfo
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index e72e3ed194..8f59daf24a 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -733,18 +733,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
                                    , text "do_ql" <+> ppr do_ql ])
        ; go emptyVarSet [] [] fun_sigma rn_args }
   where
-    fun_loc  = appCtxtLoc fun_ctxt
     fun_orig = exprCtOrigin (case fun_ctxt of
                                VAExpansion e _ -> e
                                VACall e _ _    -> e)
-    set_fun_ctxt thing_inside
-      | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
-      = thing_inside                  -- => context is already set
-      | otherwise
-      = setSrcSpan fun_loc $
-        case fun_ctxt of
-          VAExpansion orig _ -> addExprCtxt orig thing_inside
-          VACall {}          -> thing_inside
 
     -- Count value args only when complaining about a function
     -- applied to too many value args
@@ -803,9 +794,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
       | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
       , (theta, body2) <- tcSplitPhiTy body1
       , not (null tvs && null theta)
-      = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $
+      = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
                                           instantiateSigma fun_orig tvs theta body2
-                 -- set_fun_ctxt: important for the class constraints
+                 -- addHeadCtxt: important for the class constraints
                  -- that may be emitted from instantiating fun_sigma
            ; go (delta `extendVarSetList` inst_tvs)
                 (addArgWrap wrap acc) so_far fun_rho args }
@@ -894,19 +885,26 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
 
 addArgCtxt :: AppCtxt -> LHsExpr GhcRn
            -> TcM a -> TcM a
--- Adds a "In the third argument of f, namely blah"
--- context, unless we are in generated code, in which case
--- use "In the expression: arg"
+-- There are two cases:
+-- * In the normal case, we add an informative context
+--      "In the third argument of f, namely blah"
+-- * If we are deep inside generated code (isGeneratedCode)
+--   or if all or part of this particular application is an expansion
+--   (VAExpansion), just use the less-informative context
+--       "In the expression: arg"
+--   Unless the arg is also a generated thing, in which case do nothing.
 ---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside
-  = setSrcSpanA arg_loc $
-    addErrCtxt (funAppCtxt fun arg arg_no) $
-    thing_inside
-
-addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside
-  = setSrcSpanA arg_loc $
-    addExprCtxt arg    $  -- Auto-suppressed if arg_loc is generated
-    thing_inside
+addArgCtxt ctxt (L arg_loc arg) thing_inside
+  = do { in_generated_code <- inGeneratedCode
+       ; case ctxt of
+           VACall fun arg_no _ | not in_generated_code
+             -> setSrcSpanA arg_loc                    $
+                addErrCtxt (funAppCtxt fun arg arg_no) $
+                thing_inside
+
+           _ -> setSrcSpanA arg_loc $
+                addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
+                thing_inside }
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 296b223c8a..16d9cd05b8 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Gen.Head
        , tyConOf, tyConOfET, lookupParents, fieldNotInType
        , notSelector, nonBidirectionalErr
 
-       , addExprCtxt, addFunResCtxt ) where
+       , addHeadCtxt, addExprCtxt, addFunResCtxt ) where
 
 import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
 
@@ -431,12 +431,11 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
 --
 -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
 tcInferAppHead (fun,ctxt) args
-  = setSrcSpan (appCtxtLoc ctxt) $
+  = addHeadCtxt ctxt $
     do { mb_tc_fun <- tcInferAppHead_maybe fun args
        ; case mb_tc_fun of
             Just (fun', fun_sigma) -> return (fun', fun_sigma)
-            Nothing -> add_head_ctxt fun args $
-                       tcInfer (tcExpr fun) }
+            Nothing -> tcInfer (tcExpr fun) }
 
 tcInferAppHead_maybe :: HsExpr GhcRn
                      -> [HsExprArg 'TcpRn]
@@ -447,20 +446,23 @@ tcInferAppHead_maybe fun args
   = case fun of
       HsVar _ (L _ nm)          -> Just <$> tcInferId nm
       HsRecSel _ f              -> Just <$> tcInferRecSelId f
-      ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $
-                                   Just <$> tcExprWithSig e hs_ty
+      ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty
       HsOverLit _ lit           -> Just <$> tcInferOverLit lit
       HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))
                                 -> tcInferAppHead_maybe e args
       _                         -> return Nothing
 
-add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
--- Don't push an expression context if the arguments are empty,
--- because it has already been pushed by tcExpr
-add_head_ctxt fun args thing_inside
-  | null args = thing_inside
-  | otherwise = addExprCtxt fun thing_inside
-
+addHeadCtxt :: AppCtxt -> TcM a -> TcM a
+addHeadCtxt fun_ctxt thing_inside
+  | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
+  = thing_inside                  -- => context is already set
+  | otherwise
+  = setSrcSpan fun_loc $
+    case fun_ctxt of
+      VAExpansion orig _ -> addExprCtxt orig thing_inside
+      VACall {}          -> thing_inside
+  where
+    fun_loc = appCtxtLoc fun_ctxt
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index bce78dda31..f7dd7e7a9a 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Types(
         Env(..),
         TcGblEnv(..), TcLclEnv(..),
         setLclEnvTcLevel, getLclEnvTcLevel,
-        setLclEnvLoc, getLclEnvLoc,
+        setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode,
         IfGblEnv(..), IfLclEnv(..),
         tcVisibleOrphanMods,
         RewriteEnv(..),
@@ -861,6 +861,9 @@ setLclEnvLoc env loc = env { tcl_loc = loc }
 getLclEnvLoc :: TcLclEnv -> RealSrcSpan
 getLclEnvLoc = tcl_loc
 
+lclEnvInGeneratedCode :: TcLclEnv -> Bool
+lclEnvInGeneratedCode = tcl_in_gen_code
+
 type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))
         -- Monadic so that we have a chance
         -- to deal with bound type variables just before error
diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot
index 42df1f4bc0..405374a06b 100644
--- a/compiler/GHC/Tc/Types.hs-boot
+++ b/compiler/GHC/Tc/Types.hs-boot
@@ -1,5 +1,6 @@
 module GHC.Tc.Types where
 
+import GHC.Prelude
 import GHC.Tc.Utils.TcType
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
@@ -19,3 +20,5 @@ getLclEnvTcLevel :: TcLclEnv -> TcLevel
 
 setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv
 getLclEnvLoc :: TcLclEnv -> RealSrcSpan
+
+lclEnvInGeneratedCode :: TcLclEnv -> Bool