X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=fdf78cf0a4384b2c3810c3a505c8e963ba923e66;hb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;hp=1f4c4768d85fdefda7e374c799e8ed6c27d37f84;hpb=1dfd77341ec56e9d61f2d78cb7ff2b9900385dac;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1f4c476..fdf78cf 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -15,6 +15,7 @@ import DynFlags ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) import TcRnMonad +import TcMType ( checkValidInstance ) import TcEnv ( newDFunName, pprInstInfoDetails, InstInfo(..), InstBindings(..), simpleInstInfoClsTy, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv @@ -30,22 +31,23 @@ import RnEnv ( bindLocalNames ) 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, + newTyConCo ) 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 @@ -341,7 +343,7 @@ makeDerivEqns overlap_flag tycl_decls 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) -> @@ -349,6 +351,10 @@ makeDerivEqns overlap_flag tycl_decls 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) @@ -362,7 +368,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 rep_tys })) + iBinds = NewTypeDerived (newTyConCo tycon) rep_tys })) | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route @@ -433,7 +439,7 @@ makeDerivEqns overlap_flag tycl_decls -- 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 + -- 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 @@ -567,7 +573,7 @@ mkDataTypeEqn tycon clas 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? ] @@ -648,7 +654,7 @@ cond_typeableOK :: Condition -- (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") @@ -726,10 +732,15 @@ solveDerivEqns overlap_flag orig_eqns ------------------------------------------------------------------ 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 @@ -946,16 +957,20 @@ genTaggeryBinds infos \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}