From 83f16ade9edf272c88c6b2ed8b8e951b905fe130 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 12 Apr 2011 18:02:08 +0100 Subject: [PATCH] Adapt mkGenericDefMethBind to the new generics --- compiler/typecheck/TcClassDcl.lhs | 36 +++++++----------------------------- compiler/typecheck/TcInstDcls.lhs | 5 +++-- 2 files changed, 10 insertions(+), 31 deletions(-) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 62a3da8..36bef11 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -361,42 +361,20 @@ gives rise to the instance declarations op Unit = ... \begin{code} -mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name) -mkGenericDefMethBind clas inst_tys sel_id +mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) +mkGenericDefMethBind clas inst_tys sel_id dm_name = -- A generic default method - -- If the method is defined generically, we can only do the job if the - -- instance declaration is for a single-parameter type class with - -- a type constructor applied to type arguments in the instance decl - -- (checkTc, so False provokes the error) - do { checkTc (isJust maybe_tycon) - (badGenericInstance sel_id (notSimple inst_tys)) - ; checkTc (tyConHasGenerics tycon) - (badGenericInstance sel_id (notGeneric tycon)) - - ; dflags <- getDOpts + -- If the method is defined generically, we only have to call the + -- dm_name. + do { dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - -- Rename it before returning it - ; (rn_rhs, _) <- rnLExpr rhs ; return (noLoc $ mkFunBind (noLoc (idName sel_id)) - [mkSimpleMatch [] rn_rhs]) } + [mkSimpleMatch [] rhs]) } where - rhs = mkGenericRhs sel_id clas_tyvar tycon - - -- The tycon is only used in the generic case, and in that - -- case we require that the instance decl is for a single-parameter - -- type class with type variable arguments: - -- instance (...) => C (T a b) - clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas) - Just tycon = maybe_tycon - maybe_tycon = case inst_tys of - [ty] -> case tcSplitTyConApp_maybe ty of - Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon - _ -> Nothing - _ -> Nothing - + rhs = nlHsVar dm_name --------------------------- getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 0ffc466..68b9106 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -924,8 +924,9 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) - -- JPM: This is probably not that simple... - tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name) + tc_default sel_id (GenDefMeth dm_name) + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name + ; tc_body sel_id False {- Not generated code? -} meth_bind } {- tc_default sel_id GenDefMeth -- Derivable type classes stuff = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id -- 1.7.10.4