X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=2563b0979dcf9b116e297244868e27d88f3f658d;hp=95d9697c0c67f716b970a85add2b890e733fd918;hb=5e0ea427646a5474dd7c659b0713c6a62d8c99c7;hpb=7f0ce617a0380339da927433dc816e45704db0be diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 95d9697..2563b09 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -31,22 +31,22 @@ import RnEnv ( bindLocalNames ) import HscTypes ( FixityEnv ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) -import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred ) +import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) -import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys ) +import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys ) import Maybes ( catMaybes ) import RdrName ( RdrName ) import Name ( Name, getSrcLoc ) import NameSet ( duDefs ) -import Kind ( splitKindFunTys ) +import Type ( splitKindFunTys ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs, - isEnumerationTyCon, isRecursiveTyCon, TyCon + isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, isUnLiftedType, mkClassPred, tyVarsOfType, - isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys ) + isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys ) import Var ( TyVar, tyVarKind, varName ) import VarSet ( mkVarSet, subVarSet ) import PrelNames @@ -313,6 +313,29 @@ or} has just one data constructor (e.g., tuples). [See Appendix~E in the Haskell~1.2 report.] This code here deals w/ all those. +Note [Newtype deriving superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The 'tys' here come from the partial application +in the deriving clause. The last arg is the new +instance type. + +We must pass the superclasses; the newtype might be an instance +of them in a different way than the representation type +E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) +Then the Show instance is not done via isomorphism; it shows + Foo 3 as "Foo 3" +The Num instance is derived via isomorphism, but the Show superclass +dictionary must the Show instance for Foo, *not* the Show dictionary +gotten from the Num dictionary. So we must build a whole new dictionary +not just use the Num one. The instance we want is something like: + instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where + (+) = ((+)@a) + ...etc... +There may be a coercion needed which we get from the tycon for the newtype +when the dict is constructed in TcInstDcls.tcInstDecl2 + + \begin{code} makeDerivEqns :: OverlapFlag -> [LTyClDecl Name] @@ -350,6 +373,10 @@ makeDerivEqns overlap_flag tycl_decls mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys ------------------------------------------------------------------ + -- data/newtype T a = ... deriving( C t1 t2 ) + -- leads to a call to mk_eqn_help with + -- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2] + mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err) @@ -363,7 +390,7 @@ makeDerivEqns overlap_flag tycl_decls traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` new_dfun_name clas tycon `thenM` \ dfun_name -> returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, - iBinds = NewTypeDerived rep_tys })) + iBinds = NewTypeDerived tycon rep_tys })) | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route @@ -425,26 +452,11 @@ makeDerivEqns overlap_flag tycl_decls rep_pred = mkClassPred clas rep_tys -- rep_pred is the representation dictionary, from where -- we are gong to get all the methods for the newtype dictionary + -- here we are figuring out what superclass dictionaries to use + -- see Note [Newtype deriving superclasses] above inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)]) - -- The 'tys' here come from the partial application - -- in the deriving clause. The last arg is the new - -- instance type. - - -- We must pass the superclasses; the newtype might be an instance - -- of them in a different way than the representation type - -- E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) - -- Then the Show instance is not done via isomprphism; it shows - -- Foo 3 as "Foo 3" - -- The Num instance is derived via isomorphism, but the Show superclass - -- dictionary must the Show instance for Foo, *not* the Show dictionary - -- gotten from the Num dictionary. So we must build a whole new dictionary - -- not just use the Num one. The instance we want is something like: - -- instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where - -- (+) = ((+)@a) - -- ...etc... - -- There's no 'corece' needed because after the type checker newtypes - -- are transparent. + sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys) (classSCTheta clas) @@ -452,7 +464,7 @@ makeDerivEqns overlap_flag tycl_decls -- If there are no tyvars, there's no need -- to abstract over the dictionaries we need dict_tvs = deriv_tvs ++ tc_tvs - dict_args | null dict_tvs = [] + dict_args -- | null dict_tvs = [] | otherwise = rep_pred : sc_theta -- Finally! Here's where we build the dictionary Id @@ -568,7 +580,7 @@ mkDataTypeEqn tycon clas ordinary_constraints = [ mkClassPred clas [arg_ty] | data_con <- tyConDataCons tycon, - arg_ty <- dataConOrigArgTys data_con, + arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)), not (isUnLiftedType arg_ty) -- No constraints for unlifted types? ] @@ -649,7 +661,7 @@ cond_typeableOK :: Condition -- (b) 7 or fewer args cond_typeableOK (gla_exts, tycon) | tyConArity tycon > 7 = Just too_many - | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind + | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind | otherwise = Nothing where too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments") @@ -729,9 +741,9 @@ solveDerivEqns overlap_flag orig_eqns gen_soln (_, clas, tc,tyvars,deriv_rhs) = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)] - ; theta <- addErrCtxt (derivInstCtxt [] clas inst_tys) $ + ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $ tcSimplifyDeriv tc tyvars deriv_rhs - ; addErrCtxt (derivInstCtxt theta clas inst_tys) $ + ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $ checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction where @@ -952,7 +964,7 @@ genTaggeryBinds infos \begin{code} derivingThingErr clas tys tycon tyvars why = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)], - parens why] + nest 2 (parens why)] where pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)]) @@ -960,8 +972,12 @@ derivCtxt :: TyCon -> SDoc derivCtxt tycon = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon) -derivInstCtxt theta clas inst_tys - = hang (ptext SLIT("In the derived instance")) - 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, pprClassPred clas inst_tys]) +derivInstCtxt1 clas inst_tys + = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys) + +derivInstCtxt2 theta clas inst_tys + = vcat [ptext SLIT("In the derived instance declaration"), + nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, + pprClassPred clas inst_tys])] \end{code}