Emit wild-card constraints in the right place

We were failing to emit wild-card hole constraints altogether
in the case of pattern bindings.  Reason: it was done in
tcExtendTyVarEnvFromSig, which isn't called for pattern bindings.

This patch make it work right for both pattern and function
bindings.  Mainly, there is a call to emitWildCardHolds in
tcRhs for both PatBind and FunBind.

I also killed off TcExpr.typeSigCtxt.

compiler/typecheck/TcBinds.hs

@@ -799,7 +799,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
        ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs])
        ; return (mk_binders free_tvs, annotated_theta) }
 
-  | PartialSig { sig_cts = extra } <- bndr_info
+  | PartialSig { sig_cts = extra, sig_hs_ty = hs_ty } <- bndr_info
   , Just loc <- extra
   = do { annotated_theta <- zonkTcTypes annotated_theta
        ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
@@ -816,7 +816,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
              final_theta   = annotated_theta ++ inferred_diff
        ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
        ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
-       ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
+       ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs hs_ty) empty
        ; traceTc "completeTheta" $
             vcat [ ppr bndr_info
                  , ppr annotated_theta, ppr inferred_theta
@@ -834,11 +834,11 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
 
   where
     pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
-    mk_msg inferred_diff suppress_hint
+    mk_msg inferred_diff suppress_hint hs_ty
        = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_'))
                    2 (text "standing for") <+> quotes (pprTheta inferred_diff)
               , if suppress_hint then empty else pts_hint
-              , typeSigCtxt ctxt bndr_info ]
+              , pprSigCtxt ctxt (ppr hs_ty) ]
 
     spec_tv_set = mkVarSet $ map snd annotated_tvs
     mk_binders free_tvs
@@ -1497,8 +1497,19 @@ tcMonoBinds _ sig_fn no_gen binds
                                        | (n,id) <- rhs_id_env]
         ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
                     mapM (wrapLocM tcRhs) tc_binds
