X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=033e3990590e57d8ea0710d6096dbed0610cd2d8;hp=601f0deb2c579d1be188871a78e8090a3f29afd0;hb=8611d7d952b4a5bb0046898b386ded8fb287fdfa;hpb=68bc0b6f15eefa83e7d11227ec09dbf6a301ab08 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 601f0de..033e399 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -18,39 +18,40 @@ 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 ) import Inst ( getOverlapFlag ) import TcHsType ( tcHsDeriv ) import TcSimplify ( tcSimplifyDeriv ) +import TypeRep ( PredType ) import RnBinds ( rnMethodBinds, rnTopBinds ) import RnEnv ( bindLocalNames ) 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, 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 ( SrcSpan, srcLocSpan, Located(..), unLoc ) import Util ( zipWithEqual, sortLe, notNull ) import ListSetOps ( removeDups, assocMaybe ) import Outputable @@ -142,12 +143,13 @@ this by simplifying the RHS to a form in which So, here are the synonyms for the ``equation'' structures: \begin{code} -type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs) +type DerivEqn = (SrcSpan, InstOrigin, Name, Class, TyCon, [TyVar], DerivRhs) -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the RHS -pprDerivEqn (n,c,tc,tvs,rhs) - = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs) +pprDerivEqn :: DerivEqn -> SDoc +pprDerivEqn (l,_,n,c,tc,tvs,rhs) + = parens (hsep [ppr l, ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs) type DerivRhs = ThetaType type DerivSoln = DerivRhs @@ -206,15 +208,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,59 +317,91 @@ 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)] + derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)] -- Find the (nd, TyCon, Pred) pairs that must be `derived' - derive_these = [ (nd, tycon, pred) + derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, nd, tycon, pred) | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, tcdDerivs = Just preds }) <- tycl_decls, pred <- preds ] + top_level_deriv :: LDerivDecl Name -> TcM (Maybe (SrcSpan, InstOrigin, 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 (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst) + ------------------------------------------------------------------ - mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) + -- takes (whether newtype or data, name of data type, partially applied type class) + mk_eqn :: (SrcSpan, InstOrigin, 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 -- -- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign -- we allow deriving (forall a. C [a]). - mk_eqn (new_or_data, tycon_name, hs_deriv_ty) + mk_eqn (loc, orig, new_or_data, tycon_name, hs_deriv_ty) = tcLookupTyCon tycon_name `thenM` \ tycon -> - setSrcSpan (srcLocSpan (getSrcLoc tycon)) $ + setSrcSpan loc $ 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) -> doptM Opt_GlasgowExts `thenM` \ gla_exts -> - mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys + mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys ------------------------------------------------------------------ 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) | otherwise - = do { eqn <- mkDataTypeEqn tycon clas + = do { eqn <- mkDataTypeEqn loc orig tycon clas ; returnM (Just eqn, Nothing) } - mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys + mk_eqn_help loc orig 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 + = mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route | otherwise -- Non-standard instance = bale_out (if gla_exts then @@ -374,22 +410,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 +472,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 +528,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:"), @@ -540,8 +577,8 @@ new_dfun_name clas tycon -- Just a simple wrapper -- a suitable string; hence the empty type arg list ------------------------------------------------------------------ -mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn -mkDataTypeEqn tycon clas +mkDataTypeEqn :: SrcSpan -> InstOrigin -> TyCon -> Class -> TcM DerivEqn +mkDataTypeEqn loc orig tycon clas | clas `hasKey` typeableClassKey = -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) @@ -554,11 +591,11 @@ mkDataTypeEqn tycon clas -- Typeable; it depends on the arity of the type do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; dfun_name <- new_dfun_name real_clas tycon - ; return (dfun_name, real_clas, tycon, [], []) } + ; return (loc, orig, dfun_name, real_clas, tycon, [], []) } | otherwise = do { dfun_name <- new_dfun_name clas tycon - ; return (dfun_name, clas, tycon, tyvars, constraints) } + ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) } where tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints @@ -568,7 +605,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? ] @@ -649,7 +686,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,11 +763,12 @@ solveDerivEqns overlap_flag orig_eqns iterateDeriv (n+1) new_solns ------------------------------------------------------------------ - gen_soln (_, clas, tc,tyvars,deriv_rhs) - = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ + gen_soln :: DerivEqn -> TcM [PredType] + gen_soln (loc, orig, _, clas, tc,tyvars,deriv_rhs) + = setSrcSpan loc $ do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)] ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $ - tcSimplifyDeriv tc tyvars deriv_rhs + tcSimplifyDeriv orig tc tyvars deriv_rhs ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $ checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the soluction @@ -738,7 +776,8 @@ solveDerivEqns overlap_flag orig_eqns ------------------------------------------------------------------ - mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta + mk_inst_spec :: DerivEqn -> DerivSoln -> Instance + mk_inst_spec (loc, orig, dfun_name, clas, tycon, tyvars, _) theta = mkLocalInstance dfun overlap_flag where dfun = mkDictFunId dfun_name tyvars theta clas