From 380512de6eef0cbb17431d9e64007a9320914e23 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 18 Dec 2006 21:12:05 +0000 Subject: [PATCH] =?utf8?q?Deriving=20for=20indexed=20data=20types=20-=20This?= =?utf8?q?=20patch=20implements=20deriving=20clauses=20for=20data=20instance?= =?utf8?q?=20declarations=20=20=20(toplevel=20and=20associated)=20-=20Doesn'?= =?utf8?q?t=20support=20standalone=20deriving.=20=20This=20could=20be=20easi?= =?utf8?q?ly=20supported,=20=20=20but=20requires=20an=20extension=20of=20the?= =?utf8?q?=20syntax=20of=20standalone=20deriving=20clauses.=20=20=20Bj=C3=B6?= =?utf8?q?rn,=20fancy=20adding=20this=3F=20-=20We=20cannot=20derive=20Typeab?= =?utf8?q?le.=20=20This=20seems=20a=20problem=20of=20notation,=20more=20than?= =?utf8?q?=20=20=20anything=20else.=20=20Why=3F=20=20For=20a=20binary=20vani?= =?utf8?q?lla=20data=20type=20"T=20a=20b",=20we=20would=20=20=20generate=20a?= =?utf8?q?n=20instance=20Typeable2=20T;=20ie,=20the=20instance=20is=20for=20?= =?utf8?q?the=20constructor=20=20=20alone.=20=20In=20the=20case=20of=20a=20f?= =?utf8?q?amily=20instance,=20such=20as=20(S=20[a]=20(Maybe=20b)),=20we=20=20?= =?utf8?q?=20simply=20have=20no=20means=20to=20denote=20the=20associated=20c?= =?utf8?q?onstuctor.=20=20It=20appears=20to=20=20=20require=20type=20level=20?= =?utf8?q?lambda=20-=20something=20like=20(/\a=20b.=20S=20[a]=20(Maybe=20b).?= =?utf8?q?=20-=20Derivings=20are=20for=20*individual*=20family=20*instances*?= =?utf8?q?,=20not=20for=20entire=20families.=20=20=20Currently,=20I=20know=20?= =?utf8?q?of=20no=20simple=20translation=20of=20class=20instances=20for=20en?= =?utf8?q?tire=20=20=20families=20to=20System=20F=5FC.=20=20This=20actually=20?= =?utf8?q?seems=20to=20be=20similar=20to=20implementing=20=20=20open=20data=20?= =?utf8?q?types=20=C3=A0=20la=20L=C3=B6h=20&=20Hinze.=20-=20This=20patch=20o?= =?utf8?q?nly=20covers=20data=20types,=20not=20newtypes.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- compiler/typecheck/TcDeriv.lhs | 172 ++++++++++++++++++++++++++-------------- compiler/typecheck/TcEnv.lhs | 20 ++++- compiler/types/FamInstEnv.lhs | 48 ++++++++++- compiler/types/Type.lhs | 8 ++ 4 files changed, 185 insertions(+), 63 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 90ff3a7..60a7499 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -135,10 +135,14 @@ So, here are the synonyms for the ``equation'' structures: 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 :: DerivEqn -> SDoc -pprDerivEqn (l,_,n,c,tc,tvs,rhs) - = parens (hsep [ppr l, ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs) +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 @@ -270,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)) } ----------------------------------------- @@ -328,6 +333,13 @@ 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] @@ -335,44 +347,60 @@ makeDerivEqns :: OverlapFlag [InstInfo]) -- Special newtype derivings makeDerivEqns overlap_flag tycl_decls deriv_decls - = do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes + = do derive_top_level <- mapM top_level_deriv deriv_decls (maybe_ordinaries, maybe_newtypes) - <- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level) + <- mapAndUnzipM mk_eqn (derive_data ++ catMaybes derive_top_level) return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)] - -- Find the (nd, TyCon, Pred) pairs that must be `derived' - derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, 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 ] - 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 $ + -- 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 (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst) + 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) ------------------------------------------------------------------ - -- 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) + -- 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 (loc, orig, new_or_data, tycon_name, hs_deriv_ty) - = tcLookupTyCon tycon_name `thenM` \ 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 loc orig 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 + }} ------------------------------------------------------------------ -- data/newtype T a = ... deriving( C t1 t2 ) @@ -381,10 +409,12 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls 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 loc orig tycon clas ; returnM (Just eqn, Nothing) } + where + (origTyCon, ttys) = tyConOrigHead tycon mk_eqn_help loc orig gla_exts NewType tycon deriv_tvs clas tys | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas) @@ -528,7 +558,7 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls && (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") @@ -545,7 +575,7 @@ makeDerivEqns overlap_flag tycl_decls deriv_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")]) @@ -588,7 +618,8 @@ mkDataTypeEqn loc orig tycon clas | otherwise = do { dfun_name <- new_dfun_name clas tycon - ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) } + ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) + } where tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints @@ -598,7 +629,7 @@ mkDataTypeEqn loc orig 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? ] @@ -678,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 (isSubArgTypeKind . 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 @@ -757,9 +792,9 @@ solveDerivEqns overlap_flag orig_eqns ------------------------------------------------------------------ gen_soln :: DerivEqn -> TcM [PredType] - gen_soln (loc, orig, _, clas, tc,tyvars,deriv_rhs) + gen_soln (loc, orig, _, clas, tc, tyvars, deriv_rhs) = setSrcSpan loc $ - do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)] + do { let inst_tys = [origHead] ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $ tcSimplifyDeriv orig tc tyvars deriv_rhs -- Claim: the result instance declaration is guaranteed valid @@ -767,15 +802,15 @@ solveDerivEqns overlap_flag orig_eqns -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution where - + origHead = uncurry mkTyConApp (tyConOrigHead tc) ------------------------------------------------------------------ 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 @@ -850,16 +885,27 @@ 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 @@ -870,10 +916,10 @@ genInst spec 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 @@ -936,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 @@ -983,17 +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) + = ptext SLIT("When deriving the instance for") <+> + quotes (pprClassPred clas inst_tys) \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index cc50e50..d59278a 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -17,7 +17,7 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, + tcLookupLocatedClass, tcLookupFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, @@ -61,6 +61,7 @@ import VarSet import VarEnv import RdrName import InstEnv +import FamInstEnv import DataCon import TyCon import Class @@ -157,6 +158,18 @@ tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Look up the representation tycon of a family instance. +-- +tcLookupFamInst :: TyCon -> [Type] -> TcM TyCon +tcLookupFamInst tycon tys + = do { env <- getGblEnv + ; eps <- getEps + ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) + ; case lookupFamInstEnvExact instEnv tycon tys of + Nothing -> famInstNotFound tycon tys + Just famInst -> return $ famInstTyCon famInst + } \end{code} %************************************************************************ @@ -656,4 +669,9 @@ notFound name wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected) + +famInstNotFound tycon tys + = failWithTc (quotes famInst <+> ptext SLIT("is not in scope")) + where + famInst = ppr tycon <+> hsep (map pprParendType tys) \end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 9b49f5c..5ff0139 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -12,7 +12,7 @@ module FamInstEnv ( FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - lookupFamInstEnv, lookupFamInstEnvUnify + lookupFamInstEnvExact, lookupFamInstEnv, lookupFamInstEnvUnify ) where #include "HsVersions.h" @@ -174,7 +174,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) add (FamIE items tyvar) _ = FamIE (ins_item:items) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) -\end{code} +\end{code} %************************************************************************ %* * @@ -182,6 +182,50 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) %* * %************************************************************************ +@lookupFamInstEnvExact@ looks up in a @FamInstEnv@ using an exact match. +This is used when we want the @TyCon@ of a particular family instance (e.g., +during deriving classes). + +\begin{code} +lookupFamInstEnvExact :: (FamInstEnv -- External package inst-env + ,FamInstEnv) -- Home-package inst-env + -> TyCon -> [Type] -- What we are looking for + -> Maybe FamInst +lookupFamInstEnvExact (pkg_ie, home_ie) fam tys + = home_matches `mplus` pkg_matches + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + home_matches = lookup home_ie + pkg_matches = lookup pkg_ie + + -------------- + lookup env = case lookupUFM env fam of + Nothing -> Nothing -- No instances for this class + Just (FamIE insts has_tv_insts) + -- Short cut for common case: + -- The thing we are looking up is of form (C a + -- b c), and the FamIE has no instances of + -- that form, so don't bother to search + | all_tvs && not has_tv_insts -> Nothing + | otherwise -> find insts + + -------------- + find [] = Nothing + find (item@(FamInst { fi_tcs = mb_tcs, fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | tcEqTypes tpl_tys tys + = Just item + + -- No match => try next + | otherwise + = find rest +\end{code} + @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. Multiple matches are only possible in case of type families (not data families), and then, it doesn't matter which match we choose (as the diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 480357e..cdc54a1 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -55,6 +55,7 @@ module Type ( -- Source types predTypeRep, mkPredTy, mkPredTys, + tyConOrigHead, -- Newtypes splitRecNewType_maybe, newTyConInstRhs, @@ -602,6 +603,13 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a newtype application, but the consumer will -- look through that too if necessary predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) + +-- The original head is the tycon and its variables for a vanilla tycon and it +-- is the family tycon and its type indexes for a family instance. +tyConOrigHead :: TyCon -> (TyCon, [Type]) +tyConOrigHead tycon = case tyConFamInst_maybe tycon of + Nothing -> (tycon, mkTyVarTys (tyConTyVars tycon)) + Just famInst -> famInst \end{code} -- 1.7.10.4