X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=eabd3bc7ee48b276be379c3e19d5163fe6378c69;hp=a1592ec2a490a4422ecfbc58aad93c9aa8cd7fe1;hb=7aa3f5247ae454b10b61e2f28a9431f0889a8cff;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a1592ec..eabd3bc 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcModule]{Typechecking a whole module} @@ -11,6 +12,7 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, + tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, @@ -24,116 +26,73 @@ import IO import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif -import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) -import StaticFlags ( opt_PprStyle_Debug ) -import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, - SpliceDecl(..), HsBind(..), LHsBinds, - emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, - nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) ) -import RdrHsSyn ( findSplice ) - -import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, - main_RDR_Unqual ) -import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) -import TcHsSyn ( zonkTopDecls ) -import TcExpr ( tcInferRho ) +import DynFlags +import StaticFlags +import HsSyn +import RdrHsSyn + +import PrelNames +import RdrName +import TcHsSyn +import TcExpr import TcRnMonad -import TcType ( tidyTopType, tcEqType ) -import Inst ( showLIE ) -import InstEnv ( extendInstEnvList, Instance, pprInstances, - instanceDFunId ) -import FamInstEnv ( FamInst, pprFamInsts ) -import TcBinds ( tcTopBinds, tcHsBootSigs ) -import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, iDFunId ) -import TcRules ( tcRules ) -import TcForeign ( tcForeignImports, tcForeignExports ) -import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings, tcHiBootIface ) -import MkIface ( tyThingToIfaceDecl ) +import TcType +import Inst +import FamInst +import InstEnv +import FamInstEnv +import TcBinds +import TcDefaults +import TcEnv +import TcRules +import TcForeign +import TcInstDcls +import TcIface +import MkIface import IfaceSyn -import TcSimplify ( tcSimplifyTop ) -import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules ) -import RnNames ( importsFromLocalDecls, rnImports, rnExports, - reportUnusedNames, reportDeprecations ) -import RnEnv ( lookupSrcOcc_maybe ) -import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) -import RnHsDoc ( rnMbHsDoc ) -import PprCore ( pprRules, pprCoreBindings ) -import CoreSyn ( CoreRule, bindersOfBinds ) -import ErrUtils ( Messages, mkDumpDoc, showPass ) -import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) -import Var ( Var ) +import TcSimplify +import TcTyClsDecls +import LoadIface +import RnNames +import RnEnv +import RnSource +import RnHsDoc +import PprCore +import CoreSyn +import ErrUtils +import Id +import Var import Module -import UniqFM ( elemUFM, eltsUFM ) -import OccName ( mkVarOccFS, plusOccEnv ) -import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - nameModule, nameOccName, mkExternalName ) +import UniqFM +import Name import NameSet -import NameEnv -import TyCon ( tyConHasGenerics ) -import SrcLoc ( srcLocSpan, Located(..), noLoc ) -import DriverPhases ( HscSource(..), isHsBoot ) -import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, - HscEnv(..), ExternalPackageState(..), - IsBootInterface, noDependencies, - Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), availsToNameSet, - TypeEnv, lookupTypeEnv, hptInstances, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv, GenAvailInfo(..) - ) +import TyCon +import SrcLoc +import HscTypes import Outputable +import Breakpoints #ifdef GHCI -import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), - HsLocalBinds(..), HsValBinds(..), - LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, - collectLStmtsBinders, collectLStmtBinders, nlVarPat, - mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp ) -import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, - unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) -import RnSource ( addTcgDUs ) -import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs ) -import TcHsType ( kcHsType ) -import TcMType ( zonkTcType, zonkQuantifiedTyVar ) -import TcMatches ( tcStmts, tcDoStmt ) -import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) -import TcGadt ( emptyRefinement ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, - isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) -import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) -import TypeRep ( TyThing(..) ) -import RnTypes ( rnLHsType ) -import Inst ( tcGetInstEnvs ) -import InstEnv ( classInstances, instEnvElts ) -import RnExpr ( rnStmts, rnLExpr ) -import LoadIface ( loadSysInterface ) -import IfaceEnv ( ifaceExportNames ) -import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( setIdType ) -import MkId ( unsafeCoerceId ) -import TyCon ( tyConName ) -import TysWiredIn ( mkListTy, unitTy ) -import IdInfo ( GlobalIdDetails(..) ) -import {- Kind parts of -} Type ( Kind ) -import Var ( globaliseId ) -import Name ( isBuiltInSyntax, isInternalName ) -import OccName ( isTcOcc ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, - bindIOName, thenIOName, returnIOName ) -import HscTypes ( InteractiveContext(..), - ModIface(..), icPrintUnqual, - Dependencies(..) ) -import BasicTypes ( Fixity, RecFlag(..) ) -import SrcLoc ( unLoc ) -import Data.Maybe ( isNothing ) +import Linker +import DataCon +import TcHsType +import TcMType +import TcMatches +import TcGadt +import RnTypes +import RnExpr +import IfaceEnv +import MkId +import TysWiredIn +import IdInfo +import {- Kind parts of -} Type +import BasicTypes +import Data.Maybe #endif -import FastString ( mkFastString ) -import Util ( sortLe ) -import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) +import FastString +import Util +import Bag import Control.Monad ( unless ) import Data.Maybe ( isJust ) @@ -212,9 +171,18 @@ tcRnModule hsc_env hsc_src save_rn_syntax traceIf (text "rdr_env: " <+> ppr rdr_env) ; failIfErrsM ; - -- Load any orphan-module interfaces, so that - -- their rules and instance decls will be found - loadOrphanModules (imp_orphs imports) ; + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + loadOrphanModules (imp_orphs imports) False ; + loadOrphanModules (imp_finsts imports) True ; + + traceRn (text "rn1: checking family instance consistency") ; + let { directlyImpMods = map (\(mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } ; + checkFamInstConsistency (imp_finsts imports) directlyImpMods ; traceRn (text "rn1a") ; -- Rename and type check the declarations @@ -224,6 +192,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { + failIfErrsM ; -- reportDeprecations crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) traceRn (text "rn3") ; -- Report the use of any deprecated things @@ -236,6 +206,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Process the export list (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; + traceRn (text "rn4") ; + -- Rename the Haddock documentation header rn_module_doc <- rnMbHsDoc maybe_doc ; @@ -330,6 +302,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_types = final_type_env, mg_insts = tcg_insts tcg_env, mg_fam_insts = tcg_fam_insts tcg_env, + mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], mg_binds = core_binds, @@ -337,7 +310,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_foreign = NoStubs, + mg_hpc_info = noHpcInfo, + mg_dbg_sites = noDbgSites } } ; tcCoreDump mod_guts ; @@ -369,29 +344,34 @@ tcRnSrcDecls decls boot_iface <- tcHiBootIface mod ; -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ; + (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; + -- Finish simplifying class constraints + -- -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- thaat checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to tcSimplifyTop + -- * the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) traceTc (text "Tc8") ; inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids to tcSimplifyTop, - -- so that we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs ; - TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_rules = rules, tcg_fords = fords } = tcg_env + ; all_binds = binds `unionBags` inst_binds } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) - rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, @@ -415,20 +395,17 @@ tc_rn_src_decls boot_details ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) - -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; + -- checkNoErrs: stop if renaming fails - -- Bale out if errors; for example, error recovery when checking - -- the RHS of 'main' can mean that 'main' is not in the envt for - -- the subsequent checkMain test - failIfErrsM ; - - setEnvs tc_envs $ + (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; -- If there is no splice, we're nearly done + setEnvs (tcg_env, tcl_env) $ case group_tail of { - Nothing -> do { -- Last thing: check for `main' - tcg_env <- checkMain ; + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' return (tcg_env, tcl_env) } ; @@ -439,8 +416,8 @@ tc_rn_src_decls boot_details ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; - failIfErrsM ; -- Don't typecheck if renaming failed + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed rnDump (ppr rn_splice_expr) ; -- Execute the splice @@ -450,7 +427,7 @@ tc_rn_src_decls boot_details ds setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ - }}} + } } } \end{code} %************************************************************************ @@ -497,7 +474,7 @@ tcRnHsBootDecls decls ; gbl_env <- getGblEnv -- Make the final type-env - -- Include the dfun_ids so that their type sigs get + -- Include the dfun_ids so that their type sigs -- are written into the interface file ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids @@ -525,7 +502,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) checkHiBootIface (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, - tcg_type_env = local_type_env, tcg_imports = imports }) + tcg_type_env = local_type_env }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, md_types = boot_type_env }) = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; @@ -540,8 +517,11 @@ checkHiBootIface ; return (unionManyBags dfun_binds) } where check_one boot_thing - | no_check name - = return () + | isImplicitTyThing boot_thing = return () + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) | Just real_thing <- lookupTypeEnv local_type_env name = do { let boot_decl = tyThingToIfaceDecl boot_thing real_decl = tyThingToIfaceDecl real_thing @@ -554,17 +534,6 @@ checkHiBootIface where name = getName boot_thing - avail_env = imp_parent imports - is_implicit name = case lookupNameEnv avail_env name of - Just (AvailTC tc _) | tc /= name -> True - _otherwise -> False - - no_check name = isWiredInName name -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - || name `elem` dfun_names - || is_implicit name -- Has a parent, which we'll check - dfun_names = map getName boot_insts check_inst boot_inst @@ -576,7 +545,7 @@ checkHiBootIface where boot_dfun = instanceDFunId boot_inst boot_inst_ty = idType boot_dfun - local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty + local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty ---------------- missingBootThing thing @@ -609,17 +578,6 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) - -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_details decls - = do { -- Rename the declarations - (tcg_env, rn_decls) <- rnTopSrcDecls decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the declarations - tcTopSrcDecls boot_details rn_decls - }} - ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group @@ -783,7 +741,7 @@ check_main ghc_mode tcg_env main_mod main_fn ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) (getSrcLoc main_name) - ; root_main_id = mkExportedLocalId root_main_name ty + ; root_main_id = Id.mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env @@ -925,7 +883,7 @@ tcRnStmt hsc_env ictxt rdr_stmt globaliseAndTidy :: Id -> Id globaliseAndTidy id -- Give the Id a Global Name, and tidy its type - = setIdType (globaliseId VanillaGlobal id) tidy_type + = Id.setIdType (globaliseId VanillaGlobal id) tidy_type where tidy_type = tidyTopType (idType id) \end{code} @@ -1085,12 +1043,11 @@ tcRnExpr hsc_env ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; - ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; + ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; tcSimplifyInteractive lie_top ; - qtvs' <- mappM zonkQuantifiedTyVar qtvs ; - let { all_expr_ty = mkForAllTys qtvs' $ - mkFunTys (map idType dict_ids) $ + let { all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map (idType . instToId) dict_insts) $ res_ty } ; zonkTcType all_expr_ty } @@ -1135,18 +1092,34 @@ tcRnType hsc_env ictxt rdr_type -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet) +getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod - = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod) + = let + ic = hsc_IC hsc_env + checkMods = ic_toplev_scope ic ++ ic_exports ic + in + initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods) + +-- Get the export avail info and also load all orphan and family-instance +-- modules. Finally, check that the family instances of all modules in the +-- interactive context are consistent (these modules are in the second +-- argument). +tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] +tcGetModuleExports mod directlyImpMods + = do { let doc = ptext SLIT("context for compiling statements") + ; iface <- initIfaceTcRn $ loadSysInterface doc mod + + -- Load any orphan-module and family instance-module + -- interfaces, so their instances are visible. + ; loadOrphanModules (dep_orphs (mi_deps iface)) False + ; loadOrphanModules (dep_finsts (mi_deps iface)) True -tcGetModuleExports :: Module -> TcM NameSet -tcGetModuleExports mod = do - let doc = ptext SLIT("context for compiling statements") - iface <- initIfaceTcRn $ loadSysInterface doc mod - loadOrphanModules (dep_orphs (mi_deps iface)) - -- Load any orphan-module interfaces, - -- so their instances are visible - ifaceExportNames (mi_exports iface) + -- Check that the family instances of all directly loaded + -- modules are consistent. + ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods + + ; ifaceExportNames (mi_exports iface) + } tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name @@ -1183,6 +1156,12 @@ lookup_rdr_name rdr_name = do { return good_names } +tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) +tcRnRecoverDataCon hsc_env a + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + do name <- recoverDataCon a + tcLookupDataCon name tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name @@ -1218,7 +1197,6 @@ tcRnGetInfo hsc_env name ispecs <- lookupInsts (icPrintUnqual ictxt) thing return (thing, fixity, ispecs) - lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance] -- Filter the instances by the ones whose tycons (or clases resp) -- are in scope unqualified. Otherwise we list a whole lot too many! @@ -1317,6 +1295,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_rules = rules, tcg_imports = imports }) = vcat [ ppr_types insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) @@ -1345,6 +1324,17 @@ ppr_types insts type_env -- that the type checker has invented. Top-level user-defined things -- have External names. +ppr_tycons :: [FamInst] -> TypeEnv -> SDoc +ppr_tycons fam_insts type_env + = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + where + fi_tycons = map famInstTyCon fam_insts + tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] + want_tycon tycon | opt_PprStyle_Debug = True + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_insts :: [Instance] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) @@ -1362,6 +1352,16 @@ ppr_sigs ids le_sig id1 id2 = getOccName id1 <= getOccName id2 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) +ppr_tydecls :: [TyCon] -> SDoc +ppr_tydecls tycons + -- Print type constructor info; sort by OccName + = vcat (map ppr_tycon (sortLe le_sig tycons)) + where + le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 + ppr_tycon tycon + | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon + | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) + ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext SLIT("{-# RULES"),