X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=4e40be31b91d71fda93d05334c07670c711d285e;hp=571cd7010430599119781e722344ef252dc1549e;hb=b10d7d079ec9c3fc22d4700fe484dd297bddb805;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 571cd70..4e40be3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -12,6 +12,7 @@ import HsSyn import TcBinds import TcTyClsDecls import TcClassDcl +import TcPat( addInlinePrags ) import TcRnMonad import TcMType import TcType @@ -19,6 +20,7 @@ import Inst import InstEnv import FamInst import FamInstEnv +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import TcDeriv import TcEnv import RnSource ( addTcgDUs ) @@ -31,7 +33,6 @@ import TyCon import DataCon import Class import Var -import VarSet ( emptyVarSet ) import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var) ) @@ -636,7 +637,7 @@ tc_inst_decl2 dfun_id inst_binds mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts) -- NOT FINISHED! - ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet + ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol inst_tyvars' dfun_ev_vars $ emitWanteds ScOrigin sc_eqs @@ -705,7 +706,7 @@ tcSuperClass tyvars dicts self_ev_bind@(EvBind self_dict _) (sc_sel, sc_pred) = do { (ev_binds, wanted, sc_dict) - <- newImplication InstSkol emptyVarSet tyvars dicts $ + <- newImplication InstSkol tyvars dicts $ emitWanted ScOrigin sc_pred ; simplifySuperClass self_dict wanted @@ -787,7 +788,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; let spec_ty = mkSigmaTy tyvars theta tau ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) (idType dfun_id) spec_ty - ; return (SpecPrag co_fn defaultInlinePragma) } + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) @@ -834,18 +835,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) tc_body sel_id generated_code rn_bind - = add_meth_ctxt generated_code rn_bind $ + = add_meth_ctxt sel_id generated_code rn_bind $ do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True - meth_id (prag_fn (idName sel_id)) - + ; let prags = prag_fn (idName sel_id) + ; meth_id1 <- addInlinePrags meth_id prags + ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol - tyvars dfun_ev_vars - mb_dict_ev - meth_id1 local_meth_id - meth_sig_fn - (SpecPrags (spec_inst_prags ++ spec_prags)) + tyvars dfun_ev_vars mb_dict_ev + meth_id1 local_meth_id meth_sig_fn + (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } @@ -895,7 +894,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id - , SpecPrags spec_inst_prags)] + , mk_meth_spec_prags meth_id1 [])] , abs_ev_binds = EvBinds (unitBag self_dict_ev) , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own @@ -906,6 +905,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, L loc bind) } ---------------------- + mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the SPECIALISE pragmas to work for this method Id + -- There are two sources: + -- * spec_inst_prags: {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + mk_meth_spec_prags meth_id spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ + [ L loc (SpecPrag meth_id wrap inl) + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + loc = getSrcSpan dfun_id meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig" -- But there are no scoped type variables from local_method_id @@ -924,8 +935,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error -- because otherwise the user won't see the code at all - add_meth_ctxt generated_code rn_bind thing - | generated_code = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing + add_meth_ctxt sel_id generated_code rn_bind thing + | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing | otherwise = thing @@ -958,7 +969,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- by the constraint solver, since the may be -- user-specified. - = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $ + = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $ emitWanted ScOrigin rep_pred ; mapAndUnzipM (tc_item rep_d_stuff) op_items } @@ -1026,11 +1037,15 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id wrapId :: HsWrapper -> id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar id) -derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc -derivBindCtxt clas tys bind - = vcat [ ptext (sLit "When typechecking a standalone-derived method for") - <+> quotes (pprClassPred clas tys) <> colon - , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] +derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc +derivBindCtxt sel_id clas tys _bind + = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id) + , nest 2 (ptext (sLit "in a standalone derived instance for") + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] + +-- Too voluminous +-- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id