Commit 76d9156f authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 2593e204
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment