From 4f597914955e1eeb08243f8b0743387703fc62b6 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 5 Sep 2008 17:26:54 +0000 Subject: [PATCH] Fix up the instance-declaration re-engineering story This patch deals with a rather complicated situation involving overlapping instances. It's all explained in the commments Note [Subtle interaction of recursion and overlap] The absence of this case make DoCon and regex-base fail with an error about overlapping instances. Now they work properly again. --- compiler/typecheck/TcInstDcls.lhs | 199 +++++++++++++++++++++++++++---------- 1 file changed, 149 insertions(+), 50 deletions(-) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index c8e4b46..193736d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -94,18 +94,27 @@ Running example: -- Here op1_i, op2_i are the "instance method Ids" {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in - -- Note [Tricky type variable scoping] + op1_i = /\a. \(d:C a). + let local_op1 :: forall a. (C a, C [a]) + => forall b. Ix b => [a] -> b -> b + -- Note [Subtle interaction of recursion and overlap] + local_op1 = + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in + -- Note [Tricky type variable scoping] + + in local_op1 a d (df_i a d) op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) -- The dictionary function itself {-# INLINE df_i #-} -- Always inline dictionary functions df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d) + df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d) + ($dmop2 [a] d') + in d' -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-nmethod call + -- We can't apply the type checker to the default-method call * The dictionary function itself is inlined as vigorously as we possibly can, so that we expose that dictionary constructor to @@ -130,6 +139,47 @@ Running example: inlined. We need to fix this somehow -- perhaps allowing inlining of INLINE funcitons inside other INLINE functions. +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + intance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be excecuting this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +call 'nullFail' just like the example above. The DoCon package also +does the same thing; it shows up in module Fraction.hs + +Conclusion: when typechecking the methods in a C [a] instance, we want +to have C [a] available. That is why we have the strange local let in +the definition of op1_i in the example above. We can typecheck the +defintion of local_op1, and then supply the "this" argument via an +explicit call to the dfun (which in turn will be inlined). + Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example @@ -478,7 +528,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ %* * -\subsection{Type-checking instance declarations, pass 2} + Type-checking instance declarations, pass 2 %* * %************************************************************************ @@ -565,7 +615,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) ; sc_binds <- addErrCtxt superClassCtxt $ tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) - ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict)) + ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) @@ -679,15 +729,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) tc_meth = tcInstanceMethod loc clas inst_tyvars' (dfun_covars ++ dfun_dict_ids) dfun_theta' inst_tys' - this_dict_id - monobinds prag_fn + this_dict_id dfun_id + prag_fn monobinds (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items -- Figure out bindings for the superclass context -- Don't include this_dict in the 'givens', else -- wanted_sc_insts get bound by just selecting from this_dict!! - sc_binds <- addErrCtxt superClassCtxt - (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts) + sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc dfun_insts + wanted_sc_insts + -- Note [Recursive superclasses] -- It's possible that the superclass stuff might unified one -- of the inst_tyavars' with something in the envt @@ -745,7 +797,20 @@ mkMetaCoVars = mapM eqPredToCoVar eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars" \end{code} +Note [Recursive superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #1470 for why we would *like* to add "this_dict" to the +available instances here. But we can't do so because then the superclases +get satisfied by selection from this_dict, and that leads to an immediate +loop. What we need is to add this_dict to Avails without adding its +superclasses, and we currently have no way to do that. + +%************************************************************************ +%* * + Type-checking an instance method +%* * +%************************************************************************ tcInstanceMethod - Make the method bindings, as a [(NonRec, HsBinds)], one per method @@ -757,50 +822,41 @@ tcInstanceMethod \begin{code} tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var] - -> TcThetaType -> [TcType] -> Id - -> LHsBinds Name -> TcPragFun + -> TcThetaType -> [TcType] + -> Id -> Id + -> TcPragFun -> LHsBinds Name -> (Id, DefMeth) -> TcM (HsExpr Id, LHsBinds Id) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id - binds_in prag_fn (sel_id, dm_info) +tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys + this_dict_id dfun_id + prag_fn binds_in (sel_id, dm_info) = do { uniq <- newUnique - ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) - rho_ty = ASSERT( length sel_tyvars == length inst_tys ) - substTyWith sel_tyvars inst_tys sel_rho - (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - -- The first predicate should be of form (C a b) - -- where C is the class in question - meth_ty = mkSigmaTy tyvars theta meth_tau - meth_name = mkInternalName uniq sel_occ loc -- Same OccName - meth_id = mkLocalId meth_name meth_ty - - ; MASSERT( case getClassPredTys_maybe first_pred of - { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) + ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName + tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys + this_dict_id dfun_id sel_id + prags local_meth_name - - ; case (findMethodBind sel_name meth_name binds_in, dm_info) of + ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of -- There is a user-supplied method binding, so use it - (Just user_bind, _) -> typecheck_meth meth_id user_bind + (Just user_bind, _) -> tc_body user_bind -- The user didn't supply a method binding, so we have to make -- up a default binding, in a way depending on the default-method info (Nothing, GenDefMeth) -> do -- Derivable type classes stuff - { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name - ; typecheck_meth meth_id meth_bind } + { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name + ; tc_body meth_bind } (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)) -- Don't warn about _foo methods - (omittedMethodWarn sel_id) - ; return (mk_error_rhs meth_tau, emptyBag) } + omitted_meth_warn + ; return (error_rhs, emptyBag) } (Nothing, DefMeth) -> do -- An polymorphic default method { -- Build the typechecked version directly, @@ -809,30 +865,73 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id dm_name <- lookupImportedName (mkDefMethRdrName sel_name) -- Might not be imported, but will be an OrigName ; dm_id <- tcLookupId dm_name - ; return (wrap dm_wrapper dm_id, emptyBag) } } + ; return (wrapId dm_wrapper dm_id, emptyBag) } } where sel_name = idName sel_id sel_occ = nameOccName sel_name - tv_names = map tyVarName tyvars prags = prag_fn sel_name - typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id) - typecheck_meth meth_id bind - = do { tc_binds <- tcMethodBind tv_names prags meth_id bind - ; return (wrap meth_wrapper meth_id, tc_binds) } - - mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg + error_rhs = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg + meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) - wrap wrapper id = mkHsWrap wrapper (HsVar id) - meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars) - dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys + dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys + + omitted_meth_warn :: SDoc + omitted_meth_warn = ptext (sLit "No explicit method nor default method for") + <+> quotes (ppr sel_id) + +--------------- +tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var] + -> TcThetaType -> [TcType] + -> Id -> Id -> Id + -> [LSig Name] -> Name -> LHsBind Name + -> TcM (HsExpr Id, LHsBinds Id) +tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys + this_dict_id dfun_id sel_id + prags local_meth_name bind@(L loc _) + = do { uniq <- newUnique + ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length sel_tyvars == length inst_tys ) + substTyWith sel_tyvars inst_tys sel_rho + + (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + meth_name = mkInternalName uniq (getOccName local_meth_name) loc + meth_ty = mkSigmaTy tyvars theta meth_tau + meth_id = mkLocalId meth_name meth_ty + + local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau + local_meth_id = mkLocalId local_meth_name local_meth_ty + + tv_names = map tyVarName tyvars + + -- The first predicate should be of form (C a b) + -- where C is the class in question + ; MASSERT( case getClassPredTys_maybe first_pred of + { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) + + ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind + + ; let full_bind = unitBag $ L loc $ + VarBind meth_id $ L loc $ + mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $ + HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $ + mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $ + wrapId meth_wrapper local_meth_id + this_dict_bind = unitBag $ L loc $ + VarBind this_dict_id $ L loc $ + wrapId meth_wrapper dfun_id + + ; return (wrapId meth_wrapper meth_id, full_bind) } + where + meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) -omittedMethodWarn :: Id -> SDoc -omittedMethodWarn sel_id - = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id) +wrapId :: HsWrapper -> id -> HsExpr id +wrapId wrapper id = mkHsWrap wrapper (HsVar id) \end{code} Note [Default methods in instances] -- 1.7.10.4