X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=9c176d0f94bd1f7bcb18151531acc5d48b0ad278;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=99832677f065f74e14f2d2aff28b68ef6f6bb214;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9983267..9c176d0 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -44,6 +44,7 @@ import Bag import ErrUtils import Digraph import Maybes +import List import Util import BasicTypes import Outputable @@ -310,6 +311,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req)) -- CHECK FOR UNLIFTED BINDINGS -- These must be non-recursive etc, and are not generalised @@ -329,24 +331,19 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds else do -- The normal lifted case: GENERALISE { dflags <- getDOpts - ; (tyvars_to_gen, dict_binds, dict_ids) + ; (tyvars_to_gen, dicts, dict_binds) <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req - -- FINALISE THE QUANTIFIED TYPE VARIABLES - -- The quantified type variables often include meta type variables - -- we want to freeze them into ordinary type variables, and - -- default their kind (e.g. from OpenTypeKind to TypeKind) - ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen - -- BUILD THE POLYMORPHIC RESULT IDs - ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + ; let dict_ids = map instToId dicts + ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids)) 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' + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen dict_ids exports (dict_binds `unionBags` binds') @@ -526,7 +523,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, ; let mono_id = mkLocalId mono_name zonked_rhs_ty ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, - fun_co_fn = co_fn })), + fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, @@ -550,7 +547,8 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', - bind_fvs = placeHolderNames, fun_co_fn = co_fn } + bind_fvs = placeHolderNames, fun_co_fn = co_fn, + fun_tick = Nothing } ; return (unitBag (L b_loc fun_bind'), [(name, Just tc_sig, mono_id)]) } @@ -655,7 +653,8 @@ tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', - bind_fvs = placeHolderNames, fun_co_fn = co_fn }) } + bind_fvs = placeHolderNames, fun_co_fn = co_fn, + fun_tick = Nothing }) } tcRhs bind@(TcPatBind _ pat' grhss pat_ty) = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ @@ -684,10 +683,13 @@ getMonoBindInfo tc_binds generalise :: DynFlags -> TopLevelFlag -> [LHsBind Name] -> TcSigFun -> [MonoBindInfo] -> [Inst] - -> TcM ([TcTyVar], TcDictBinds, [TcId]) + -> TcM ([TyVar], [Inst], TcDictBinds) +-- The returned [TyVar] are all ready to quantify + generalise dflags top_lvl bind_list sig_fn mono_infos lie_req | isMonoGroup dflags bind_list - = do { extendLIEs lie_req; return ([], emptyBag, []) } + = do { extendLIEs lie_req + ; return ([], [], emptyBag) } | isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE = -- Check signature contexts are empty @@ -702,27 +704,28 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req -- Check that signature type variables are OK ; final_qtvs <- checkSigsTyVars qtvs sigs - ; return (final_qtvs, binds, []) } + ; return (final_qtvs, [], binds) } | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS = tcSimplifyInfer doc tau_tvs lie_req | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS - = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty; sig_lie is zonked ; let -- The "sig_avails" is the stuff available. We get that from -- the context of the type signature, BUT ALSO the lie_avail -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] sig_avails = sig_lie ++ local_meths + loc = sig_loc (head sigs) -- Check that the needed dicts can be -- expressed in terms of the signature ones - ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req + ; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req -- Check that signature type variables are OK - ; final_qtvs <- checkSigsTyVars forall_tvs sigs + ; final_qtvs <- checkSigsTyVars qtvs sigs - ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } + ; returnM (final_qtvs, sig_lie, binds) } where bndrs = bndrNames mono_infos sigs = [sig | (_, Just sig, _) <- mono_infos] @@ -734,7 +737,8 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_loc = loc }) mono_id - = Method mono_id poly_id (mkTyVarTys tvs) theta loc + = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs, + tci_theta = theta, tci_loc = loc} \end{code} unifyCtxts checks that all the signature contexts are the same @@ -751,14 +755,16 @@ might not otherwise be related. This is a rather subtle issue. \begin{code} unifyCtxts :: [TcSigInfo] -> TcM [Inst] +-- Post-condition: the returned Insts are full zonked unifyCtxts (sig1 : sigs) -- Argument is always non-empty = do { mapM unify_ctxt sigs - ; newDictBndrs (sig_loc sig1) (sig_theta sig1) } + ; theta <- zonkTcThetaType (sig_theta sig1) + ; newDictBndrs (sig_loc sig1) theta } where theta1 = sig_theta sig1 unify_ctxt :: TcSigInfo -> TcM () unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + = setSrcSpan (instLocSpan (sig_loc sig)) $ addErrCtxt (sigContextsCtxt sig1 sig) $ unifyTheta theta1 theta @@ -821,7 +827,7 @@ checkDistinctTyVars sig_tvs <+> quotes (ppr tidy_tv2) ; failWithTcM (env2, msg) } where -\end{code} +\end{code} @getTyVarsToGen@ decides what type variables to generalise over. @@ -1057,8 +1063,7 @@ tcInstSig use_skols name scoped_names = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into -- scope when starting the binding group ; let skol_info = SigSkol (FunSigCtxt name) - inst_tyvars | use_skols = tcInstSkolTyVars skol_info - | otherwise = tcInstSigTyVars skol_info + inst_tyvars = tcInstSigTyVars use_skols skol_info ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id,