import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
+import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
import NameSet ( duDefs )
-import Kind ( splitKindFunTys )
+import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
- isEnumerationTyCon, isRecursiveTyCon, TyCon
+ isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfType,
- isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
+ isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
[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 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
-> [LTyClDecl Name]
mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
------------------------------------------------------------------
+ -- data/newtype T a = ... deriving( C t1 t2 )
+ -- leads to a call to mk_eqn_help with
+ -- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
+
mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
| Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
= bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
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 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 isomprphism; 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)
-- If there are no tyvars, there's no need
-- to abstract over the dictionaries we need
dict_tvs = deriv_tvs ++ tc_tvs
- dict_args | null dict_tvs = []
+ dict_args -- | null dict_tvs = []
| otherwise = rep_pred : sc_theta
-- Finally! Here's where we build the dictionary Id
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
- arg_ty <- dataConOrigArgTys data_con,
+ arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
-- (b) 7 or fewer args
cond_typeableOK (gla_exts, tycon)
| tyConArity tycon > 7 = Just too_many
- | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+ | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
| otherwise = Nothing
where
too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
gen_soln (_, clas, tc,tyvars,deriv_rhs)
= setSrcSpan (srcLocSpan (getSrcLoc tc)) $
do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
- ; theta <- addErrCtxt (derivInstCtxt [] clas inst_tys) $
+ ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
tcSimplifyDeriv tc tyvars deriv_rhs
- ; addErrCtxt (derivInstCtxt theta clas inst_tys) $
+ ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction
where
\begin{code}
derivingThingErr clas tys tycon tyvars why
= sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
- parens why]
+ nest 2 (parens why)]
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
derivCtxt tycon
= ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
-derivInstCtxt theta clas inst_tys
- = hang (ptext SLIT("In the derived instance"))
- 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, pprClassPred clas inst_tys])
+derivInstCtxt1 clas inst_tys
+ = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys)
+
+derivInstCtxt2 theta clas inst_tys
+ = vcat [ptext SLIT("In the derived instance declaration"),
+ nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
+ pprClassPred clas inst_tys])]
\end{code}
projects / ghc-hetmet.git / blobdiff