X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=a1592ec2a490a4422ecfbc58aad93c9aa8cd7fe1;hp=347d38b3ec18bcd4f85f65012743a810f8bff19e;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=2c1ea2cedb1a8034b0828e24b554a35f56bb8924 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 347d38b..a1592ec 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -26,11 +26,10 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, - nlHsApp, nlHsVar, pprLHsBinds ) + nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) ) import RdrHsSyn ( findSplice ) import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, @@ -39,9 +38,11 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) +import TcType ( tidyTopType, tcEqType ) import Inst ( showLIE ) -import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, + instanceDFunId ) +import FamInstEnv ( FamInst, pprFamInsts ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, iDFunId ) @@ -49,36 +50,39 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) +import MkIface ( tyThingToIfaceDecl ) +import IfaceSyn 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 RnHsDoc ( rnMbHsDoc ) import PprCore ( pprRules, pprCoreBindings ) import CoreSyn ( CoreRule, bindersOfBinds ) -import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import Module +import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - mkExternalName, isInternalName ) + nameModule, nameOccName, mkExternalName ) import NameSet -import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) +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), TyThing(..), + ForeignStubs(NoStubs), availsToNameSet, TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv + emptyFixityEnv, GenAvailInfo(..) ) import Outputable @@ -87,7 +91,7 @@ import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsLocalBinds(..), HsValBinds(..), LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, collectLStmtsBinders, collectLStmtBinders, nlVarPat, - mkFunBind, placeHolderType, noSyntaxExpr ) + mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp ) import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) @@ -96,27 +100,27 @@ 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 ( loadSrcInterface, loadSysInterface ) +import LoadIface ( loadSysInterface ) import IfaceEnv ( ifaceExportNames ) -import Module ( moduleSetElts, mkModuleSet ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( setIdType ) import MkId ( unsafeCoerceId ) import TyCon ( tyConName ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import Kind ( Kind ) +import {- Kind parts of -} Type ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModule, isBuiltInSyntax ) +import Name ( isBuiltInSyntax, isInternalName ) import OccName ( isTcOcc ) -import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, bindIOName, thenIOName, returnIOName ) import HscTypes ( InteractiveContext(..), @@ -124,14 +128,15 @@ import HscTypes ( InteractiveContext(..), Dependencies(..) ) import BasicTypes ( Fixity, RecFlag(..) ) import SrcLoc ( unLoc ) +import Data.Maybe ( isNothing ) #endif import FastString ( mkFastString ) -import Maybes ( MaybeErr(..) ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) -import Maybe ( isJust ) +import Control.Monad ( unless ) +import Data.Maybe ( isJust ) \end{code} @@ -152,30 +157,31 @@ 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_mod = case maybe_mod of - Nothing -> mAIN -- 'module M where' is omitted - Just (L _ mod) -> mod } ; -- The normal case + let { this_pkg = thisPackage (hsc_dflags hsc_env) ; + this_mod = case maybe_mod of + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mkModule this_pkg mod } ; + -- The normal case initTc hsc_env hsc_src this_mod $ 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 :: ModuleEnv (Module, IsBootInterface) + let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file - ; want_instances :: Module -> Bool - ; want_instances mod = mod `elemModuleEnv` dep_mods - && mod /= this_mod + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod ; home_insts = hptInstances hsc_env want_instances } ; @@ -184,8 +190,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- and any other incrementally-performed imports updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - checkConflicts imports this_mod $ do { - -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, @@ -205,6 +209,7 @@ 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 @@ -226,12 +231,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- that we don't bleat about re-exporting a deprecated -- thing (especially via 'module Foo' export item) -- Only uses in the body of the module are complained about - reportDeprecations tcg_env ; + 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 ; + + -- 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 @@ -242,9 +252,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 } ; @@ -254,27 +267,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Dump output and return tcDump final_env ; return final_env - }}}}} - - --- The program is not allowed to contain two modules with the same --- name, and we check for that here. It could happen if the home package --- contains a module that is also present in an external package, for example. -checkConflicts imports this_mod and_then = do - dflags <- getDOpts - let - dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) - -- don't forget to include the current module! - - mb_dep_pkgs = checkForPackageConflicts - dflags dep_mods (imp_dep_pkgs imports) - -- - case mb_dep_pkgs of - Failed msg -> - do addErr msg; failM - Succeeded _ -> - updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) - and_then + }}}} \end{code} @@ -323,28 +316,28 @@ 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_home_mods = mkHomeModules [], -- ?? wrong!! - 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 } } ; tcCoreDump mod_guts ; @@ -397,7 +390,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 ; @@ -449,6 +441,7 @@ tc_rn_src_decls boot_details ds -- Rename the splice expression, and get its supporting decls (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; failIfErrsM ; -- Don't typecheck if renaming failed + rnDump (ppr rn_splice_expr) ; -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; @@ -490,7 +483,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 @@ -530,26 +524,47 @@ 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 }) - = do { mapM_ check_one (typeEnvElts boot_type_env) + (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_type_env = local_type_env, tcg_imports = imports }) + (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 () - | otherwise - = case lookupTypeEnv local_type_env name of - Nothing -> addErrTc (missingBootThing boot_thing) - Just real_thing -> check_thing boot_thing real_thing + | Just real_thing <- lookupTypeEnv local_type_env name + = 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 + -- iface syntax, where we already have good comparison functions + | otherwise + = addErrTc (missingBootThing boot_thing) 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 @@ -564,36 +579,12 @@ checkHiBootIface local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty ---------------- -check_thing (ATyCon boot_tc) (ATyCon real_tc) - | isSynTyCon boot_tc && isSynTyCon real_tc, - defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2 - = return () - - | tyConKind boot_tc == tyConKind real_tc - = return () - where - (tvs1, defn1) = synTyConDefn boot_tc - (tvs2, defn2) = synTyConDefn boot_tc - -check_thing (AnId boot_id) (AnId real_id) - | idType boot_id `tcEqType` idType real_id - = return () - -check_thing (ADataCon dc1) (ADataCon dc2) - | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2) - = return () - - -- Can't declare a class in a hi-boot file - -check_thing boot_thing real_thing -- Default case; failure - = addErrAt (srcLocSpan (getSrcLoc real_thing)) - (bootMisMatch real_thing) - ----------------- missingBootThing thing = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") -bootMisMatch thing - = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") +bootMisMatch thing boot_decl real_decl + = 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")) @@ -660,6 +651,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, @@ -680,7 +672,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 @@ -789,7 +782,7 @@ 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) + (getSrcLoc main_name) ; root_main_id = mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } @@ -891,16 +884,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 } } ; @@ -995,15 +1002,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] @@ -1017,6 +1029,8 @@ tcGhciStmts stmts 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) ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1031,17 +1045,16 @@ tcGhciStmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) (nlHsVar id) } ; -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; - ((tc_stmts, ids), lie) <- getLIE $ - tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ -> - mappM tcLookupId names ; + ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> + mappM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1128,17 +1141,13 @@ getModuleExports hsc_env mod tcGetModuleExports :: Module -> TcM NameSet tcGetModuleExports mod = do - iface <- load_iface mod + 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) -load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} - where - doc = ptext SLIT("context for compiling statements") - - tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1239,7 +1248,9 @@ plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualif = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) where ok name | isBuiltInSyntax name = True - | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | isExternalName name = + isNothing $ fst print_unqual (nameModule name) + (nameOccName name) | otherwise = True loadUnqualIfaces :: InteractiveContext -> TcM () @@ -1300,15 +1311,17 @@ 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_insts insts + , ppr_fam_insts fam_insts , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports)) + , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc @@ -1317,12 +1330,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 && @@ -1337,6 +1349,11 @@ 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