Commit ad4a18b1 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

towards newtype deriving dicts

Mon Sep 18 14:27:57 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * towards newtype deriving dicts
  Sat Aug  5 21:21:13 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * towards newtype deriving dicts
    Fri Jul  7 09:26:44 EDT 2006  kevind@bu.edu
parent c94408e5
......@@ -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,
......
......@@ -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)
......
......@@ -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
......
......@@ -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))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment