import Generics ( mkTyConGenericBinds )
import TcRnMonad
+import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type ( zipOpenTvSubst, substTheta )
+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 (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
- addErrCtxt (derivCtxt Nothing tycon) $
+ addErrCtxt (derivCtxt tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
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)) $
- addErrCtxt (derivCtxt (Just clas) tc) $
- tcSimplifyDeriv tc tyvars deriv_rhs `thenM` \ theta ->
- returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
+ = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
+ ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
+ tcSimplifyDeriv tc tyvars deriv_rhs
+ ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
+ checkValidInstance tyvars theta clas inst_tys
+ ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction
+ where
+
------------------------------------------------------------------
mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
\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 :: Maybe Class -> TyCon -> SDoc
-derivCtxt maybe_cls tycon
- = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
- where
- cls = case maybe_cls of
- Nothing -> ptext SLIT("instances")
- Just c -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
+derivCtxt :: TyCon -> SDoc
+derivCtxt tycon
+ = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
+
+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