From 63c79c1d87a235808c3efcb4983eb5411572b6d3 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:21:26 +0000 Subject: [PATCH] Fix newtype deriving bug Mon Sep 18 17:22:43 EDT 2006 Manuel M T Chakravarty * Fix newtype deriving bug Sun Aug 6 21:02:35 EDT 2006 Manuel M T Chakravarty * Fix newtype deriving bug Fri Aug 4 06:45:21 EDT 2006 kevind@bu.edu --- compiler/typecheck/TcInstDcls.lhs | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 2db9bab..ea26254 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -26,12 +26,13 @@ import TcEnv ( InstInfo(..), InstBindings(..), import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifySuperClasses ) -import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy ) -import Coercion ( mkAppCoercion, mkAppsCoercion, mkSymCoercion ) -import TyCon ( TyCon, newTyConCo ) +import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, + splitFunTys ) +import Coercion ( mkSymCoercion ) +import TyCon ( TyCon, newTyConCo, tyConTyVars ) import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys ) import Class ( classBigSig ) -import Var ( TyVar, Id, idName, idType ) +import Var ( TyVar, Id, idName, idType, tyVarKind ) import Id ( mkSysLocal ) import UniqSupply ( uniqsFromSupply, splitUniqSupply ) import MkId ( mkDictFunId ) @@ -348,8 +349,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, -- arguments built by NewTypeDerived in TcDeriv.) wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids) - - coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id) + + -- we need to find the kind that this class applies to + -- and drop trailing tvs appropriately + cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon))) + the_tvs = drop_tail (length (fst (splitFunTys cls_kind))) tvs + + coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id) body | null sc_dict_ids = coerced_rep_dict | otherwise = HsCase (noLoc coerced_rep_dict) $ @@ -383,14 +389,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, dict = mkHsCoerce wrap_fn body ; 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) - (mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs)))) - | otherwise - = idCoercion + -- For newtype T a = MkT + -- The returned coercion has kind :: C (T a):=:C + co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo tycon + = ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++ + [mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))])) + | otherwise + = idCoercion + drop_tail n l = take (length l - n) l ------------------------ -- Ordinary instances -- 1.7.10.4