X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=60a7499ef5bf34375be9669fd82d87097bdba6f9;hb=380512de6eef0cbb17431d9e64007a9320914e23;hp=65c425d255d1c9522b34585dd3e0d658fdca6a31;hpb=45b391025ccd6f91d6c280c7d0e5e755b67e760c;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 65c425d..60a7499 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1,7 +1,7 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcDeriv]{Deriving} Handles @deriving@ clauses on @data@ declarations. @@ -11,48 +11,38 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn -import DynFlags ( DynFlag(..) ) +import DynFlags -import Generics ( mkTyConGenericBinds ) +import Generics import TcRnMonad -import TcMType ( checkValidInstance ) -import TcEnv ( newDFunName, pprInstInfoDetails, - InstInfo(..), InstBindings(..), simpleInstInfoClsTy, - tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv - ) +import TcEnv import TcGenDeriv -- Deriv stuff -import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList ) -import Inst ( getOverlapFlag ) -import TcHsType ( tcHsDeriv ) -import TcSimplify ( tcSimplifyDeriv ) - -import RnBinds ( rnMethodBinds, rnTopBinds ) -import RnEnv ( bindLocalNames ) -import HscTypes ( FixityEnv ) - -import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) -import Type ( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy ) -import ErrUtils ( dumpIfSet_dyn ) -import MkId ( mkDictFunId ) -import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys ) -import Maybes ( catMaybes ) -import RdrName ( RdrName ) -import Name ( Name, getSrcLoc ) -import NameSet ( duDefs ) -import Kind ( splitKindFunTys ) -import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, - tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs, - isEnumerationTyCon, isRecursiveTyCon, TyCon - ) -import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, - isUnLiftedType, mkClassPred, tyVarsOfType, - isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys ) -import Var ( TyVar, tyVarKind, varName ) -import VarSet ( mkVarSet, subVarSet ) +import InstEnv +import Inst +import TcHsType +import TcSimplify + +import RnBinds +import RnEnv +import HscTypes + +import Class +import Type +import ErrUtils +import MkId +import DataCon +import Maybes +import RdrName +import Name +import NameSet +import TyCon +import TcType +import Var +import VarSet import PrelNames -import SrcLoc ( srcLocSpan, Located(..) ) -import Util ( zipWithEqual, sortLe, notNull ) -import ListSetOps ( removeDups, assocMaybe ) +import SrcLoc +import Util +import ListSetOps import Outputable import Bag \end{code} @@ -142,12 +132,17 @@ 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 + -- For family indexes, the tycon is the representation tycon -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 origTc, ppr tys] <+> equals <+> + ppr rhs) + where + (origTc, tys) = tyConOrigHead tc type DerivRhs = ThetaType type DerivSoln = DerivRhs @@ -206,15 +201,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) $ @@ -277,7 +274,8 @@ deriveOrdinaryStuff overlap_flag eqns ; extra_binds <- genTaggeryBinds inst_infos -- Done - ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s)) + ; returnM (map fst inst_infos, + unionManyBags (extra_binds : aux_binds_s)) } ----------------------------------------- @@ -313,59 +311,120 @@ 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} +type DerivSpec = (SrcSpan, -- location of the deriving clause + InstOrigin, -- deriving at data decl or standalone? + NewOrData, -- newtype or data type + Name, -- Type constructor for which we derive + Maybe [LHsType Name], -- Type indexes if indexed type + LHsType Name) -- Class instance to be generated + 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_top_level <- mapM top_level_deriv deriv_decls + (maybe_ordinaries, maybe_newtypes) + <- mapAndUnzipM mk_eqn (derive_data ++ catMaybes derive_top_level) + return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(NewOrData, Name, LHsType Name)] - -- Find the (nd, TyCon, Pred) pairs that must be `derived' - derive_these = [ (nd, tycon, pred) - | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, - tcdDerivs = Just preds }) <- tycl_decls, + -- Deriving clauses at data declarations + derive_data :: [DerivSpec] + derive_data = [ (loc, DerivOrigin, nd, tycon, tyPats, pred) + | L loc (TyData { tcdND = nd, tcdLName = L _ tycon, + tcdTyPats = tyPats, + tcdDerivs = Just preds }) <- tycl_decls, pred <- preds ] + -- Standalone deriving declarations + top_level_deriv :: LDerivDecl Name -> TcM (Maybe DerivSpec) + top_level_deriv d@(L loc (DerivDecl inst ty_name)) = + recoverM (returnM Nothing) $ setSrcSpan loc $ + 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 (loc, StandAloneDerivOrigin, new_or_data, + unLoc ty_name, Nothing, inst) + ------------------------------------------------------------------ - mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) + -- Derive equation/inst info for one deriving clause (data or standalone) + mk_eqn :: DerivSpec -> 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) - = tcLookupTyCon tycon_name `thenM` \ tycon -> - setSrcSpan (srcLocSpan (getSrcLoc 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) -> - doptM Opt_GlasgowExts `thenM` \ gla_exts -> - mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys + -- The "deriv_ty" is a LHsType to take account of the fact that for + -- newtype deriving we allow deriving (forall a. C [a]). + + mk_eqn (loc, orig, new_or_data, tycon_name, mb_tys, hs_deriv_ty) + = setSrcSpan loc $ + addErrCtxt (derivCtxt tycon_name mb_tys) $ + do { named_tycon <- tcLookupTyCon tycon_name + + -- Lookup representation tycon in case of a family instance + ; tycon <- case mb_tys of + Nothing -> return named_tycon + Just hsTys -> do + tys <- mapM dsHsType hsTys + tcLookupFamInst named_tycon tys + + -- Enable deriving preds to mention the type variables in the + -- instance type + ; tcExtendTyVarEnv (tyConTyVars tycon) $ do + -- + { (deriv_tvs, clas, tys) <- tcHsDeriv hs_deriv_ty + ; gla_exts <- doptM Opt_GlasgowExts + ; 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 + -- 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 loc orig 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) + = bale_out (derivingThingErr clas tys origTyCon ttys err) | otherwise - = do { eqn <- mkDataTypeEqn tycon clas + = do { eqn <- mkDataTypeEqn loc orig tycon clas ; returnM (Just eqn, Nothing) } + where + (origTyCon, ttys) = tyConOrigHead tycon - 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 +433,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 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 + -- 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 + -- + -- 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 +495,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,12 +551,14 @@ 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 + cant_derive_err = derivingThingErr clas tys tycon (mkTyVarTys tyvars_to_keep) (vcat [ptext SLIT("even with cunning newtype deriving:"), if isRecursiveTyCon tycon then ptext SLIT("the newtype is recursive") @@ -515,7 +575,7 @@ makeDerivEqns overlap_flag tycl_decls else empty ]) - non_std_err = derivingThingErr clas tys tycon tyvars_to_keep + non_std_err = derivingThingErr clas tys tycon (mkTyVarTys tyvars_to_keep) (vcat [non_std_why clas, ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")]) @@ -540,8 +600,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 +614,12 @@ 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 +629,7 @@ mkDataTypeEqn tycon clas ordinary_constraints = [ mkClassPred clas [arg_ty] | data_con <- tyConDataCons tycon, - arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)), + arg_ty <- dataConInstOrigArgTys data_con (mkTyVarTys tyvars), not (isUnLiftedType arg_ty) -- No constraints for unlifted types? ] @@ -648,12 +709,16 @@ cond_typeableOK :: Condition -- Currently: (a) args all of kind * -- (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 - | otherwise = Nothing + | tyConArity tycon > 7 = Just too_many + | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) + = Just bad_kind + | isFamInstTyCon tycon = Just fam_inst -- no Typable for family insts + | otherwise = Nothing where too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments") - bad_kind = quotes (ppr tycon) <+> ptext SLIT("has arguments of kind other than `*'") + bad_kind = quotes (ppr tycon) <+> + ptext SLIT("has arguments of kind other than `*'") + fam_inst = quotes (ppr tycon) <+> ptext SLIT("is a type family") cond_glaExts :: Condition cond_glaExts (gla_exts, tycon) | gla_exts = Nothing @@ -726,23 +791,26 @@ solveDerivEqns overlap_flag orig_eqns iterateDeriv (n+1) new_solns ------------------------------------------------------------------ - gen_soln (_, clas, tc,tyvars,deriv_rhs) - = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ - do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)] + gen_soln :: DerivEqn -> TcM [PredType] + gen_soln (loc, orig, _, clas, tc, tyvars, deriv_rhs) + = setSrcSpan loc $ + do { let inst_tys = [origHead] ; 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 + tcSimplifyDeriv orig tc tyvars deriv_rhs + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution where - + origHead = uncurry mkTyConApp (tyConOrigHead tc) ------------------------------------------------------------------ - 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 - [mkTyConApp tycon (mkTyVarTys tyvars)] + dfun = mkDictFunId dfun_name tyvars theta clas [origHead] + origHead = uncurry mkTyConApp (tyConOrigHead tycon) extendLocalInstEnv :: [Instance] -> TcM a -> TcM a -- Add new locally-defined instances; don't bother to check @@ -817,30 +885,41 @@ the renamer. What a great hack! \end{itemize} \begin{code} --- Generate the InstInfo for the required instance, +-- Generate the InstInfo for the required instance paired with the +-- *representation* tycon for that instance, -- plus any auxiliary bindings required -genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName) +-- +-- Representation tycons differ from the tycon in the instance signature in +-- case of instances for indexed families. +-- +genInst :: Instance -> TcM ((InstInfo, TyCon), LHsBinds RdrName) genInst spec = do { fix_env <- getFixityEnv ; let (tyvars,_,clas,[ty]) = instanceHead spec clas_nm = className clas - tycon = tcTyConAppTyCon ty - (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon + (visible_tycon, tyArgs) = tcSplitTyConApp ty + + -- In case of a family instance, we need to use the representation + -- tycon (after all it has the data constructors) + ; tycon <- if isOpenTyCon visible_tycon + then tcLookupFamInst visible_tycon tyArgs + else return visible_tycon + ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon -- Bring the right type variables into -- scope, and rename the method binds -- It's a bit yukky that we return *renamed* InstInfo, but -- *non-renamed* auxiliary bindings ; (rn_meth_binds, _fvs) <- discardWarnings $ - bindLocalNames (map varName tyvars) $ + bindLocalNames (map Var.varName tyvars) $ rnMethodBinds clas_nm (\n -> []) [] meth_binds -- Build the InstInfo - ; return (InstInfo { iSpec = spec, - iBinds = VanillaInst rn_meth_binds [] }, + ; return ((InstInfo { iSpec = spec, + iBinds = VanillaInst rn_meth_binds [] }, tycon), aux_binds) - } + } genDerivBinds clas fix_env tycon | className clas `elem` typeableClassNames @@ -903,15 +982,14 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName) +genTaggeryBinds :: [(InstInfo, TyCon)] -> TcM (LHsBinds RdrName) genTaggeryBinds infos = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) } where - all_CTs = [ (cls, tcTyConAppTyCon ty) - | info <- infos, - let (cls,ty) = simpleInstInfoClsTy info ] + all_CTs = [ (fst (simpleInstInfoClsTy info), tc) + | (info, tc) <- infos] all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons @@ -950,22 +1028,24 @@ genTaggeryBinds infos \end{code} \begin{code} -derivingThingErr clas tys tycon tyvars why - = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)], +derivingThingErr clas tys tycon ttys why + = sep [hsep [ptext SLIT("Can't make a derived instance of"), + quotes (ppr pred)], nest 2 (parens why)] where - pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)]) + pred = mkClassPred clas (tys ++ [mkTyConApp tycon ttys]) -derivCtxt :: TyCon -> SDoc -derivCtxt tycon - = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon) +derivCtxt :: Name -> Maybe [LHsType Name] -> SDoc +derivCtxt tycon mb_tys + = ptext SLIT("When deriving instances for") <+> quotes typeInst + where + typeInst = case mb_tys of + Nothing -> ppr tycon + Just tys -> ppr tycon <+> + hsep (map (pprParendHsType . unLoc) tys) 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])] + = ptext SLIT("When deriving the instance for") <+> + quotes (pprClassPred clas inst_tys) \end{code}