From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 16:53:48 +0000 (+0000) Subject: towards newtype deriving dicts X-Git-Tag: After_FC_branch_merge~92 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ad4a18b179fbe4ad314b3accf32e806cf00f2a0b towards newtype deriving dicts Mon Sep 18 14:27:57 EDT 2006 Manuel M T Chakravarty * towards newtype deriving dicts Sat Aug 5 21:21:13 EDT 2006 Manuel M T Chakravarty * towards newtype deriving dicts Fri Jul 7 09:26:44 EDT 2006 kevind@bu.edu --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index d1d7a02..d36c94e 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -316,7 +316,7 @@ mkDataConIds wrap_name wkr_name data_con Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed - -> case splitProductType "do_unbox" (idType arg) of + ->case splitProductType "do_unbox" (idType arg) of (tycon, tycon_args, con, tys) -> Case (Var arg) arg result_ty [(DataAlt con, diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index fdf78cf..b777968 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -314,6 +314,28 @@ 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's no 'corece' needed because after the type checker newtypes +are transparent. + \begin{code} makeDerivEqns :: OverlapFlag -> [LTyClDecl Name] @@ -368,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 (newTyConCo tycon) 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 @@ -430,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 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's no 'corece' needed because after the type checker newtypes - -- are transparent. + sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys) (classSCTheta clas) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 936ec5b..b3e0d7f 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -566,7 +566,7 @@ data InstBindings -- specialised instances | NewTypeDerived - (Maybe TyCon) -- maybe a coercion for the newtype + TyCon -- tycon for the newtype -- Used for deriving instances of newtypes, where the [Type] -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3e55844..50640a3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -305,9 +305,13 @@ First comes the easy case of a non-local instance decl. tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -- Returns a binding for the dfun - ** Explain superclass stuff *** - +-- -- Derived newtype instances +-- +-- We need to make a copy of the dictionary we are deriving from +-- because we may need to change some of the superclass dictionaries +-- see Note [Newtype deriving superclasses] in TcDeriv.lhs +-- -- In the case of a newtype, things are rather easy -- class Show a => Foo a b where ... -- newtype T a = MkT (Tree [a]) deriving( Foo Int ) @@ -316,23 +320,35 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -- -- So all need is to generate a binding looking like -- dfunFooT :: forall a. (Show (T a), Foo Int (Tree [a]) => Foo Int (T a) --- dfunFooT = /\a. \(ds:Show (T a) (df:Foo (Tree [a])). +-- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])). -- case df `cast` (Foo Int (CoT a)) of -- Foo _ op1 .. opn -> Foo ds op1 .. opn tcInstDecl2 (InstInfo { iSpec = ispec, - iBinds = NewTypeDerived rep_tys }) - = do { let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id - origin = SigOrigin rigid_info - inst_ty = idType dfun_id + iBinds = NewTypeDerived tycon rep_tys }) + = do { let dfun_id = instanceDFunId ispec + rigid_info = InstSkol dfun_id + origin = SigOrigin rigid_info + inst_ty = idType dfun_id + maybe_co_con = newTyConCo tycon ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty - ; ASSERT( isSingleton theta ) -- Always the case for NewTypeDerived - rep_dict <- newDict origin (head theta) - - ; let rep_dict_id = instToId rep_dict - cast = - co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast + ; rep_dict <- newDict origin (head theta) + ; if isSingleton theta then + return (unitBag (VarBind dfun_id $ + case maybe_co_con of + Nothing -> rep_dict + Just co_con -> mkCoerce rep_dict $ + mkAppCoercion (mkAppsCoercion tycon rep_tys) + (mkTyConApp co_con tvs))) + else do + let rep_dict_id = instToId rep_dict + coerced_dict = case maybe_co_con of + Nothing -> rep_dict_id + Just co_con -> mkCoerce rep_dict_id $ + mkAppCoercion (mkAppsCoercion tycon rep_tys) + (mkTyConApp co_con tvs) + ; return (unitBag (VarBind dfun_id + co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast ; return (unitBag (VarBind dfun_id (HsCoerce co_fn (HsVar rep_dict_id))))