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,
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 TcBinds ( tcTopBinds, tcHsBootSigs )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings, tcHiBootIface )
+import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
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, isImplicitName, mkExternalName )
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
+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),
TypeEnv, lookupTypeEnv, hptInstances,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
emptyFixityEnv
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 IdInfo ( GlobalIdDetails(..) )
import Kind ( 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,
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 Data.Maybe ( isJust )
\end{code}
import_decls local_decls mod_deprec))
= 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 $
rn_imports <- rnImports import_decls ;
(rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
- 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
} ;
-- 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,
-- 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 ;
-- 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}
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,
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)
+ = 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
; 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 ext_nm boot_thing
+ real_decl = tyThingToIfaceDecl ext_nm 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
+ 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
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
+bootMisMatch thing boot_decl real_decl
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
instMisMatch inst
= hang (ppr inst)
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 $
= 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 ()
, ppr_insts dfun_ids
, 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
projects / ghc-hetmet.git / blobdiff