X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=c4b351724f36524ffd5ed5a62a00b1bdb81c27dc;hb=18766724e350e926e85d10002ebf2a70d375f440;hp=511fcbfcc5c5cd48b2627a88d3629be49a5308dc;hpb=46c673a70fe14fe05d7160b456925b8591b5f779;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 511fcbf..c4b3517 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,27 +5,19 @@ \section[TcModule]{Typechecking a whole module} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - tcRnLookupName, - tcRnGetInfo, getModuleExports, #endif + tcRnLookupName, + tcRnGetInfo, tcRnModule, tcTopSrcDecls, tcRnExtCore ) where -import System.IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif @@ -33,13 +25,11 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags import StaticFlags import HsSyn -import RdrHsSyn import PrelNames import RdrName import TcHsSyn import TcExpr import TcRnMonad -import TcType import Coercion import Inst import FamInst @@ -62,7 +52,6 @@ import LoadIface import RnNames import RnEnv import RnSource -import RnHsDoc import PprCore import CoreSyn import ErrUtils @@ -70,13 +59,12 @@ import Id import VarEnv import Var import Module -import LazyUniqFM +import UniqFM import Name import NameEnv import NameSet import TyCon import TysPrim -import TysWiredIn import SrcLoc import HscTypes import ListSetOps @@ -84,10 +72,10 @@ import Outputable import DataCon import Type import Class +import TcType import Data.List ( sortBy ) #ifdef GHCI -import Linker import TcHsType import TcMType import TcMatches @@ -95,11 +83,9 @@ import RnTypes import RnExpr import IfaceEnv import MkId -import IdInfo -import {- Kind parts of -} Type import BasicTypes -import Foreign.Ptr( Ptr ) -import TidyPgm ( globaliseAndTidyId ) +import TidyPgm ( globaliseAndTidyId ) +import TysWiredIn ( unitTy, mkListTy ) #endif import FastString @@ -108,7 +94,6 @@ import Util import Bag import Control.Monad -import Data.Maybe ( isJust ) #include "HsVersions.h" \end{code} @@ -312,7 +297,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -341,6 +326,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], + mg_anns = [], mg_binds = core_binds, -- Stubs @@ -358,6 +344,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) return mod_guts }}}} +mkFakeGroup :: [LTyClDecl a] -> HsGroup a mkFakeGroup decls -- Rather clumsy; lots of unused fields = emptyRdrGroup { hs_tyclds = decls } \end{code} @@ -423,7 +410,7 @@ tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds - = do { let { (first_group, group_tail) = findSplice ds } ; + = do { (first_group, group_tail) <- findSplice ds ; -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice @@ -440,11 +427,13 @@ tc_rn_src_decls boot_details ds return (tcg_env, tcl_env) } ; - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr, rest_ds) -> do { #ifndef GHCI + -- There shouldn't be a splice + Just (SpliceDecl {}, _) -> do { failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr _, rest_ds) -> do { -- Rename the splice expression, and get its supporting decls (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; @@ -471,31 +460,38 @@ tc_rn_src_decls boot_details ds \begin{code} tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls - = do { let { (first_group, group_tail) = findSplice decls } - - ; case group_tail of - Just stuff -> spliceInHsBootErr stuff - Nothing -> return () + = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations ; (tcg_env, HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, - hs_fords = _, - hs_defds = _, -- Todo: check no foreign decls, no rules, - hs_ruleds = _, -- no default decls and no annotation decls + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group ; setGblEnv tcg_env $ do { + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () + ; mapM_ (badBootDecl "foreign") for_decls + ; mapM_ (badBootDecl "default") def_decls + ; mapM_ (badBootDecl "rule") rule_decls + -- Typecheck type/class decls ; traceTc (text "Tc2") - ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { + ; (tcg_env, aux_binds, dm_ids) + <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { -- Typecheck instance decls + -- Family instance declarations are rejected here ; traceTc (text "Tc3") ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 tycl_decls inst_decls deriv_decls @@ -517,18 +513,20 @@ tcRnHsBootDecls decls ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids + ; type_env3 = extendTypeEnvWithIds type_env2 aux_ids ; dfun_ids = map iDFunId inst_infos ; aux_ids = case aux_binds of ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs] _ -> panic "tcRnHsBoodDecls" } - ; setGlobalTypeEnv gbl_env type_env2 + ; setGlobalTypeEnv gbl_env type_env3 }}}} -spliceInHsBootErr (SpliceDecl (L loc _), _) - = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files")) +badBootDecl :: String -> Located decl -> TcM () +badBootDecl what (L loc _) + = addErrAt loc (char 'A' <+> text what + <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) \end{code} Once we've typechecked the body of the module, we want to compare what @@ -546,7 +544,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv checkHiBootIface tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, - tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_insts = local_insts, tcg_type_env = local_type_env, tcg_exports = local_exports }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, md_types = boot_type_env, md_exports = boot_exports }) @@ -560,15 +558,6 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, - tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -579,15 +568,19 @@ checkHiBootIface -- Check instance declarations ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } - final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] + ; let dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' final_type_env } + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one + -- so that if the source module reads in an interface unfolding + -- mentioning one of the dfuns from the boot module, then it + -- can "see" that boot dfun. See Trac #4003 where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -671,7 +664,8 @@ checkBootDecl (AClass c1) (AClass c2) eqSig (id1, def_meth1) (id2, def_meth2) = idName id1 == idName id2 && - tcEqTypeX env op_ty1 op_ty2 + tcEqTypeX env op_ty1 op_ty2 && + def_meth1 == def_meth2 where (_, rho_ty1) = splitForAllTys (idType id1) op_ty1 = funResultTy rho_ty1 @@ -693,7 +687,7 @@ checkBootDecl (AClass c1) (AClass c2) eqListBy eqSig op_stuff1 op_stuff2 && eqListBy checkBootTyCon ats1 ats2) -checkBootDecl (ADataCon dc1) (ADataCon dc2) +checkBootDecl (ADataCon dc1) (ADataCon _) = pprPanic "checkBootDecl" (ppr dc1) checkBootDecl _ _ = False -- probably shouldn't happen @@ -713,6 +707,7 @@ checkBootTyCon tc1 tc2 = tcEqTypeX env k1 k2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = tcEqTypeX env t1 t2 + eqSynRhs _ _ = False in equalLength tvs1 tvs2 && eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) @@ -726,6 +721,8 @@ checkBootTyCon tc1 tc2 | isForeignTyCon tc1 && isForeignTyCon tc2 = eqKind (tyConKind tc1) (tyConKind tc2) && tyConExtName tc1 == tyConExtName tc2 + + | otherwise = False where env0 = mkRnEnv2 emptyInScopeSet @@ -755,15 +752,18 @@ checkBootTyCon tc1 tc2 (dataConOrigArgTys c2) ---------------- -missingBootThing thing what - = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") +missingBootThing :: Name -> String -> SDoc +missingBootThing name what + = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") <+> text what <+> ptext (sLit "the module") +bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), ptext (sLit "Main module:") <+> ppr real_decl, ptext (sLit "Boot file: ") <+> ppr boot_decl] +instMisMatch :: Instance -> SDoc instMisMatch inst = hang (ppr inst) 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) @@ -823,10 +823,12 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc (text "Tc2") ; - (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { + -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; @@ -856,13 +858,12 @@ tcTopSrcDecls boot_details (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcTopBinds val_binds; + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ - tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; - - setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; -- Foreign exports traceTc (text "Tc7") ; @@ -909,6 +910,7 @@ checkMain check_main dflags tcg_env } +check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv check_main dflags tcg_env | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> @@ -970,6 +972,7 @@ check_main dflags tcg_env <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn +ppMainFn :: RdrName -> SDoc ppMainFn main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) @@ -1015,12 +1018,11 @@ get two defns for 'main' in the interface file! %********************************************************* \begin{code} -#ifdef GHCI setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a setInteractiveContext hsc_env icxt thing_inside = let -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnModule. - (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True) + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) in updGblEnv (\env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, @@ -1046,6 +1048,7 @@ setInteractiveContext hsc_env icxt thing_inside \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName @@ -1062,7 +1065,7 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; + (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; rnDump (ppr rn_stmt) ; @@ -1074,7 +1077,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; let { global_ids = map globaliseAndTidyId zonked_ids } ; @@ -1196,13 +1199,13 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt -- The two-step process avoids getting two errors: one from -- the expression itself, and one from the 'print it' part -- This two-step story is very clunky, alas - do { checkNoErrs (tcGhciStmts [let_stmt]) + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) --- checkNoErrs defeats the error recovery of let-bindings ; tcGhciStmts [let_stmt, print_it] } ]} mkPlan stmt@(L loc (BindStmt {})) - | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt + | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) (HsVar thenIOName) placeHolderType @@ -1231,9 +1234,9 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; + tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; - names = map unLoc (collectLStmtsBinders stmts) ; + names = collectLStmtsBinders stmts ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -1266,7 +1269,7 @@ tcGhciStmts stmts traceTc (text "TcRnDriver.tcGhciStmts: done") ; return (ids, mkHsDictLet const_binds $ - noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) + noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) } \end{code} @@ -1282,14 +1285,14 @@ tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - (rn_expr, fvs) <- rnLExpr rdr_expr ; + (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; + ((_tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyInteractive lie_top ; + _ <- tcSimplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs $ mkFunTys (map (idType . instToId) dict_insts) $ @@ -1315,7 +1318,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcLHsType rn_type ; + (_ty', kind) <- kcLHsType rn_type ; return kind } where @@ -1341,7 +1344,7 @@ getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod = let ic = hsc_IC hsc_env - checkMods = ic_toplev_scope ic ++ ic_exports ic + checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic) in initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) @@ -1372,6 +1375,7 @@ tcRnLookupRdrName hsc_env rdr_name setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name +lookup_rdr_name :: RdrName -> TcM [Name] lookup_rdr_name rdr_name = do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both @@ -1400,6 +1404,7 @@ lookup_rdr_name rdr_name = do { return good_names } +#endif tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name @@ -1420,8 +1425,8 @@ tcRnLookupName' name = do _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv - -> Name - -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) + -> Name + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implement :info in GHCi -- @@ -1431,8 +1436,14 @@ tcRnGetInfo :: HscEnv -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name - = initTcPrintErrors hsc_env iNTERACTIVE $ - let ictxt = hsc_IC hsc_env in + = initTcPrintErrors hsc_env iNTERACTIVE $ + tcRnGetInfo' hsc_env name + +tcRnGetInfo' :: HscEnv + -> Name + -> TcRn (TyThing, Fixity, [Instance]) +tcRnGetInfo' hsc_env name + = let ictxt = hsc_IC hsc_env in setInteractiveContext hsc_env ictxt $ do -- Load the interface for all unqualified types and classes @@ -1452,11 +1463,11 @@ lookupInsts (AClass cls) ; return (classInstances inst_envs cls) } lookupInsts (ATyCon tc) - = do { eps <- getEps -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all - ; return [ ispec + = do { (pkg_ie, home_ie) <- tcGetInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; return [ ispec -- Search all | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie , let dfun = instanceDFunId ispec , relevant dfun ] } @@ -1464,7 +1475,7 @@ lookupInsts (ATyCon tc) relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts other = return [] +lookupInsts _ = return [] loadUnqualIfaces :: InteractiveContext -> TcM () -- Load the home module for everything that is in scope unqualified @@ -1481,7 +1492,6 @@ loadUnqualIfaces ictxt isTcOcc (nameOccName name), -- Types and classes only unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") -#endif /* GHCI */ \end{code} %************************************************************************ @@ -1512,6 +1522,7 @@ tcDump env -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords +tcCoreDump :: ModGuts -> TcM () tcCoreDump mod_guts = do { dflags <- getDOpts ; when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) @@ -1615,6 +1626,7 @@ ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 4 (pprRules rs), ptext (sLit "#-}")] +ppr_gen_tycons :: [TyCon] -> SDoc ppr_gen_tycons [] = empty ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]