X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=11ff67229845c05632984bb4ad8ac5e3aa519bee;hb=3ad8f84f6a75f240383e62a14472d14eb372dcd1;hp=65c425d255d1c9522b34585dd3e0d658fdca6a31;hpb=45b391025ccd6f91d6c280c7d0e5e755b67e760c;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 65c425d..11ff672 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -18,7 +18,7 @@ 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 ) @@ -34,23 +34,23 @@ import Class ( className, classArity, classKey, classTyVars, classSCTheta, Clas import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) -import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys ) +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, tyVarsOfType, - 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 @@ -206,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) $ @@ -313,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)] @@ -331,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 @@ -350,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) @@ -359,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 @@ -374,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) @@ -426,38 +474,27 @@ makeDerivEqns overlap_flag tycl_decls -- 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 @@ -493,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) - && (tyVarsOfType rep_fn' `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:"), @@ -649,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")