X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=bd4eb9b54cb2437ac6de138de085c0acf4b48200;hp=ea29fb1256e125c4ad4337bd5037fa23b8e38b0c;hb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index ea29fb1..bd4eb9b 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} @@ -24,116 +25,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 ) -import RdrHsSyn ( findSplice ) - -import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, - main_RDR_Unqual ) -import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) -import TyCon ( isOpenTyCon ) -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 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 IfaceSyn ( checkBootDecl, IfaceExtName(..) ) -import TcSimplify ( tcSimplifyTop ) -import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules ) -import RnNames ( importsFromLocalDecls, rnImports, rnExports, - mkRdrEnvAndImports, mkExportNameSet, - reportUnusedNames, reportDeprecations ) -import RnEnv ( lookupSrcOcc_maybe ) -import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) -import PprCore ( pprRules, pprCoreBindings ) -import CoreSyn ( CoreRule, bindersOfBinds ) -import ErrUtils ( Messages, mkDumpDoc, showPass ) -import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) -import Var ( Var ) +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 +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, isImplicitName, mkExternalName ) +import UniqFM +import Name import NameSet -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), - TypeEnv, lookupTypeEnv, hptInstances, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv - ) +import NameEnv +import TyCon +import SrcLoc +import HscTypes import Outputable #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 NameEnv ( delListFromNameEnv ) -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 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 ) \end{code} @@ -155,7 +113,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec)) + import_decls local_decls mod_deprec _ module_info maybe_doc)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; @@ -168,8 +126,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax setSrcSpan loc $ do { -- Deal with imports; - rn_imports <- rnImports import_decls ; - (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; + (rn_imports, rdr_env, imports) <- rnImports import_decls ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -208,11 +165,20 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set + 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 ; + + let { directlyImpMods = map (\(mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } ; + checkFamInstConsistency (imp_finsts imports) directlyImpMods ; traceRn (text "rn1a") ; -- Rename and type check the declarations @@ -232,9 +198,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list - rn_exports <- rnExports export_ies ; - let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ; - exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ; + (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; + + traceRn (text "rn4") ; + + -- Rename the Haddock documentation header + rn_module_doc <- rnMbHsDoc maybe_doc ; + + -- Rename the Haddock module info + rn_description <- rnMbHsDoc (hmi_description module_info) ; + let { rn_module_info = module_info { hmi_description = rn_description } } ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -245,9 +218,12 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_rn_exports = if save_rn_syntax then rn_exports else Nothing, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports), tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` - mod_deprecs } + mod_deprecs, + tcg_doc = rn_module_doc, + tcg_hmi = rn_module_info + } -- A module deprecation over-rides the earlier ones } ; @@ -306,27 +282,29 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Wrap up let { bndrs = bindersOfBinds core_binds ; - my_exports = mkNameSet (map idName bndrs) ; + my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_usages = [], -- ToDo: compute usage - mg_dir_imps = [], -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_types = final_type_env, - mg_insts = tcg_insts tcg_env, - mg_rules = [], - mg_binds = core_binds, + mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, + mg_usages = [], -- ToDo: compute usage + mg_dir_imps = [], -- ?? + mg_deps = noDependencies, -- ?? + mg_exports = my_exports, + mg_types = final_type_env, + mg_insts = tcg_insts tcg_env, + mg_fam_insts = tcg_fam_insts tcg_env, + mg_rules = [], + mg_binds = core_binds, -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_deprecs = NoDeprecs, + mg_foreign = NoStubs, + mg_hpc_info = noHpcInfo } } ; tcCoreDump mod_guts ; @@ -379,7 +357,6 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - tcDump tcg_env ; (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; @@ -473,7 +450,8 @@ tcRnHsBootDecls decls -- Typecheck instance decls ; traceTc (text "Tc3") - ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group) + ; (tcg_env, inst_infos, _binds) + <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -486,7 +464,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 @@ -513,19 +491,30 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) - (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) + (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + 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)) ; ; mapM_ check_one (typeEnvElts boot_type_env) ; dfun_binds <- mapM check_inst boot_insts + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... ; 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 ext_nm boot_thing - real_decl = tyThingToIfaceDecl ext_nm real_thing + = do { let boot_decl = tyThingToIfaceDecl boot_thing + real_decl = tyThingToIfaceDecl real_thing ; checkTc (checkBootDecl boot_decl real_decl) (bootMisMatch boot_thing boot_decl real_decl) } -- The easiest way to check compatibility is to convert to @@ -535,15 +524,6 @@ checkHiBootIface where name = getName boot_thing - ext_nm name = ExtPkg (nameModule name) (nameOccName name) - -- Just enough to compare; no versions etc needed - - 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 - || isImplicitName name -- Has a parent, which we'll check - dfun_names = map getName boot_insts check_inst boot_inst @@ -555,13 +535,15 @@ 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 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") bootMisMatch thing boot_decl real_decl - = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") + = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"), + ptext SLIT("Decl") <+> ppr real_decl, + ptext SLIT("Boot file:") <+> ppr boot_decl] instMisMatch inst = hang (ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) @@ -628,6 +610,7 @@ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, + hs_derivds = deriv_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, @@ -648,7 +631,8 @@ tcTopSrcDecls boot_details -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; - (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; + (tcg_env, inst_infos, deriv_binds) + <- tcInstDecls1 tycl_decls inst_decls deriv_decls; setGblEnv tcg_env $ do { -- Foreign import declarations next. No zonking necessary @@ -757,8 +741,8 @@ check_main ghc_mode tcg_env main_mod main_fn ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (Just main_name) (getSrcLoc main_name) - ; root_main_id = mkExportedLocalId root_main_name ty + (getSrcLoc main_name) + ; 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 @@ -859,16 +843,30 @@ tcRnStmt hsc_env ictxt rdr_stmt bound_names = map idName global_ids ; new_rn_env = extendLocalRdrEnv rn_env bound_names ; - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out + shadowed = [ n | name <- bound_names, let rdr_name = mkRdrUnqual (nameOccName name), Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; - filtered_type_env = delListFromNameEnv type_env shadowed ; - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; +-------------------------------------------------- -} + new_type_env = extendTypeEnvWithIds type_env global_ids ; new_ic = ictxt { ic_rn_local_env = new_rn_env, ic_type_env = new_type_env } } ; @@ -886,7 +884,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} @@ -963,15 +961,20 @@ mkPlan stmt@(L loc (BindStmt {})) | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) (HsVar thenIOName) placeHolderType + + ; print_bind_result <- doptM Opt_PrintBindResult + ; let print_plan = do + { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + -- The plans are: -- [stmt; print v] but not if v::() -- [stmt] - ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff }, - tcGhciStmts [stmt] - ]} + ; runPlans ((if print_bind_result then [print_plan] else []) ++ + [tcGhciStmts [stmt]]) + } mkPlan stmt = tcGhciStmts [stmt] @@ -1091,17 +1094,20 @@ 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) -tcGetModuleExports :: Module -> TcM NameSet +tcGetModuleExports :: Module -> TcM [AvailInfo] tcGetModuleExports mod = do let doc = ptext SLIT("context for compiling statements") iface <- initIfaceTcRn $ loadSysInterface doc mod - loadOrphanModules (dep_orphs (mi_deps iface)) + loadOrphanModules (dep_orphs (mi_deps iface)) False -- Load any orphan-module interfaces, -- so their instances are visible + loadOrphanModules (dep_finsts (mi_deps iface)) True + -- Load any family instance-module interfaces, + -- so all family instances are visible ifaceExportNames (mi_exports iface) tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) @@ -1267,12 +1273,15 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = dfun_ids, - tcg_rules = rules, - tcg_imports = imports }) - = vcat [ ppr_types dfun_ids type_env - , ppr_insts dfun_ids +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + 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) , ppr_gen_tycons (typeEnvTyCons type_env) , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) @@ -1284,12 +1293,11 @@ pprModGuts (ModGuts { mg_types = type_env, = vcat [ ppr_types [] type_env, ppr_rules rules ] - ppr_types :: [Instance] -> TypeEnv -> SDoc -ppr_types ispecs type_env +ppr_types insts type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where - dfun_ids = map instanceDFunId ispecs + dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && @@ -1300,10 +1308,26 @@ ppr_types ispecs 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) +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts [] = empty +ppr_fam_insts fam_insts = + text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) + ppr_sigs :: [Var] -> SDoc ppr_sigs ids -- Print type signatures; sort by OccName @@ -1312,6 +1336,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"),