X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=c35e2d64b2feff238af48adeb1c2399a80cff567;hb=cadba81047f6188fad2fe07004c3cb36316c36d1;hp=eab7748b53cc3475e39e0942726a1f787e7ea9e6;hpb=678086d0d26108713d1c361ab07d5ae12e24f363;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index eab7748..c35e2d6 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 @@ -637,8 +637,8 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) ; sc_dicts <- newDictBndrs sc_loc sc_theta' ; inst_loc <- getInstLoc origin ; dfun_dicts <- newDictBndrs inst_loc theta - ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) ; rep_dict <- newDictBndr inst_loc rep_pred + ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) -- Figure out bindings for the superclass context from dfun_dicts -- Don't include this_dict in the 'givens', else @@ -698,7 +698,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 @@ -716,11 +716,12 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) origin = SigOrigin rigid_info -- Create dictionary Ids from the specified instance contexts. - ; sc_loc <- getInstLoc InstScOrigin - ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted - ; inst_loc <- getInstLoc origin - ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities - ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + ; sc_loc <- getInstLoc InstScOrigin + ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + ; inst_loc <- getInstLoc origin + ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities + ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. @@ -729,8 +730,8 @@ 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 @@ -754,7 +755,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) -- Create the result bindings ; let dict_constr = classDataCon clas inline_prag | null dfun_dicts = [] - | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] + | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))] -- Always inline the dfun; this is an experimental decision -- because it makes a big performance difference sometimes. -- Often it means we can do the method selection, and then @@ -813,7 +814,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 @@ -822,7 +823,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 @@ -837,12 +838,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 @@ -858,7 +861,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) } @@ -900,9 +903,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]