diff options
Diffstat (limited to 'compiler/typecheck/TcBinds.hs')
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 471 |
1 files changed, 247 insertions, 224 deletions
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 7b01ababcd..b549856ac1 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -9,18 +9,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, +module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, tcHsBootSigs, tcPolyCheck, - tcVectDecls, addTypecheckedBinds, + addTypecheckedBinds, chooseInferredQuantifiers, badBootDeclErr ) where +import GhcPrelude + import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import CoreSyn (Tickish (..)) -import CostCentre (mkUserCC) +import CostCentre (mkUserCC, CCFlavour(DeclCC)) import DynFlags import FastString import HsSyn @@ -38,9 +39,9 @@ import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs ) import TyCon import TcType -import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe) +import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) import TysPrim -import TysWiredIn( cTupleTyConName ) +import TysWiredIn( mkBoxedTupleTy ) import Id import Var import VarSet @@ -51,7 +52,6 @@ import NameSet import NameEnv import SrcLoc import Bag -import ListSetOps import ErrUtils import Digraph import Maybes @@ -60,7 +60,6 @@ import BasicTypes import Outputable import PrelNames( ipClassName ) import TcValidity (checkValidType) -import Unique (getUnique) import UniqFM import UniqSet import qualified GHC.LanguageExtensions as LangExt @@ -137,7 +136,7 @@ If we don't take care, after typechecking we get in \ys:[a] -> ...f'... -Notice the the stupid construction of (f a d), which is of course +Notice the stupid construction of (f a d), which is of course identical to the function we're executing. In this case, the polymorphic recursion isn't being used (but that's a very common case). This can lead to a massive space leak, from the following top-level defn @@ -233,7 +232,7 @@ tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] tcCompleteSigs sigs = let doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ lns mtc) + doOne c@(CompleteMatchSig _ _ lns mtc) = fmap Just $ do addErrCtxt (text "In" <+> ppr c) $ case mtc of @@ -304,15 +303,6 @@ tcCompleteSigs sigs = <+> quotes (ppr tc')) in mapMaybeM (addLocM doOne) sigs -tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv -tcRecSelBinds (ValBindsOut binds sigs) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - tcValBinds TopLevel binds sigs getGblEnv - ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds - ; return tcg_env' } -tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" - tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this @@ -320,7 +310,7 @@ tcHsBootSigs binds sigs = do { checkTc (null binds) badBootDeclErr ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames + tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty @@ -335,16 +325,16 @@ badBootDeclErr = text "Illegal declarations in an hs-boot file" tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTcId, thing) -tcLocalBinds EmptyLocalBinds thing_inside +tcLocalBinds (EmptyLocalBinds x) thing_inside = do { thing <- thing_inside - ; return (EmptyLocalBinds, thing) } + ; return (EmptyLocalBinds x, thing) } -tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside +tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds (ValBindsOut binds' sigs), thing) } -tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" + ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" -tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside +tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside = do { ipClass <- tcLookupClass ipClassName ; (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds @@ -355,27 +345,31 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside ; (ev_binds, result) <- checkConstraints (IPSkol ips) [] given_ips thing_inside - ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } + ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds] + ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds] -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcMonoExpr expr (mkCheckExpType ty) ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind (Right ip_id) d)) } - tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" + ; return (ip_id, (IPBind noExt (Right ip_id) d)) } + tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" + tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind" -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] +tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds" +tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds" + {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We add the type variables in the types of the implicit parameters @@ -407,7 +401,7 @@ tcValBinds top_lvl binds sigs thing_inside -- Extend the envt right away with all the Ids -- declared with complete type signatures - -- Do not extend the TcIdBinderStack; instead + -- Do not extend the TcBinderStack; instead -- we extend it on a per-rhs basis in tcExtendForRhs ; tcExtendSigIds top_lvl poly_ids $ do { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do @@ -529,18 +523,12 @@ tc_single :: forall thing. -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn - (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside - = do { (aux_binds, tcg_env) <- tc_pat_syn_decl + = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside ; return (aux_binds, thing) } - where - tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv) - tc_pat_syn_decl = case sig_fn name of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - Just _ -> panic "tc_single" tc_single top_lvl sig_fn prag_fn lbind closed thing_inside = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn @@ -564,6 +552,10 @@ mkEdges sig_fn binds -- is still deterministic even if the edges are in nondeterministic order -- as explained in Note [Deterministic SCC] in Digraph. where + bind_fvs (FunBind { fun_ext = fvs }) = fvs + bind_fvs (PatBind { pat_ext = fvs }) = fvs + bind_fvs _ = emptyNameSet + no_sig :: Name -> Bool no_sig n = not (hasCompleteSig sig_fn n) @@ -638,7 +630,13 @@ recoveryCode binder_names sig_fn = mkLocalId name forall_a_a forall_a_a :: TcType -forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy +-- At one point I had (forall r (a :: TYPE r). a), but of course +-- that type is ill-formed: its mentions 'r' which escapes r's scope. +-- Another alternative would be (forall (a :: TYPE kappa). a), where +-- kappa is a unification variable. But I don't think we need that +-- complication here. I'm going to just use (forall (a::*). a). +-- See Trac #15276 +forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy {- ********************************************************************* * * @@ -701,8 +699,8 @@ tcPolyCheck prag_fn ; (ev_binds, (co_fn, matches')) <- checkConstraints skol_info skol_tvs ev_vars $ - tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ - tcExtendTyVarEnv2 tv_prs $ + tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ + tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $ tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) @@ -711,19 +709,27 @@ tcPolyCheck prag_fn ; poly_id <- addInlinePrags poly_id prag_sigs ; mod <- getModule + ; tick <- funBindTicks nm_loc mono_id mod prag_sigs ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc - , fun_tick = funBindTicks nm_loc mono_id mod prag_sigs } + , fun_ext = placeHolderNamesTc + , fun_tick = tick } - abs_bind = L loc $ AbsBindsSig - { abs_sig_export = poly_id - , abs_tvs = skol_tvs - , abs_ev_vars = ev_vars - , abs_sig_prags = SpecPrags spec_prags - , abs_sig_ev_bind = ev_binds - , abs_sig_bind = L loc bind' } + export = ABE { abe_ext = noExt + , abe_wrap = idHsWrapper + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags } + + abs_bind = L loc $ + AbsBinds { abs_ext = noExt + , abs_tvs = skol_tvs + , abs_ev_vars = ev_vars + , abs_ev_binds = [ev_binds] + , abs_exports = [export] + , abs_binds = unitBag (L loc bind') + , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) } @@ -731,9 +737,9 @@ tcPolyCheck _prag_fn sig bind = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] - -> [Tickish TcId] + -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -742,10 +748,12 @@ funBindTicks loc fun_id mod sigs | otherwise = getOccFS (Var.varName fun_id) cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str - cc = mkUserCC cc_name mod loc (getUnique fun_id) - = [ProfNote cc True True] + = do + flavour <- DeclCC <$> getCCIndexM cc_name + let cc = mkUserCC cc_name mod loc flavour + return [ProfNote cc True True] | otherwise - = [] + = return [] {- Note [Instantiate sig with fresh variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -787,19 +795,21 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; mapM_ (checkOverloadedSig mono) sigs ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds) + ; (qtvs, givens, ev_binds, insoluble) <- simplifyInfer tclvl infer_mode sigs name_taus wanted ; let inferred_theta = map evVarPred givens ; exports <- checkNoErrs $ - mapM (mkExport prag_fn qtvs inferred_theta) mono_infos + mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports abs_bind = L loc $ - AbsBinds { abs_tvs = qtvs + AbsBinds { abs_ext = noExt + , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] - , abs_exports = exports, abs_binds = binds' } + , abs_exports = exports, abs_binds = binds' + , abs_sig = False } ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) ; return (unitBag abs_bind, poly_ids) } @@ -807,6 +817,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list -------------- mkExport :: TcPragEnv + -> Bool -- True <=> there was an insoluble type error + -- when typechecking the bindings -> [TyVar] -> TcThetaType -- Both already zonked -> MonoBindInfo -> TcM (ABExport GhcTc) @@ -823,12 +835,12 @@ mkExport :: TcPragEnv -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn qtvs theta +mkExport prag_fn insoluble qtvs theta mono_info@(MBI { mbi_poly_name = poly_name , mbi_sig = mb_sig , mbi_mono_id = mono_id }) = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty + ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs @@ -854,19 +866,22 @@ mkExport prag_fn qtvs theta ; when warn_missing_sigs $ localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - ; return (ABE { abe_wrap = wrap + ; return (ABE { abe_ext = noExt + , abe_wrap = wrap -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags}) } + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags }) } where prag_sigs = lookupPragEnv prag_fn poly_name sig_ctxt = InfSigCtxt poly_name -mkInferredPolyId :: [TyVar] -> TcThetaType +mkInferredPolyId :: Bool -- True <=> there was an insoluble error when + -- checking the binding group for this Id + -> [TyVar] -> TcThetaType -> Name -> Maybe TcIdSigInst -> TcType -> TcM TcId -mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty +mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst , CompleteSig { sig_bndr = poly_id } <- sig = return poly_id @@ -894,9 +909,13 @@ mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' , ppr inferred_poly_ty]) - ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ + ; unless insoluble $ + addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ checkValidType (InfSigCtxt poly_name) inferred_poly_ty -- See Note [Validity of inferred types] + -- If we found an insoluble error in the function definition, don't + -- do this check; otherwise (Trac #14000) we may report an ambiguity + -- error for a rather bogus type. ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) } @@ -921,64 +940,96 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs , sig_inst_wcx = wcx , sig_inst_theta = annotated_theta , sig_inst_skols = annotated_tvs })) - | Nothing <- wcx - = do { annotated_theta <- zonkTcTypes annotated_theta - ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta - `unionVarSet` tau_tvs) - ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs]) - ; psig_qtvs <- mk_psig_qtvs annotated_tvs - ; return (mk_final_qtvs psig_qtvs free_tvs, annotated_theta) } - - | Just wc_var <- wcx - = do { annotated_theta <- zonkTcTypes annotated_theta - ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case - -- Omitting this caused #12844 - seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there - `unionVarSet` tau_tvs -- by the user - - ; psig_qtvs <- mk_psig_qtvs annotated_tvs - ; let my_qtvs = mk_final_qtvs psig_qtvs free_tvs - keep_me = psig_qtvs `unionVarSet` free_tvs - my_theta = pickCapturedPreds keep_me inferred_theta - - -- Report the inferred constraints for an extra-constraints wildcard/hole as - -- an error message, unless the PartialTypeSignatures flag is enabled. In this - -- case, the extra inferred constraints are accepted without complaining. - -- NB: inferred_theta already includes all the annotated constraints - inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff - ; writeMetaTyVar wc_var ctuple - ; traceTc "completeTheta" $ - vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - - ; return (my_qtvs, my_theta) } - - | otherwise -- A complete type signature is dealt with in mkInferredPolyId - = pprPanic "chooseInferredQuantifiers" (ppr sig) - + = -- Choose quantifiers for a partial type signature + do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs + + -- Check whether the quantified variables of the + -- partial signature have been unified together + -- See Note [Quantified variables in partial type signatures] + ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) + + -- Check whether a quantified variable of the partial type + -- signature is not actually quantified. How can that happen? + -- See Note [Quantification and partial signatures] Wrinkle 4 + -- in TcSimplify + ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs + , not (tv `elem` qtvs) ] + + ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) + + ; annotated_theta <- zonkTcTypes annotated_theta + ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx + + ; let keep_me = free_tvs `unionVarSet` psig_qtvs + final_qtvs = [ mkTyVarBinder vis tv + | tv <- qtvs -- Pulling from qtvs maintains original order + , tv `elemVarSet` keep_me + , let vis | tv `elemVarSet` psig_qtvs = Specified + | otherwise = Inferred ] + + ; return (final_qtvs, my_theta) } where - mk_final_qtvs psig_qtvs free_tvs - = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] - where - keep_me = free_tvs `unionVarSet` psig_qtvs - - mk_ctuple [pred] = return pred - mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds)) - ; return (mkTyConApp tc preds) } + report_dup_tyvar_tv_err (n1,n2) + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_tyvar_tv_err" (ppr sig) + + report_mono_sig_tv_err n + | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig + = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) + | otherwise -- Can't happen; by now we know it's a partial sig + = pprPanic "report_mono_sig_tv_err" (ppr sig) + + choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType + -> TcM (VarSet, TcThetaType) + choose_psig_context _ annotated_theta Nothing + = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; return (free_tvs, annotated_theta) } + + choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) + = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) + -- growThetaVars just like the no-type-sig case + -- Omitting this caused #12844 + seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there + `unionVarSet` tau_tvs -- by the user + + ; let keep_me = psig_qtvs `unionVarSet` free_tvs + my_theta = pickCapturedPreds keep_me inferred_theta + + -- Fill in the extra-constraints wildcard hole with inferred_theta, + -- so that the Hole constraint we have already emitted + -- (in tcHsPartialSigType) can report what filled it in. + -- NB: my_theta already includes all the annotated constraints + ; let inferred_diff = [ pred + | pred <- my_theta + , all (not . (`eqType` pred)) annotated_theta ] + ; ctuple <- mk_ctuple inferred_diff + + ; case tcGetCastedTyVar_maybe wc_var_ty of + -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it + -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to + -- make the kinds work out, we reverse the cast here. + Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) + Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) + + ; traceTc "completeTheta" $ + vcat [ ppr sig + , ppr annotated_theta, ppr inferred_theta + , ppr inferred_diff ] + ; return (free_tvs, my_theta) } + + mk_ctuple preds = return (mkBoxedTupleTy preds) + -- Hack alert! See TcHsType: + -- Note [Extra-constraint holes in partial type signatures] - mk_psig_qtvs :: [(Name,TcTyVar)] -> TcM TcTyVarSet - mk_psig_qtvs annotated_tvs - = do { psig_qtvs <- mapM (zonkTcTyVarToTyVar . snd) annotated_tvs - ; return (mkVarSet psig_qtvs) } mk_impedance_match_msg :: MonoBindInfo -> TcType -> TcType @@ -1076,6 +1127,28 @@ It's stupid to apply the MR here. This test includes an extra-constraints wildcard; that is, we don't apply the MR if you write f3 :: _ => blah +Note [Quantified variables in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a -> _ + f x y = g x y + g :: forall b. b -> b -> _ + g x y = [x, y] + +Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' +together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then +unify with each other. + +But now consider: + f :: forall a b. a -> b -> _ + f x y = [x, y] + +We want to get an error from this, because 'a' and 'b' get unified. +So we make a test, one per parital signature, to check that the +explicitly-quantified type variables have not been unified together. +Trac #14449 showed this up. + + Note [Validity of inferred types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to check inferred type for validity, in case it uses language @@ -1130,82 +1203,6 @@ It also cleverly does an ambiguity check; for example, rejecting where F is a non-injective type function. -} -{- ********************************************************************* -* * - Vectorisation -* * -********************************************************************* -} - -tcVectDecls :: [LVectDecl GhcRn] -> TcM ([LVectDecl GhcTcId]) -tcVectDecls decls - = do { decls' <- mapM (wrapLocM tcVect) decls - ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl] - dups = findDupsEq (==) ids - ; mapM_ reportVectDups dups - ; traceTcConstraints "End of tcVectDecls" - ; return decls' - } - where - reportVectDups (first:_second:_more) - = addErrAt (getSrcSpan first) $ - text "Duplicate vectorisation declarations for" <+> ppr first - reportVectDups _ = return () - --------------- -tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId) --- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised --- type of the original definition as this requires internals of the vectoriser not available --- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single --- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType' --- from the vectoriser here. -tcVect (HsVect s name rhs) - = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name - ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs - ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id))) - } - -tcVect (HsNoVect s name) - = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name - ; return $ HsNoVect s var - } -tcVect (HsVectTypeIn _ isScalar lname rhs_name) - = addErrCtxt (vectCtxt lname) $ - do { tycon <- tcLookupLocatedTyCon lname - ; checkTc ( not isScalar -- either we have a non-SCALAR declaration - || isJust rhs_name -- or we explicitly provide a vectorised type - || tyConArity tycon == 0 -- otherwise the type constructor must be nullary - ) - scalarTyConMustBeNullary - - ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name - ; return $ HsVectTypeOut isScalar tycon rhs_tycon - } -tcVect (HsVectTypeOut _ _ _) - = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" -tcVect (HsVectClassIn _ lname) - = addErrCtxt (vectCtxt lname) $ - do { cls <- tcLookupLocatedClass lname - ; return $ HsVectClassOut cls - } -tcVect (HsVectClassOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'" -tcVect (HsVectInstIn linstTy) - = addErrCtxt (vectCtxt linstTy) $ - do { (cls, tys) <- tcHsVectInst linstTy - ; inst <- tcLookupInstance cls tys - ; return $ HsVectInstOut inst - } -tcVect (HsVectInstOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" - -vectCtxt :: Outputable thing => thing -> SDoc -vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing - -scalarTyConMustBeNullary :: MsgDoc -scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary" {- Note [SPECIALISE pragmas] @@ -1251,7 +1248,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, - fun_matches = matches, bind_fvs = fvs })] + fun_matches = matches, fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1267,7 +1264,7 @@ tcMonoBinds is_rec sig_fn no_gen <- tcInferInst $ \ exp_ty -> -- tcInferInst: see TcUnify, -- Note [Deep instantiation of InferResult] - tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $ + tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking @@ -1276,7 +1273,7 @@ tcMonoBinds is_rec sig_fn no_gen ; mono_id <- newLetBndr no_gen name rhs_ty ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', bind_fvs = fvs, + fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name , mbi_sig = Nothing @@ -1424,7 +1421,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc + , fun_ext = placeHolderNamesTc , fun_tick = [] } ) } tcRhs (TcPatBind infos pat' grhss pat_ty) @@ -1437,8 +1434,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_rhs_ty = pat_ty - , bind_fvs = placeHolderNamesTc + , pat_ext = NPatBindTc placeHolderNamesTc pat_ty , pat_ticks = ([],[]) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a @@ -1450,12 +1446,13 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvFromSig sig_inst thing_inside | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - = tcExtendTyVarEnv2 wcs $ - tcExtendTyVarEnv2 skol_prs $ + -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs] + = tcExtendNameTyVarEnv wcs $ + tcExtendNameTyVarEnv skol_prs $ thing_inside tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a --- Extend the TcIdBinderStack for the RHS of the binding, with +-- Extend the TcBinderStack for the RHS of the binding, with -- the monomorphic Id. That way, if we have, say -- f = \x -> blah -- and something goes wrong in 'blah', we get a "relevant binding" @@ -1464,12 +1461,12 @@ tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a -- f :: forall a. [a] -> [a] -- f x = True -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] --- If we had the *polymorphic* version of f in the TcIdBinderStack, it +-- If we had the *polymorphic* version of f in the TcBinderStack, it -- would not be reported as relevant, because its type is closed tcExtendIdBinderStackForRhs infos thing_inside - = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel - | MBI { mbi_mono_id = mono_id } <- infos ] - thing_inside + = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel + | MBI { mbi_mono_id = mono_id } <- infos ] + thing_inside -- NotTopLevel: it's a monomorphic binding --------------------- @@ -1589,6 +1586,30 @@ Example for (E2), we generate The beta is untoucable, but floats out of the constraint and can be solved absolutely fine. +Note [Use tcExtendTyVar not scopeTyVars in tcRhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally, any place that corresponds to Λ or ∀ in Core should be flagged +with a call to scopeTyVars, which arranges for an implication constraint +to be made, bumps the TcLevel, and (crucially) prevents a unification +variable created outside the scope of a local skolem to unify with that +skolem. + +We do not need to do this here, however. + +- Note that this happens only in the case of a partial signature. + Complete signatures go via tcPolyCheck, not tcPolyInfer. + +- The TcLevel is incremented in tcPolyInfer, right outside the call + to tcMonoBinds. We thus don't have to worry about outer metatvs unifying + with local skolems. + +- The other potential concern is that we need SkolemInfo associated with + the skolems. This, too, is OK, though: the constraints pass through + simplifyInfer (which doesn't report errors), at the end of which + the skolems will get quantified and put into an implication constraint. + Thus, by the time any errors are reported, the SkolemInfo will be + in place. + ************************************************************************ * * Generalisation @@ -1603,7 +1624,7 @@ data GeneralisationPlan | CheckGen (LHsBind GhcRn) TcIdSigInfo -- One FunBind with a signature - -- Explicit generalisation; there is an AbsBindsSig + -- Explicit generalisation -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one @@ -1677,16 +1698,18 @@ isClosedBndrGroup type_env binds fv_env :: NameEnv NameSet fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs + bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs }) + = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs + bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = let open_fvs = get_open_fvs fvs in [(b, open_fvs) | b <- collectPatBinders pat] bindFvs _ = [] + get_open_fvs fvs = filterNameSet (not . is_closed) fvs + is_closed :: Name -> ClosedTypeId is_closed name | Just thing <- lookupNameEnv type_env name @@ -1725,7 +1748,7 @@ isClosedBndrGroup type_env binds -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body) - => LPat p -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body) + => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) |