X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=30574ae70632e31072bedada0a1a3d974f177c73;hp=08ea437f211d873a1badddbf4f710685910e9a1d;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=671b39c5b40e5a3105e4ffb49b673b20ce96ba15 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 08ea437..30574ae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,6 +5,13 @@ \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, @@ -12,15 +19,12 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, - tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, tcRnExtCore ) where -#include "HsVersions.h" - import IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) @@ -30,7 +34,6 @@ import DynFlags import StaticFlags import HsSyn import RdrHsSyn - import PrelNames import RdrName import TcHsSyn @@ -41,6 +44,7 @@ import Inst import FamInst import InstEnv import FamInstEnv +import TcAnnotations import TcBinds import TcDefaults import TcEnv @@ -52,6 +56,7 @@ import MkIface import IfaceSyn import TcSimplify import TcTyClsDecls +import TcUnify ( withBox ) import LoadIface import RnNames import RnEnv @@ -61,33 +66,38 @@ import PprCore import CoreSyn import ErrUtils import Id +import VarEnv import Var import Module -import UniqFM +import LazyUniqFM import Name import NameEnv import NameSet import TyCon +import TysWiredIn import SrcLoc import HscTypes import ListSetOps import Outputable +import DataCon +import Type +import Class +import Data.List ( sortBy ) #ifdef GHCI 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 Foreign.Ptr( Ptr ) +import TidyPgm ( globaliseAndTidyId ) #endif import FastString @@ -95,10 +105,10 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad import Data.Maybe ( isJust ) -import Foreign.Ptr ( Ptr ) +#include "HsVersions.h" \end{code} @@ -119,7 +129,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" ; @@ -159,22 +169,24 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- thing (especially via 'module Foo' export item) -- That is, only uses in the *body* of the module are complained about traceRn (text "rn3") ; - failIfErrsM ; -- finishDeprecations crashes sometimes + failIfErrsM ; -- finishWarnings crashes sometimes -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list + traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4") ; + traceRn (text "rn4b: after exportss") ; -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- Make the new type env available to stuff slurped from interface files - -- Must do this after checkHiBootIface, because the latter might add new - -- bindings for boot_dfuns, which may be mentioned in imported unfoldings - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings -- Rename the Haddock documentation tcg_env <- rnHaddock module_info maybe_doc tcg_env ; @@ -198,7 +210,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax \begin{code} tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports) <- rnImports import_decls ; + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -210,7 +222,8 @@ tcRnImports hsc_env this_mod import_decls ; want_instances :: ModuleName -> Bool ; want_instances mod = mod `elemUFM` dep_mods && mod /= moduleName this_mod - ; home_insts = hptInstances hsc_env want_instances + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances } ; -- Record boot-file info in the EPS, so that it's @@ -220,11 +233,15 @@ tcRnImports hsc_env this_mod import_decls -- Update the gbl env ; updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts - }) $ do { + gbl { + tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = rn_imports, + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) -- Fail if there are any errors so far @@ -241,8 +258,7 @@ tcRnImports hsc_env this_mod import_decls -- Check type-familily consistency ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = map (\ (mod, _, _) -> mod) - . moduleEnvElts + ; let { dir_imp_mods = moduleEnvKeys . imp_mods $ imports } ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; @@ -271,24 +287,31 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) let { ldecls = map noLoc decls } ; - -- Deal with the type declarations; first bring their stuff - -- into scope, then rname them, then type check them - tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ; + -- bring the type and class decls into scope + -- ToDo: check that this doesn't need to extract the val binds. + -- It seems that only the type and class decls need to be in scope below because + -- (a) tcTyAndClassDecls doesn't need the val binds, and + -- (b) tcExtCoreBindings doesn't need anything + -- (in fact, it might not even need to be in the scope of + -- this tcg_env at all) + avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; + tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ; - setGblEnv tcg_env $ do { + setEnvs tc_envs $ do { - rn_decls <- rnTyClDecls ldecls ; - failIfErrsM ; + rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ; - -- Make the new type env available to stuff slurped from interface files + -- 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 ; setGblEnv tcg_env $ do { + -- Make the new type env available to stuff slurped from interface files -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; @@ -299,17 +322,19 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; + 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_used_names = emptyNameSet, -- ToDo: compute usage + mg_dir_imps = emptyModuleEnv, -- ?? 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_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], mg_binds = core_binds, @@ -317,10 +342,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Stubs mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, + mg_warns = NoWarnings, mg_foreign = NoStubs, - mg_hpc_info = noHpcInfo, - mg_modBreaks = emptyModBreaks + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo } } ; tcCoreDump mod_guts ; @@ -368,19 +394,25 @@ tcRnSrcDecls boot_iface decls -- 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 + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_rules = rules, + tcg_fords = fords } = tcg_env ; all_binds = binds `unionBags` inst_binds } ; + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + (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, - tcg_binds = binds', + ; tcg_env' = tcg_env { tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' } } ; - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) + setGlobalTypeEnv tcg_env' final_type_env } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -391,8 +423,8 @@ tc_rn_src_decls boot_details ds -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; - -- checkNoErrs: stop if renaming fails + (tcg_env, rn_decls) <- rnTopSrcDecls first_group ; + -- rnTopSrcDecls fails if there are any errors (tcg_env, tcl_env) <- setGblEnv tcg_env $ tcTopSrcDecls boot_details rn_decls ; @@ -442,26 +474,32 @@ tcRnHsBootDecls decls Nothing -> return () -- Rename the declarations - ; (tcg_env, rn_group) <- rnTopSrcDecls first_group + ; (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_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls first_group ; setGblEnv tcg_env $ do { - -- Todo: check no foreign decls, no rules, no default decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck instance decls ; traceTc (text "Tc3") ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) + <- tcInstDecls1 tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations ; traceTc (text "Tc5") - ; val_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_ids <- tcHsBootSigs val_binds -- Wrap up -- No simplification or zonking to do @@ -470,16 +508,23 @@ tcRnHsBootDecls decls -- Make the final type-env -- Include the dfun_ids so that their type sigs - -- are written into the interface file + -- are written into the interface file. + -- And similarly the aux_ids from aux_binds ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos } - ; return (gbl_env { tcg_type_env = type_env2 }) + ; type_env3 = extendTypeEnvWithIds type_env1 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 }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) - = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files")) + = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files")) \end{code} Once we've typechecked the body of the module, we want to compare what @@ -511,15 +556,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 [ noLoc $ VarBind 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 " ++ @@ -528,7 +564,17 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... - ; return tcg_env' } + -- 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 [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + + ; failIfErrsM + ; setGlobalTypeEnv tcg_env' final_type_env } where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -538,7 +584,8 @@ checkHiBootIface -- Check that the actual module exports the same thing | not (null missing_names) - = addErrTc (missingBootThing (head missing_names) "exported by") + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing (head missing_names) "exported by") -- If the boot module does not *define* the thing, we are done -- (it simply re-exports it, and names match, so nothing further to do) @@ -546,13 +593,14 @@ checkHiBootIface -- Check that the actual module also defines the thing, and -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) - real_decl = tyThingToIfaceDecl real_thing - ; checkTc (checkBootDecl boot_decl real_decl) - (bootMisMatch real_thing boot_decl real_decl) } - -- The easiest way to check compatibility is to convert to - -- iface syntax, where we already have good comparison functions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = when (not (checkBootDecl boot_thing real_thing)) + $ addErrAt (nameSrcSpan (getName boot_thing)) + (let boot_decl = tyThingToIfaceDecl + (fromJust mb_boot_thing) + real_decl = tyThingToIfaceDecl real_thing + in bootMisMatch real_thing boot_decl real_decl) | otherwise = addErrTc (missingBootThing name "defined in") @@ -582,19 +630,116 @@ checkHiBootIface local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty +-- This has to compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +checkBootDecl :: TyThing -> TyThing -> Bool + +checkBootDecl (AnId id1) (AnId id2) + = ASSERT(id1 == id2) + (idType id1 `tcEqType` idType id2) + +checkBootDecl (ATyCon tc1) (ATyCon tc2) + | isSynTyCon tc1 && isSynTyCon tc2 + = ASSERT(tc1 == tc2) + let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 + env = rnBndrs2 env0 tvs1 tvs2 + + eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _) + = tcEqTypeX env k1 k2 + eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) + = tcEqTypeX env t1 t2 + in + equalLength tvs1 tvs2 && + eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + + | isAlgTyCon tc1 && isAlgTyCon tc2 + = ASSERT(tc1 == tc2) + eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) + && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + + | isForeignTyCon tc1 && isForeignTyCon tc2 + = tyConExtName tc1 == tyConExtName tc2 + where + env0 = mkRnEnv2 emptyInScopeSet + + eqAlgRhs AbstractTyCon _ = True + eqAlgRhs OpenTyCon{} OpenTyCon{} = True + eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + eqListBy eqCon (data_cons tc1) (data_cons tc2) + eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ = False + + eqCon c1 c2 + = dataConName c1 == dataConName c2 + && dataConIsInfix c1 == dataConIsInfix c2 + && dataConStrictMarks c1 == dataConStrictMarks c2 + && dataConFieldLabels c1 == dataConFieldLabels c2 + && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 + tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 + env = rnBndrs2 env0 tvs1 tvs2 + in + equalLength tvs1 tvs2 && + eqListBy (tcEqPredX env) + (dataConEqTheta c1 ++ dataConDictTheta c1) + (dataConEqTheta c2 ++ dataConDictTheta c2) && + eqListBy (tcEqTypeX env) + (dataConOrigArgTys c1) + (dataConOrigArgTys c2) + +checkBootDecl (AClass c1) (AClass c2) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) + = classExtraBigSig c1 + (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) + = classExtraBigSig c2 + + env0 = mkRnEnv2 emptyInScopeSet + env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 + + eqSig (id1, def_meth1) (id2, def_meth2) + = idName id1 == idName id2 && + tcEqTypeX env op_ty1 op_ty2 + where + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + equalLength clas_tyvars1 clas_tyvars2 && + eqListBy eqFD clas_fds1 clas_fds2 && + (null sc_theta1 && null op_stuff1 + || + eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy eqSig op_stuff1 op_stuff2) + +checkBootDecl (ADataCon dc1) (ADataCon dc2) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + ---------------- missingBootThing thing what - = ppr thing <+> ptext SLIT("is exported by the hs-boot file, but not") - <+> text what <+> ptext SLIT("the module") + = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") + <+> text what <+> ptext (sLit "the module") 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] + = 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 inst = hang (ppr inst) - 2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself")) + 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) \end{code} @@ -618,18 +763,12 @@ monad; it augments it and returns the new TcGblEnv. \begin{code} ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +-- Fails if there are any errors rnTopSrcDecls group - = do { -- Bring top level binders into scope - tcg_env <- importsFromLocalDecls group ; - setGblEnv tcg_env $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- Rename the source decls - (tcg_env, rn_decls) <- rnSrcDecls group ; - failIfErrsM ; + = do { -- Rename the source decls + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - -- save the renamed syntax, if we want it + -- save the renamed syntax, if we want it let { tcg_env' | Just grp <- tcg_rn_decls tcg_env = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } @@ -640,7 +779,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; return (tcg_env', rn_decls) - }} + } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) @@ -650,20 +789,16 @@ tcTopSrcDecls boot_details hs_derivds = deriv_decls, hs_fords = foreign_decls, hs_defds = default_decls, + hs_annds = annotation_decls, hs_ruleds = rule_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ; - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; + -- If there are any errors, tcTyAndClassDecls fails here - -- Make these type and class decls available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; - - setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations @@ -672,8 +807,7 @@ tcTopSrcDecls boot_details <- tcInstDecls1 tycl_decls inst_decls deriv_decls; setGblEnv tcg_env $ do { - -- Foreign import declarations next. No zonking necessary - -- here; we can tuck them straight into the global environment. + -- Foreign import declarations next. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { @@ -683,23 +817,33 @@ tcTopSrcDecls boot_details default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; + -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; - setLclTypeEnv tcl_env $ do { + (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; + (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 -- Foreign exports - -- They need to be zonked, so we return them traceTc (text "Tc7") ; (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + -- Annotations + annotations <- tcAnnotations annotation_decls ; + -- Rules rules <- tcRules rule_decls ; @@ -707,13 +851,16 @@ tcTopSrcDecls boot_details traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` + tc_deriv_binds `unionBags` + tc_aux_binds `unionBags` inst_binds `unionBags` - foe_binds ; + foe_binds; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, tcg_rules = tcg_rules tcg_env ++ rules, + tcg_anns = tcg_anns tcg_env ++ annotations, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', tcl_env) }}}}}} @@ -732,23 +879,16 @@ checkMain :: TcM TcGblEnv checkMain = do { tcg_env <- getGblEnv ; dflags <- getDOpts ; - let { main_mod = mainModIs dflags ; - main_fn = case mainFunIs dflags of { - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; - Nothing -> main_RDR_Unqual } } ; - - check_main dflags tcg_env main_mod main_fn + check_main dflags tcg_env } - -check_main dflags tcg_env main_mod main_fn +check_main dflags tcg_env | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> return tcg_env | otherwise - = addErrCtxt mainCtxt $ - do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupGlobalOccRn_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -756,19 +896,27 @@ check_main dflags tcg_env main_mod main_fn ; complain_no_main ; return tcg_env } ; Just main_name -> do - { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) - ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } - -- :Main.main :: IO () = runMainIO main - ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ - tcInferRho rhs + { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName + ; (main_expr, res_ty) + <- addErrCtxt mainCtxt $ + withBox liftedTypeKind $ \res_ty -> + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS FSLIT("main")) - (getSrcLoc main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name ty - ; main_bind = noLoc (VarBind root_main_id main_expr) } + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = noLoc (VarBind root_main_id rhs) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env `snocBag` main_bind, @@ -779,17 +927,28 @@ check_main dflags tcg_env main_mod main_fn }) }}} where - mod = tcg_mod tcg_env - + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_fn = getMainFun dflags + complain_no_main | ghcLink dflags == LinkInMemory = return () | otherwise = failWithTc noMainMsg -- In interactive mode, don't worry about the absence of 'main' -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. - mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn) - noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) - <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) + mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn + noMainMsg = ptext (sLit "The") <+> pp_main_fn + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case (mainFunIs dflags) of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual \end{code} Note [Root-main Id] @@ -815,30 +974,29 @@ get two defns for 'main' in the interface file! #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 - dfuns = hptInstances hsc_env (\mod -> True) + = 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) in updGblEnv (\env -> env { - tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - - - tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $ - -- tcExtendIdEnv does lots: + tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) + home_fam_insts + }) $ + + tcExtendGhciEnv (ic_tmp_ids icxt) $ + -- tcExtendGhciEnv does lots: -- - it extends the local type env (tcl_env) with the given Ids, -- - it extends the local rdr env (tcl_rdr) with the Names from -- the given Ids -- - it adds the free tyvars of the Ids to the tcl_tyvars -- set. -- - -- We should have no Ids with the same name in the - -- ic_type_env, otherwise we'll end up with shadowing in the - -- tcl_rdr, and it's random which one will be in scope. + -- later ids in ic_tmp_ids must shadow earlier ones with the same + -- OccName, and tcExtendIdEnv implements this behaviour. - do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} @@ -847,9 +1005,10 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] + -> IO (Messages, Maybe ([Id], LHsExpr Id)) + -- The returned [Id] is the list of new Ids bound by + -- this statement. It can be used to extend the + -- InteractiveContext via extendInteractiveContext. -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). @@ -862,6 +1021,7 @@ tcRnStmt hsc_env ictxt rdr_stmt (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; + rnDump (ppr rn_stmt) ; -- The real work is done here (bound_ids, tc_expr) <- mkPlan rn_stmt ; @@ -870,24 +1030,11 @@ 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! - mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; - let { -- (a) Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - -- - -- (b) Tidy their types; this is important, because :info may - -- ask to look at them, and :info expects the things it looks - -- up to have tidy types - global_ids = map globaliseAndTidy zonked_ids ; - - -- Update the interactive context - type_env = ic_type_env ictxt ; - - bound_names = map idName global_ids ; + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -908,35 +1055,40 @@ tcRnStmt hsc_env ictxt rdr_stmt -------------------------------------------------- -} - old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ; - shadowed = [ n | name <- bound_names, - n <- old_bound_names, - nameOccName name == nameOccName n ] ; - - filtered_type_env = delListFromNameEnv type_env shadowed ; - - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; - new_ic = ictxt { ic_type_env = new_type_env } - } ; - dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (new_ic, bound_names, zonked_expr) + return (global_ids, zonked_expr) } where - bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), + bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -globaliseAndTidy :: Id -> Id -globaliseAndTidy id --- Give the Id a Global Name, and tidy its type - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) \end{code} +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in Template Haskell are currently + a) GlobalIds + b) with an Internal Name (not External) + c) and a tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) They retain their Internal names becuase we don't have a suitable + Module to name them with. We could revisit this choice. + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + + +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + Here is the grand plan, implemented in tcUserStmt What you type The IO [HValue] that hscStmt returns @@ -989,7 +1141,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt ; runPlans [ -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; ifM (isUnitTy it_ty) failM + ; when (isUnitTy it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1014,7 +1166,7 @@ mkPlan stmt@(L loc (BindStmt {})) ; 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 + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } -- The plans are: @@ -1033,11 +1185,9 @@ tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { - io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts - (emptyRefinement, io_ret_ty) ; + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1059,16 +1209,18 @@ tcGhciStmts stmts } ; -- OK, we're ready to typecheck the stmts - traceTc (text "tcs 2") ; + traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> - mappM tcLookupId names ; + mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope -- Simplify the context + traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ; const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails + traceTc (text "TcRnDriver.tcGhciStmts: done") ; return (ids, mkHsDictLet const_binds $ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) } @@ -1081,7 +1233,7 @@ tcRnExpr just finds the type of an expression tcRnExpr :: HscEnv -> InteractiveContext -> LHsExpr RdrName - -> IO (Maybe Type) + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1101,7 +1253,7 @@ tcRnExpr hsc_env ictxt rdr_expr zonkTcType all_expr_ty } where - smpl_doc = ptext SLIT("main expression") + smpl_doc = ptext (sLit "main expression") \end{code} tcRnType just finds the kind of a type @@ -1110,7 +1262,7 @@ tcRnType just finds the kind of a type tcRnType :: HscEnv -> InteractiveContext -> LHsType RdrName - -> IO (Maybe Kind) + -> IO (Messages, Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1119,11 +1271,11 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (ty', kind) <- kcLHsType rn_type ; return kind } where - doc = ptext SLIT("In GHCi input") + doc = ptext (sLit "In GHCi input") #endif /* GHCi */ \end{code} @@ -1137,7 +1289,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI --- ASSUMES that the module is either in the HomePackageTable or is +-- | ASSUMES that the module is either in the 'HomePackageTable' or is -- 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. @@ -1155,7 +1307,7 @@ getModuleExports hsc_env mod -- argument). tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] tcGetModuleExports mod directlyImpMods - = do { let doc = ptext SLIT("context for compiling statements") + = do { let doc = ptext (sLit "context for compiling statements") ; iface <- initIfaceTcRn $ loadSysInterface doc mod -- Load any orphan-module and family instance-module @@ -1170,7 +1322,7 @@ tcGetModuleExports mod directlyImpMods ; ifaceExportNames (mi_exports iface) } -tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1205,14 +1357,7 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env ptr - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ do - name <- dataConInfoPtrToName ptr - tcLookupDataCon name - -tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1232,7 +1377,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [Instance])) + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implemnent :info in GHCi -- @@ -1252,21 +1397,17 @@ tcRnGetInfo hsc_env name -- in the home package all relevant modules are loaded.) loadUnqualIfaces ictxt - thing <- tcRnLookupName' name + thing <- tcRnLookupName' name fixity <- lookupFixityRn name - ispecs <- lookupInsts (icPrintUnqual ictxt) thing + ispecs <- lookupInsts 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! -lookupInsts print_unqual (AClass cls) +lookupInsts :: TyThing -> TcM [Instance] +lookupInsts (AClass cls) = do { inst_envs <- tcGetInstEnvs - ; return [ ispec - | ispec <- classInstances inst_envs cls - , plausibleDFun print_unqual (instanceDFunId ispec) ] } + ; return (classInstances inst_envs cls) } -lookupInsts print_unqual (ATyCon tc) +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) @@ -1274,22 +1415,12 @@ lookupInsts print_unqual (ATyCon tc) ; return [ ispec | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie , let dfun = instanceDFunId ispec - , relevant dfun - , plausibleDFun print_unqual dfun ] } + , relevant dfun ] } where relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts print_unqual other = return [] - -plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified - = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) - where - ok name | isBuiltInSyntax name = True - | isExternalName name = - isNothing $ fst print_unqual (nameModule name) - (nameOccName name) - | otherwise = True +lookupInsts other = return [] loadUnqualIfaces :: InteractiveContext -> TcM () -- Load the home module for everything that is in scope unqualified @@ -1305,7 +1436,7 @@ loadUnqualIfaces ictxt not (isInternalName name), 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") + doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") #endif /* GHCI */ \end{code} @@ -1325,8 +1456,8 @@ tcDump env = do { dflags <- getDOpts ; -- Dump short output if -ddump-types or -ddump-tc - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) @@ -1339,8 +1470,8 @@ tcDump env tcCoreDump mod_guts = do { dflags <- getDOpts ; - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn (pprModGuts mod_guts)) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } @@ -1360,8 +1491,16 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , 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)) - , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output + cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, @@ -1419,16 +1558,16 @@ ppr_tydecls tycons where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ppr_tycon tycon - | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr 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"), +ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 4 (pprRules rs), - ptext SLIT("#-}")] + ptext (sLit "#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"), +ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code}