From ec0b859902e717c24addff49f9a83efb927fb669 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 16 Mar 2007 13:38:50 +0000 Subject: [PATCH] Refactor TcRnDriver, and check exports on hi-boot files This patch refactors TcRnDriver to make the top-level structure easier to understand. The change was driven by Trac #924, and this patch fixes that bug. When comparing a module against its hs-boot file, we must ensure that the module exports everything that the hs-boot file exports. --- compiler/iface/TcIface.lhs | 7 +- compiler/rename/RnHsDoc.hs | 22 ++- compiler/rename/RnNames.lhs | 71 ++++++---- compiler/rename/RnSource.lhs | 14 +- compiler/typecheck/TcRnDriver.lhs | 265 +++++++++++++++++++------------------ compiler/typecheck/TcRnMonad.lhs | 18 ++- 6 files changed, 217 insertions(+), 180 deletions(-) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 5af949e..d5cc5fd 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -224,11 +224,14 @@ typecheckIface iface %************************************************************************ \begin{code} -tcHiBootIface :: Module -> TcRn ModDetails +tcHiBootIface :: HscSource -> Module -> TcRn ModDetails -- Load the hi-boot iface for the module being compiled, -- if it indeed exists in the transitive closure of imports -- Return the ModDetails, empty if no hi-boot iface -tcHiBootIface mod +tcHiBootIface hsc_src mod + | isHsBoot hsc_src -- Already compiling a hs-boot file + = return emptyModDetails + | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) ; mode <- getGhcMode diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index f3d3690..9fb9348 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -1,17 +1,29 @@ -module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc, rnMbHsDoc ) where +module RnHsDoc ( rnHaddock, rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where +import TcRnTypes import TcRnMonad ( RnM ) import RnEnv ( dataTcOccs, lookupGreRn_maybe ) -import HsDoc ( HsDoc(..) ) +import HsSyn -import RdrName ( RdrName, isRdrDataCon, isRdrTc, gre_name ) +import RdrName ( RdrName, gre_name ) import Name ( Name ) import SrcLoc ( Located(..) ) import Outputable ( ppr, defaultUserStyle ) -import Data.List ( (\\) ) -import Debug.Trace ( trace ) +rnHaddock :: HaddockModInfo RdrName -> Maybe (HsDoc RdrName) + -> TcGblEnv -> RnM TcGblEnv +rnHaddock module_info maybe_doc tcg_env + = do { 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 } } + + ; return (tcg_env { tcg_doc = rn_module_doc, + tcg_hmi = rn_module_info }) } + +rnMbHsDoc :: Maybe (HsDoc RdrName) -> RnM (Maybe (HsDoc Name)) rnMbHsDoc mb_doc = case mb_doc of Just doc -> do doc' <- rnHsDoc doc diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 0c09827..6c35ef1 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -8,7 +8,7 @@ module RnNames ( rnImports, importsFromLocalDecls, rnExports, getLocalDeclBinders, extendRdrEnvRn, - reportUnusedNames, reportDeprecations + reportUnusedNames, finishDeprecations ) where #include "HsVersions.h" @@ -688,41 +688,44 @@ type ExportOccMap = OccEnv (Name, IE RdrName) -- it came from. It's illegal to export two distinct things -- that have the same occurrence name -rnExports :: Bool -- False => no 'module M(..) where' header at all +rnExports :: Bool -- False => no 'module M(..) where' header at all -> Maybe [LIE RdrName] -- Nothing => no explicit export list - -> RnM (Maybe [LIE Name], [AvailInfo]) + -> TcGblEnv + -> RnM TcGblEnv -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -rnExports explicit_mod exports - = do TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports } <- getGblEnv - +rnExports explicit_mod exports + tcg_env@(TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports }) + = do { -- If the module header is omitted altogether, then behave -- as if the user had written "module Main(main) where..." -- EXCEPT in interactive mode, when we behave as if he had -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ghc_mode <- getGhcMode - real_exports <- - case () of - () | explicit_mod - -> return exports - | ghc_mode == Interactive - -> return Nothing - | otherwise - -> do mainName <- lookupGlobalOccRn main_RDR_Unqual - return (Just ([noLoc (IEVar main_RDR_Unqual)])) - -- ToDo: the 'noLoc' here is unhelpful if 'main' turns - -- out to be out of scope - - (exp_spec, avails) <- exports_from_avail real_exports rdr_env imports this_mod - - return (exp_spec, nubAvails avails) -- Combine families + ; ghc_mode <- getGhcMode + ; let real_exports + | explicit_mod = exports + | ghc_mode == Interactive = Nothing + | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + + ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; let final_avails = nubAvails avails -- Combine families + + ; return (tcg_env { tcg_exports = final_avails, + tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly (availsToNameSet final_avails) }) } + exports_from_avail :: Maybe [LIE RdrName] -- Nothing => no explicit export list @@ -904,13 +907,23 @@ check_occs ie occs names %********************************************************* \begin{code} -reportDeprecations :: DynFlags -> TcGblEnv -> RnM () -reportDeprecations dflags tcg_env - = ifOptM Opt_WarnDeprecations $ - do { (eps,hpt) <- getEpsAndHpt +finishDeprecations :: DynFlags -> Maybe DeprecTxt + -> TcGblEnv -> RnM TcGblEnv +-- (a) Report usasge of deprecated imports +-- (b) If the whole module is deprecated, update tcg_deprecs +-- All this happens only once per module +finishDeprecations dflags mod_deprec tcg_env + = do { (eps,hpt) <- getEpsAndHpt + ; ifOptM Opt_WarnDeprecations $ + mapM_ (check hpt (eps_PIT eps)) all_gres -- By this time, typechecking is complete, -- so the PIT is fully populated - ; mapM_ (check hpt (eps_PIT eps)) all_gres } + + -- Deal with a module deprecation; it overrides all existing deprecs + ; let new_deprecs = case mod_deprec of + Just txt -> DeprecAll txt + Nothing -> tcg_deprecs tcg_env + ; return (tcg_env { tcg_deprecs = new_deprecs }) } where used_names = allUses (tcg_dus tcg_env) -- Report on all deprecated uses; hence allUses diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 75af8fd..ca237dd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -6,7 +6,7 @@ \begin{code} module RnSource ( rnSrcDecls, addTcgDUs, - rnTyClDecls, checkModDeprec, + rnTyClDecls, rnSplice, checkTH ) where @@ -23,7 +23,7 @@ import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, - lookupOccRn, lookupTopBndrRn, newLocalsRn, + lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupNames, mapFvRn @@ -31,8 +31,7 @@ import RnEnv ( lookupLocalDataTcNames, import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import HscTypes ( FixityEnv, FixItem(..), - Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) +import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs ) import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet @@ -42,7 +41,7 @@ import Outputable import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) -import Maybe ( isNothing, isJust ) +import Maybe ( isNothing ) import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) \end{code} @@ -254,11 +253,6 @@ rnSrcDeprecDecls decls rn_deprec (Deprecation rdr_name txt) = lookupLocalDataTcNames rdr_name `thenM` \ names -> returnM [(name, (nameOccName name, txt)) | name <- names] - -checkModDeprec :: Maybe DeprecTxt -> Deprecations --- Check for a module deprecation; done once at top level -checkModDeprec Nothing = NoDeprecs -checkModDeprec (Just txt) = DeprecAll txt \end{code} %********************************************************* diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 6c4a35f..f428853 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -91,6 +91,7 @@ import Data.Maybe #endif import FastString +import Maybes import Util import Bag @@ -116,7 +117,8 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec _ module_info maybe_doc)) + 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) ; @@ -125,126 +127,125 @@ tcRnModule hsc_env hsc_src save_rn_syntax Just (L _ mod) -> mkModule this_pkg mod } ; -- The normal case - initTc hsc_env hsc_src this_mod $ + initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { - -- Deal with imports; - (rn_imports, rdr_env, imports) <- rnImports import_decls ; - - 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 :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; home_insts = hptInstances hsc_env want_instances - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - - -- Update the gbl env - updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = if save_rn_syntax then - Just rn_imports - else - Nothing, - tcg_rn_decls = if save_rn_syntax then - Just emptyRnGroup - else - Nothing }) - $ do { - - traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; - -- 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 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 ; + do { -- Deal with imports; + tcg_env <- tcRnImports hsc_env this_mod import_decls ; + setGblEnv tcg_env $ do { - traceRn (text "rn1: checking family instance consistency") ; - let { directlyImpMods = map (\(mod, _, _) -> mod) - . moduleEnvElts - . imp_mods - $ imports } ; - checkFamInstConsistency (imp_finsts imports) directlyImpMods ; + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; - traceRn (text "rn1a") ; -- Rename and type check the declarations + traceRn (text "rn1a") ; tcg_env <- if isHsBoot hsc_src then tcRnHsBootDecls local_decls else - tcRnSrcDecls local_decls ; + tcRnSrcDecls boot_iface 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 - -- We do this before processsing the export list so + -- We do this *before* processsing the export list so -- 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 (hsc_dflags hsc_env) tcg_env ; + -- That is, only uses in the *body* of the module are complained about + traceRn (text "rn3") ; + failIfErrsM ; -- finishDeprecations crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) + tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list - (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; - + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; 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 - let { mod_deprecs = checkModDeprec mod_deprec } ; - - -- Add exports and deprecations to envt - let { final_env = tcg_env { tcg_exports = exports, - tcg_rn_exports = if save_rn_syntax then - rn_exports - else Nothing, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports), - tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` - mod_deprecs, - tcg_doc = rn_module_doc, - tcg_hmi = rn_module_info - } - -- A module deprecation over-rides the earlier ones - } ; + -- 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 ; + + -- Rename the Haddock documentation + tcg_env <- rnHaddock module_info maybe_doc tcg_env ; -- Report unused names - reportUnusedNames export_ies final_env ; + reportUnusedNames export_ies tcg_env ; -- Dump output and return - tcDump final_env ; - return final_env + tcDump tcg_env ; + return tcg_env }}}} \end{code} %************************************************************************ %* * + Import declarations +%* * +%************************************************************************ + +\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 ; + + ; 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 :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; home_insts = hptInstances hsc_env want_instances + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + + -- 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 { + + ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) + -- 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 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 + + -- Check type-familily consistency + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = map (\ (mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + + ; getGblEnv } } +\end{code} + + +%************************************************************************ +%* * Type-checking external-core modules %* * %************************************************************************ @@ -259,7 +260,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env ExtCoreFile this_mod $ do { + initTc hsc_env ExtCoreFile False this_mod $ do { let { ldecls = map noLoc decls } ; @@ -332,18 +333,11 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ \begin{code} -tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv +tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings -tcRnSrcDecls decls - = do { -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - mod <- getModule ; - boot_iface <- tcHiBootIface mod ; - - -- Do all the declarations +tcRnSrcDecls boot_iface decls + = do { -- Do all the declarations (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; -- Finish simplifying class constraints @@ -382,10 +376,7 @@ tcRnSrcDecls decls -- Make the new type env available to stuff slurped from interface files writeMutVar (tcg_type_env_var tcg_env) final_type_env ; - -- Compare the hi-boot iface (if any) with the real thing - dfun_binds <- checkHiBootIface tcg_env' boot_iface ; - - return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) + return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -460,7 +451,7 @@ tcRnHsBootDecls decls -- Typecheck instance decls ; traceTc (text "Tc3") - ; (tcg_env, inst_infos, _binds) + ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) ; setGblEnv tcg_env $ do { @@ -491,7 +482,7 @@ Once we've typechecked the body of the module, we want to compare what we've found (gathered in a TypeEnv) with the hi-boot details (if any). \begin{code} -checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- Compare the hi-boot file for this module (if there is one) -- with the type environment we've just come up with -- In the common case where there is no hi-boot file, the list @@ -501,12 +492,18 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, - tcg_type_env = local_type_env }) + tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, + tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_type_env = local_type_env, tcg_exports = local_exports }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env }) - = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; - ; mapM_ check_one (typeEnvElts boot_type_env) + md_types = boot_type_env, md_exports = boot_exports }) + | isHsBoot hs_src -- Current module is already a hs-boot file! + = return tcg_env + + | otherwise + = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ + ppr local_export_set $$ ppr boot_exports)) ; + ; mapM_ check_export (concatMap availNames boot_exports) ; dfun_binds <- mapM check_inst boot_insts ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -514,28 +511,36 @@ checkHiBootIface -- 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) } + ; return (tcg_env { tcg_binds = binds `unionBags` unionManyBags dfun_binds }) } where - check_one boot_thing - | isImplicitTyThing boot_thing = return () + check_export name -- Name is exported by the boot iface | 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) + | isImplicitTyThing boot_thing = return () | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl boot_thing + = do { checkTc (name `elemNameSet` local_export_set) + (missingBootThing boot_thing "exported by") + + ; 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) + = addErrTc (missingBootThing boot_thing "defined in") where - name = getName boot_thing + boot_thing = lookupTypeEnv boot_type_env name + `orElse` pprPanic "checkHiBootIface" (ppr name) dfun_names = map getName boot_insts + local_export_set :: NameSet + local_export_set = availsToNameSet local_exports + check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, @@ -547,16 +552,20 @@ checkHiBootIface boot_inst_ty = idType boot_dfun 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") +missingBootThing thing what + = 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("Decl") <+> ppr real_decl, - ptext SLIT("Boot file:") <+> ppr boot_decl] + 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")) + 2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself")) \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 06e3d81..56f073f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -71,13 +71,14 @@ ioToTcRn = ioToIOEnv initTc :: HscEnv -> HscSource + -> Bool -- True <=> retain renamed syntax trees -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env hsc_src mod do_this +initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; @@ -86,6 +87,10 @@ initTc hsc_env hsc_src mod do_this th_var <- newIORef False ; dfun_n_var <- newIORef 1 ; let { + maybe_rn_syntax empty_val + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, @@ -101,9 +106,11 @@ initTc hsc_env hsc_src mod do_this tcg_exports = [], tcg_imports = emptyImportAvails, tcg_dus = emptyDUs, - tcg_rn_imports = Nothing, - tcg_rn_exports = Nothing, - tcg_rn_decls = Nothing, + + tcg_rn_imports = maybe_rn_syntax [], + tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], @@ -152,7 +159,7 @@ initTcPrintErrors -- Used from the interactive loop only -> TcM r -> IO (Maybe r) initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile mod todo + (msgs, res) <- initTc env HsSrcFile False mod todo printErrorsAndWarnings (hsc_dflags env) msgs return res \end{code} @@ -161,7 +168,6 @@ initTcPrintErrors env mod todo = do addBreakpointBindings :: TcM a -> TcM a addBreakpointBindings thing_inside = thing_inside - \end{code} %************************************************************************ -- 1.7.10.4