X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=479bd670be57296dd9ee7dd03c1c7e7f42887b3e;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=cf03e7116b838f1afacdef20d5b19e4d7be6052b;hpb=46f02d59813499ba2aa44e7831e0b69ec6d8f25d;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index cf03e71..479bd67 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -29,7 +29,6 @@ import TcSimplify import Type import Coercion import TyCon -import TypeRep import DataCon import Class import Var @@ -433,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 @@ -601,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 @@ -616,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 @@ -699,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 @@ -731,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 @@ -815,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 @@ -824,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 @@ -839,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 @@ -902,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]