From e6e3c778b0723dd98842f223576dbef4d8ec57a1 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 16:57:46 +0000 Subject: [PATCH] newtype deriving still not working Mon Sep 18 14:31:59 EDT 2006 Manuel M T Chakravarty * newtype deriving still not working Sat Aug 5 21:25:43 EDT 2006 Manuel M T Chakravarty * newtype deriving still not working Mon Jul 10 10:27:20 EDT 2006 kevind@bu.edu --- compiler/typecheck/Inst.lhs | 2 +- compiler/typecheck/TcDeriv.lhs | 5 +++-- compiler/typecheck/TcInstDcls.lhs | 29 ++++++++++++++++++----------- 3 files changed, 22 insertions(+), 14 deletions(-) diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 98fe3e9..cc91be8 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -76,7 +76,7 @@ import HscTypes ( ExternalPackageState(..), HscEnv(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon, dataConStupidTheta, dataConName, dataConWrapId, dataConUnivTyVars ) -import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) +import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule, isInternalName, setNameUnique ) import NameSet ( addOneToNameSet ) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index b777968..857999b 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -333,8 +333,9 @@ 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. +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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index a1ea0dd..7b1c132 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -338,36 +338,43 @@ tcInstDecl2 (InstInfo { iSpec = ispec, ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty ; dicts <- newDicts origin theta ; uniqs <- newUniqueSupply - ; let (rep_dict_id:sc_dict_ids) = map instToId dicts + ; let (cls, op_tys) = tcSplitDFunHead inst_head + ; [this_dict] <- newDicts origin [mkClassPred cls op_tys] + ; let (rep_dict_id:sc_dict_ids) = + if null dicts then + [instToId this_dict] + else + map instToId dicts + -- (Here, we are relying on the order of dictionary -- arguments built by NewTypeDerived in TcDeriv.) - wrap_fn = CoTyLams tvs <.> CoLams sc_dict_ids + wrap_fn | null dicts = idCoercion + | otherwise = CoTyLams tvs <.> CoLams sc_dict_ids - coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id) - mk_located a = L noSrcSpan a - body | null sc_dict_ids = coerced_rep_dict - | otherwise = HsCase (mk_located coerced_rep_dict) $ + coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id) + + body | null dicts || null sc_dict_ids = coerced_rep_dict + | otherwise = HsCase (noLoc coerced_rep_dict) $ MatchGroup [the_match] inst_head the_match = mkSimpleMatch [the_pat] the_rhs op_ids = zipWith (mkSysLocal FSLIT("op")) (uniqsFromSupply uniqs) op_tys - the_pat = mk_located $ ConPatOut { pat_con = mk_located cls_data_con, pat_tvs = [], + the_pat = noLoc $ ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [], pat_dicts = sc_dict_ids, pat_binds = emptyLHsBinds, pat_args = PrefixCon (map nlVarPat op_ids), pat_ty = inst_head } - (cls, op_tys) = tcSplitDFunHead inst_head cls_data_con = classDataCon cls cls_tycon = dataConTyCon cls_data_con the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids)) - - ; return (unitBag (mk_located $ VarBind (dfun_id) (mk_located (mkHsCoerce wrap_fn body)))) } + dict = (mkHsCoerce wrap_fn body) + ; pprTrace "built dict:" (ppr dict) $ return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) } where co_fn :: [TyVar] -> TyCon -> ExprCoFn co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon - = ExprCoFn (mkAppCoercion (mkAppsCoercion (mkTyConApp cls_tycon []) rep_tys) + = ExprCoFn (mkAppCoercion (mkTyConApp cls_tycon []) (mkTyConApp co_con (map mkTyVarTy tvs))) | otherwise = idCoercion -- 1.7.10.4