+
         ; return (listToBag binds', mono_infos) }
 
+
+emitWildCardHoles :: MonoBindInfo -> TcM ()
+emitWildCardHoles (MBI { mbi_sig = Just sig })
+  | TISI { sig_bndr = bndr, sig_ctxt = ctxt } <- sig
+  , PartialSig { sig_wcs = wc_prs, sig_hs_ty = hs_ty } <- bndr
+  = addErrCtxt (pprSigCtxt ctxt (ppr hs_ty)) $
+    emitWildCardHoleConstraints wc_prs
+emitWildCardHoles _
+  = return ()
+
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
@@ -1581,6 +1592,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
         ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
                                  matches (mkCheckExpType $ idType mono_id)
+        ; emitWildCardHoles info
         ; return ( FunBind { fun_id = L loc mono_id
                            , fun_matches = matches'
                            , fun_co_fn = co_fn
@@ -1597,6 +1609,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                     tcGRHSsPat grhss pat_ty
+        ; mapM_ emitWildCardHoles infos
         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
                            , pat_rhs_ty = pat_ty
                            , bind_fvs = placeHolderNamesTc
@@ -1610,15 +1623,12 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside
 
 tcExtendTyVarEnvFromSig :: TcIdSigInfo -> TcM a -> TcM a
 tcExtendTyVarEnvFromSig sig thing_inside
-  | TISI { sig_bndr = s_bndr, sig_skols = skol_prs, sig_ctxt = ctxt } <- sig
+  | TISI { sig_bndr = s_bndr, sig_skols = skol_prs } <- sig
   = tcExtendTyVarEnv2 skol_prs $
     case s_bndr of
       CompleteSig {}  -> thing_inside
       PartialSig { sig_wcs = wc_prs }  -- Extend the env ad emit the holes
-                      -> tcExtendTyVarEnv2 wc_prs $
-                         do { addErrCtxt (typeSigCtxt ctxt s_bndr) $
-                              emitWildCardHoleConstraints wc_prs
-                            ; thing_inside }
+                      -> tcExtendTyVarEnv2 wc_prs thing_inside
 
 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
 -- Extend the TcIdBinderStack for the RHS of the binding, with
@@ -2105,12 +2115,6 @@ patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Nam
 patMonoBindsCtxt pat grhss
   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
 
-typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc
-typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty })
-  = pprSigCtxt ctxt empty (ppr hs_ty)
-typeSigCtxt ctxt (CompleteSig id)
-  = pprSigCtxt ctxt empty (ppr (idType id))
-
 instErrCtxt :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
 instErrCtxt name ty env
   = do { let (env', ty') = tidyOpenType env ty

compiler/typecheck/TcExpr.hs

@@ -1454,10 +1454,13 @@ tcExprSig expr sig@(TISI { sig_bndr  = s_bndr
                          <.> mkWpLet  ev_binds
        ; return (mkLHsWrap poly_wrap expr', idType poly_id) }
 
-  | PartialSig { sig_name = name } <- s_bndr
-  = do { (tclvl, wanted, expr') <- pushLevelAndCaptureConstraints  $
-                                   tcExtendTyVarEnvFromSig sig $
-                                   tcPolyExprNC expr tau
+  | PartialSig { sig_name = name, sig_wcs = wc_prs, sig_hs_ty = hs_ty } <- s_bndr
+  = do { (tclvl, wanted, expr')
+             <- pushLevelAndCaptureConstraints  $
+                tcExtendTyVarEnvFromSig sig $
+                do { addErrCtxt (pprSigCtxt ExprSigCtxt (ppr hs_ty)) $
+                     emitWildCardHoleConstraints wc_prs
+                   ; tcPolyExprNC expr tau }
        ; (qtvs, givens, ev_binds)
                  <- simplifyInfer tclvl False [sig] [(name, tau)] wanted
        ; tau <- zonkTcType tau

compiler/typecheck/TcHsType.hs

@@ -153,7 +153,7 @@ funsSigCtxt []              = panic "funSigCtxt"
 addSigCtxt :: UserTypeCtxt -> LHsType Name -> TcM a -> TcM a
 addSigCtxt ctxt sig_ty thing_inside
   = setSrcSpan (getLoc sig_ty) $
-    addErrCtxt (pprSigCtxt ctxt empty (ppr sig_ty)) $
+    addErrCtxt (pprSigCtxt ctxt (ppr sig_ty)) $
     thing_inside
 
 tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type

compiler/typecheck/TcType.hs

@@ -564,18 +564,18 @@ pprUserTypeCtxt SigmaCtxt         = text "the context of a polymorphic type"
 pprUserTypeCtxt (DataTyCtxt tc)   = text "the context of the data type declaration for" <+> quotes (ppr tc)
 pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n)
 
-pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc
+pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc
 -- (pprSigCtxt ctxt <extra> <type>)
--- prints    In <extra> the type signature for 'f':
+-- prints    In the type signature for 'f':
 --              f :: <type>
 -- The <extra> is either empty or "the ambiguity check for"
-pprSigCtxt ctxt extra pp_ty
+pprSigCtxt ctxt pp_ty
   | Just n <- isSigMaybe ctxt
-  = vcat [ text "In" <+> extra <+> ptext (sLit "the type signature:")
-         , nest 2 (pprPrefixOcc n <+> dcolon <+> pp_ty) ]
+  = hang (text "In the type signature:")
+       2 (pprPrefixOcc n <+> dcolon <+> pp_ty)
 
   | otherwise
-  = hang (text "In" <+> extra <+> pprUserTypeCtxt ctxt <> colon)
+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)
        2 pp_ty
 
 isSigMaybe :: UserTypeCtxt -> Maybe Name
@@ -1823,7 +1823,7 @@ pickQuantifiablePreds
   -> TcThetaType        -- Context from PartialTypeSignatures
   -> TcThetaType        -- Proposed constraints to quantify
   -> TcThetaType        -- A subset that we can actually quantify
--- This function decides whether a particular constraint shoudl be
+-- This function decides whether a particular constraint should be
 -- quantified over, given the type variables that are being quantified
 pickQuantifiablePreds qtvs annotated_theta theta
   = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without