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,
[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]
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
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)
-- 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
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 )
--
-- 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))))
projects / ghc-hetmet.git / commitdiff