X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=11ff67229845c05632984bb4ad8ac5e3aa519bee;hb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;hp=472ce6b94d3942ba706c186acbff3ea569ba2a05;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 472ce6b..11ff672 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -15,9 +15,10 @@ import DynFlags ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) import TcRnMonad +import TcMType ( checkValidInstance ) import TcEnv ( newDFunName, pprInstInfoDetails, InstInfo(..), InstBindings(..), simpleInstInfoClsTy, - tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv + tcLookupClass, tcLookupTyCon, tcLookupLocatedTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList ) @@ -30,26 +31,26 @@ 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, 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, + tyConStupidTheta, isProductTyCon, isDataTyCon, isNewTyCon, newTyConRhs, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, - isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind, - tcEqTypes, tcSplitAppTys, mkAppTys ) + isUnLiftedType, mkClassPred, tyVarsOfType, tyVarsOfTypes, + isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys ) import Var ( TyVar, tyVarKind, varName ) -import VarSet ( mkVarSet, subVarSet ) +import VarSet ( mkVarSet, disjointVarSet ) import PrelNames -import SrcLoc ( srcLocSpan, Located(..) ) +import SrcLoc ( srcLocSpan, Located(..), unLoc ) import Util ( zipWithEqual, sortLe, notNull ) import ListSetOps ( removeDups, assocMaybe ) import Outputable @@ -205,15 +206,17 @@ And then translate it to: \begin{code} tcDeriving :: [LTyClDecl Name] -- All type constructors + -> [LDerivDecl Name] -- All stand-alone deriving declarations -> TcM ([InstInfo], -- The generated "instance decls" HsValBinds Name) -- Extra generated top-level bindings -tcDeriving tycl_decls +tcDeriving tycl_decls deriv_decls = recoverM (returnM ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". overlap_flag <- getOverlapFlag - ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls + ; (ordinary_eqns, newtype_inst_info) + <- makeDerivEqns overlap_flag tycl_decls deriv_decls ; (ordinary_inst_info, deriv_binds) <- extendLocalInstEnv (map iSpec newtype_inst_info) $ @@ -312,15 +315,39 @@ 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 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] + -> [LDerivDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings -makeDerivEqns overlap_flag tycl_decls - = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) -> - returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) +makeDerivEqns overlap_flag tycl_decls deriv_decls + = do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes + (maybe_ordinaries, maybe_newtypes) + <- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level) + return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ derive_these :: [(NewOrData, Name, LHsType Name)] @@ -330,7 +357,15 @@ makeDerivEqns overlap_flag tycl_decls tcdDerivs = Just preds }) <- tycl_decls, pred <- preds ] + top_level_deriv :: LDerivDecl Name -> TcM (Maybe (NewOrData, Name, LHsType Name)) + top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $ + do tycon <- tcLookupLocatedTyCon ty_name + let new_or_data = if isNewTyCon tycon then NewType else DataType + traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst)) + return $ Just (new_or_data, unLoc ty_name, inst) + ------------------------------------------------------------------ + -- takes (whether newtype or data, name of data type, partially applied type class) mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) -- We swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation @@ -341,7 +376,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 +384,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) @@ -358,11 +397,11 @@ makeDerivEqns overlap_flag tycl_decls mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas) - = -- Go ahead and use the isomorphism - 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 })) + = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) + ; -- Go ahead and use the isomorphism + dfun_name <- new_dfun_name clas tycon + ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, + iBinds = NewTypeDerived ntd_info })) } | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route @@ -373,22 +412,32 @@ makeDerivEqns overlap_flag tycl_decls non_std_err) -- Just complain about being a non-std instance where -- Here is the plan for newtype derivings. We see - -- newtype T a1...an = T (t ak...an) deriving (.., C s1 .. sm, ...) + -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) -- where t is a type, - -- ak...an is a suffix of a1..an - -- ak...an do not occur free in t, + -- ak+1...an is a suffix of a1..an + -- ak+1...an do not occur free in t, nor in the s1..sm -- (C s1 ... sm) is a *partial applications* of class C -- with the last parameter missing + -- (T a1 .. ak) matches the kind of C's last argument + -- (and hence so does t) + -- + -- We generate the instance + -- instance forall ({a1..ak} u fvs(s1..sm)). + -- C s1 .. sm t => C s1 .. sm (T a1...ak) + -- where T a1...ap is the partial application of + -- the LHS of the correct kind and p >= k -- - -- We generate the instances - -- instance C s1 .. sm (t ak...ap) => C s1 .. sm (T a1...ap) - -- where T a1...ap is the partial application of the LHS of the correct kind - -- and p >= k + -- NB: the variables below are: + -- tc_tvs = [a1, ..., an] + -- tyvars_to_keep = [a1, ..., ak] + -- rep_ty = t ak .. an + -- deriv_tvs = fvs(s1..sm) \ tc_tvs + -- tys = [s1, ..., sm] + -- rep_fn' = t -- -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + -- We generate the instance -- instance Monad (ST s) => Monad (T s) where - -- fail = coerce ... (fail @ ST s) - -- (Actually we don't need the coerce, because non-rec newtypes are transparent clas_tyvars = classTyVars clas kind = tyVarKind (last clas_tyvars) @@ -419,43 +468,33 @@ makeDerivEqns overlap_flag tycl_decls args_to_drop = drop n_args_to_keep rep_ty_args args_to_keep = take n_args_to_keep rep_ty_args - rep_tys = tys ++ [mkAppTys rep_fn args_to_keep] + rep_fn' = mkAppTys rep_fn args_to_keep + rep_tys = tys ++ [rep_fn'] 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 - 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. + -- Next we figure out what superclass dictionaries to use + -- See Note [Newtype deriving superclasses] above + inst_tys = tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)] 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 = [] - | otherwise = rep_pred : sc_theta + -- Example: newtype T = MkT Int deriving( C ) + -- We get the derived instance + -- instance C T + -- rather than + -- instance C Int => C T + dict_tvs = deriv_tvs ++ tyvars_to_keep + all_preds = rep_pred : sc_theta -- NB: rep_pred comes first + (dict_args, ntd_info) | null dict_tvs = ([], Just all_preds) + | otherwise = (all_preds, Nothing) -- Finally! Here's where we build the dictionary Id - mk_inst_spec dfun_name - = mkLocalInstance dfun overlap_flag + mk_inst_spec dfun_name = mkLocalInstance dfun overlap_flag where dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys @@ -491,10 +530,12 @@ makeDerivEqns overlap_flag tycl_decls -- Check that eta reduction is OK -- (a) the dropped-off args are identical - -- (b) the remaining type args mention - -- only the remaining type variables + -- (b) the remaining type args do not mention any of teh dropped type variables + -- (c) the type class args do not mention any of teh dropped type variables + dropped_tvs = mkVarSet tyvars_to_drop eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop) - && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) + && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs) + && (tyVarsOfTypes tys `disjointVarSet` dropped_tvs) cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep (vcat [ptext SLIT("even with cunning newtype deriving:"), @@ -566,7 +607,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? ] @@ -647,7 +688,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") @@ -725,10 +766,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 @@ -827,7 +873,7 @@ genInst spec -- *non-renamed* auxiliary bindings ; (rn_meth_binds, _fvs) <- discardWarnings $ bindLocalNames (map varName tyvars) $ - rnMethodBinds clas_nm [] meth_binds + rnMethodBinds clas_nm (\n -> []) [] meth_binds -- Build the InstInfo ; return (InstInfo { iSpec = spec, @@ -945,16 +991,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}