X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=479bd670be57296dd9ee7dd03c1c7e7f42887b3e;hb=ee2571bd2a80683d33cf65a01942bc8be50a5e33;hp=74879f39b01b736d24758b14162cd4dd26992a92;hpb=4bc25e8c30559b7a6a87b39afcc79340ae778788;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 74879f3..479bd67 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -22,13 +22,13 @@ import FamInstEnv import TcDeriv import TcEnv import RnEnv ( lookupGlobalOccRn ) +import RnSource ( addTcgDUs ) import TcHsType import TcUnify import TcSimplify import Type import Coercion import TyCon -import TypeRep import DataCon import Class import Var @@ -339,9 +339,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- a) local instance decls -- b) generic instances -- c) local family instance decls - ; addInsts local_info $ do { - ; addInsts generic_inst_info $ do { - ; addFamInsts at_idx_tycons $ do { + ; addInsts local_info $ + addInsts generic_inst_info $ + addFamInsts at_idx_tycons $ do { -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance @@ -351,13 +351,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, becuase that may give -- more errors still - ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls - deriv_decls + ; (deriv_inst_info, deriv_binds, deriv_dus) + <- tcDeriving tycl_decls inst_decls deriv_decls ; gbl_env <- addInsts deriv_inst_info getGblEnv - ; return (gbl_env, + ; return ( addTcgDUs gbl_env deriv_dus, generic_inst_info ++ deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) - }}}}} + }}} where -- Make sure that toplevel type instance are not for associated types. -- !!!TODO: Need to perform this check for the TyThing of type functions, @@ -432,7 +432,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ispec = mkLocalInstance dfun overlap_flag ; return (InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }, + iBinds = VanillaInst binds uprags False }, idx_tycons) } where @@ -600,9 +600,10 @@ tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id) -- see Note [Newtype deriving superclasses] in TcDeriv.lhs tc_inst_decl2 dfun_id (NewTypeDerived coi) - = do { let rigid_info = InstSkol - origin = SigOrigin rigid_info - inst_ty = idType dfun_id + = do { let rigid_info = InstSkol + origin = SigOrigin rigid_info + inst_ty = idType dfun_id + inst_tvs = fst (tcSplitForAllTys inst_ty) ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty -- inst_head_ty is a PredType @@ -615,7 +616,13 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) (rep_ty, wrapper) = case coi of IdCo -> (last_ty, idHsWrapper) - ACo co -> (snd (coercionKind co), WpCast (mk_full_coercion co)) + ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co')) + where + co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co + -- NB: the free variable of coi are bound by the + -- universally quantified variables of the dfun_id + -- This is weird, and maybe we should make NewTypeDerived + -- carry a type-variable list too; but it works fine ----------------------- -- mk_full_coercion @@ -698,7 +705,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) ------------------------ -- Ordinary instances -tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) +tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) = do { let rigid_info = InstSkol inst_ty = idType dfun_id @@ -730,13 +737,13 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities prag_fn = mkPragFun uprags loc = getSrcSpan dfun_id - tc_meth = tcInstanceMethod loc clas inst_tyvars' - dfun_dicts + tc_meth = tcInstanceMethod loc standalone_deriv + clas inst_tyvars' dfun_dicts dfun_theta' inst_tys' this_dict dfun_id prag_fn monobinds ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ - mapAndUnzipM tc_meth op_items + mapAndUnzipM tc_meth op_items -- Figure out bindings for the superclass context -- Don't include this_dict in the 'givens', else @@ -814,7 +821,7 @@ tcInstanceMethod - Use tcValBinds to do the checking \begin{code} -tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst] +tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst] -> TcThetaType -> [TcType] -> Inst -> Id -> TcPragFun -> LHsBinds Name @@ -823,7 +830,7 @@ tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst] -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys +tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys this_dict dfun_id prag_fn binds_in (sel_id, dm_info) = do { cloned_this <- cloneDict this_dict -- Need to clone the dict in case it is floated out, and @@ -838,12 +845,14 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys -- involved; otherwise overlap is not possible -- See Note [Subtle interaction of recursion and overlap] - tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody + tc_body rn_bind + = add_meth_ctxt rn_bind $ + do { (meth_id, tc_binds) <- tcInstanceMethodBody InstSkol clas tyvars dfun_dicts theta inst_tys mb_this_bind sel_id local_meth_name meth_sig_fn meth_prag_fn rn_bind - ; return (wrapId meth_wrapper meth_id, tc_binds) } + ; return (wrapId meth_wrapper meth_id, tc_binds) } ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of -- There is a user-supplied method binding, so use it @@ -859,7 +868,7 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys (Nothing, NoDefMeth) -> do -- No default method in the class { warn <- doptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods - && reportIfUnused (getOccName sel_id)) + && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods omitted_meth_warn ; return (error_rhs, emptyBag) } @@ -901,9 +910,21 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys dfun_lam_vars = map instToVar dfun_dicts meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) + -- 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 rn_bind thing + | standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing + | otherwise = thing 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 ] \end{code} Note [Default methods in instances]