X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=f27637d0dd723025d132fa8f5bc464b6f682b9e4;hb=85e16365444e938b4adff9d241d56df4c1fbca91;hp=351b6d8a2567987e1c3ecac285fb5438a9f5ad8a;hpb=970d5b88b1554bbdd7e459dae41aab3668ae897a;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 351b6d8..f27637d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -5,6 +5,13 @@ \section[TcBinds]{TcBinds} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, TcPragFun, tcSpecPrag, tcPrags, mkPragFun, @@ -30,11 +37,12 @@ import TcPat import TcMType import TcType import {- Kind parts of -} Type +import Coercion import VarEnv import TysPrim import Id import IdInfo -import Var ( TyVar ) +import Var ( TyVar, varType ) import Name import NameSet import NameEnv @@ -241,7 +249,7 @@ tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a) bindLocalInsts top_lvl thing_inside | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) } - -- For the top level don't bother will all this bindInstsOfLocalFuns stuff. + -- For the top level don't bother with all this bindInstsOfLocalFuns stuff. -- All the top level things are rec'd together anyway, so it's fine to -- leave them to the tcSimplifyTop, and quite a bit faster too @@ -336,15 +344,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req -- BUILD THE POLYMORPHIC RESULT IDs - ; let dict_ids = map instToId dicts - ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids)) + ; let dict_vars = map instToVar dicts -- May include equality constraints + ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids)) ; let abs_bind = L loc $ AbsBinds tyvars_to_gen - dict_ids exports + dict_vars exports (dict_binds `unionBags` binds') ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport @@ -370,17 +378,18 @@ mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs ; let warn = isTopLevel top_lvl && warn_missing_sigs ; (tvs, poly_id) <- mk_poly_id warn mb_sig + -- poly_id has a zonked type - ; poly_id' <- zonkId poly_id - ; prags <- tcPrags poly_id' (prag_fn poly_name) + ; prags <- tcPrags poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id', mono_id, prags) } + ; return (tvs, poly_id, mono_id, prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) - mk_poly_id warn Nothing = do { missingSigWarn warn poly_name poly_ty - ; return (inferred_tvs, mkLocalId poly_name poly_ty) } + mk_poly_id warn Nothing = do { poly_ty' <- zonkTcType poly_ty + ; missingSigWarn warn poly_name poly_ty' + ; return (inferred_tvs, mkLocalId poly_name poly_ty') } mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig) ; return (tvs, sig_id sig) } @@ -511,7 +520,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- e.g. f = \(x::forall a. a->a) -> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) -- Check for an unboxed tuple type -- f = (# True, False #) @@ -546,7 +555,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ - tcMatchesFun mono_name matches mono_ty + tcMatchesFun mono_name inf matches mono_ty ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', @@ -653,8 +662,8 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) - = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches - (idType mono_id) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf + matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', bind_fvs = placeHolderNames, fun_co_fn = co_fn, fun_tick = Nothing }) } @@ -769,7 +778,17 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty unify_ctxt sig@(TcSigInfo { sig_theta = theta }) = setSrcSpan (instLocSpan (sig_loc sig)) $ addErrCtxt (sigContextsCtxt sig1 sig) $ - unifyTheta theta1 theta + do { cois <- unifyTheta theta1 theta + ; -- Check whether all coercions are identity coercions + -- That can happen if we have, say + -- f :: C [a] => ... + -- g :: C (F a) => ... + -- where F is a type function and (F a ~ [a]) + -- Then unification might succeed with a coercion. But it's much + -- much simpler to require that such signatures have identical contexts + checkTc (all isIdentityCoercion cois) + (ptext SLIT("Mutually dependent functions have syntactically distinct contexts")) + } checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs