X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=91729b8b5fcf577a5e9c99f479f811f1a6387175;hb=8edd38dc3555b851ef2a724e69cf997b35bb16c1;hp=2e5dc6bdb45ad2e644f99867658d6e087b9f854f;hpb=b768e242a4934facfd73f24dacd7ef854f85211d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 2e5dc6b..91729b8 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -32,24 +32,23 @@ import TcRnMonad ( thenM, returnM, mapAndUnzipM ) import HscTypes ( DFunId ) import BasicTypes ( NewOrData(..) ) -import Class ( className, classKey, classTyVars, classSCTheta, Class ) +import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) import Subst ( mkTyVarSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) -import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon ) +import DataCon ( dataConRepArgTys, dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) import Maybes ( maybeToBool, catMaybes ) import Name ( Name, getSrcLoc, nameUnique ) import NameSet import RdrName ( RdrName ) -import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep, +import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe, isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, - tcEqTypes, mkAppTys ) -import Type ( splitAppTys ) + tcEqTypes, tcSplitAppTys, mkAppTys ) import Var ( TyVar, tyVarKind ) import VarSet ( mkVarSet, subVarSet ) import PrelNames @@ -348,7 +347,7 @@ makeDerivEqns tycl_decls constraints = extra_constraints ++ [ mkClassPred clas [arg_ty] | data_con <- tyConDataCons tycon, - arg_ty <- dataConRepArgTys data_con, + arg_ty <- dataConRepArgTys data_con, -- dataConOrigArgTys??? -- Use the same type variables -- as the type constructor, -- hence no need to instantiate @@ -362,6 +361,7 @@ makeDerivEqns tycl_decls = doptM Opt_GlasgowExts `thenM` \ gla_exts -> if can_derive_via_isomorphism && (gla_exts || standard_instance) then -- Go ahead and use the isomorphism + traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` new_dfun_name clas tycon `thenM` \ dfun_name -> returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name, iBinds = NewTypeDerived rep_tys })) @@ -394,8 +394,18 @@ makeDerivEqns tycl_decls -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s) - (tyvars, rep_ty) = newTyConRep tycon - (rep_fn, rep_ty_args) = splitAppTys rep_ty + -- Note [newtype representation] + -- We must not use newTyConRep to get the representation + -- type, because that looks through all intermediate newtypes + -- To get the RHS of *this* newtype, just look at the data + -- constructor. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + tyvars = tyConTyVars tycon + rep_ty = head (dataConOrigArgTys (head (tyConDataCons tycon))) + (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty n_tyvars_to_keep = tyConArity tycon - n_args_to_drop tyvars_to_drop = drop n_tyvars_to_keep tyvars @@ -449,6 +459,9 @@ makeDerivEqns tycl_decls can_derive_via_isomorphism = not (clas `hasKey` readClassKey) -- Never derive Read,Show this way && not (clas `hasKey` showClassKey) + && length tys + 1 == classArity clas -- Well kinded; + -- eg not: newtype T ... deriving( ST ) + -- because ST needs *2* type params && n_tyvars_to_keep >= 0 -- Well kinded; -- eg not: newtype T = T Int deriving( Monad ) && n_args_to_keep >= 0 -- Well kinded: @@ -468,9 +481,8 @@ makeDerivEqns tycl_decls cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep (vcat [ptext SLIT("too hard for cunning newtype deriving"), - ppr n_tyvars_to_keep, - ppr n_args_to_keep, - ppr eta_ok, + ptext SLIT("debug info:") <+> ppr n_tyvars_to_keep <+> + ppr n_args_to_keep <+> ppr eta_ok <+> ppr (isRecursiveTyCon tycon) ]) @@ -479,7 +491,7 @@ makeDerivEqns tycl_decls ------------------------------------------------------------------ chk_out :: Class -> TyCon -> [TcType] -> Maybe SDoc chk_out clas tycon tys - | notNull tys = Just non_std_why + | notNull tys = Just ty_args_why | not (getUnique clas `elem` derivableClassKeys) = Just non_std_why | clas `hasKey` enumClassKey && not is_enumeration = Just nullary_why | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why @@ -493,11 +505,14 @@ makeDerivEqns tycl_decls is_single_con = maybeToBool (maybeTyConSingleCon tycon) is_enumeration_or_single = is_enumeration || is_single_con - single_nullary_why = ptext SLIT("one constructor data type or type with all nullary constructors expected") - nullary_why = ptext SLIT("data type with all nullary constructors expected") - no_cons_why = ptext SLIT("type has no data constructors") - non_std_why = ptext SLIT("not a derivable class") - existential_why = ptext SLIT("it has existentially-quantified constructor(s)") + single_nullary_why = ptext SLIT("one constructor data type or type with all nullary constructors expected") + nullary_why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors") + no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors") + ty_args_why = quotes (ppr pred) <+> ptext SLIT("is not a class") + non_std_why = quotes (ppr clas) <+> ptext SLIT("is not a derivable class") + existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)") + + pred = mkClassPred clas tys new_dfun_name clas tycon -- Just a simple wrapper = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)