\begin{code}
module TcRnDriver (
#ifdef GHCI
- getModuleContents, tcRnStmt,
- tcRnGetInfo, GetInfoResult,
- tcRnExpr, tcRnType,
+ tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ tcRnLookupName,
+ tcRnGetInfo,
getModuleExports,
#endif
tcRnModule,
import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
import StaticFlags ( opt_PprStyle_Debug )
-import Packages ( moduleToPackageConfig, mkPackageId, package,
- isHomeModule )
+import Packages ( checkForPackageConflicts, mkHomeModules )
import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
SpliceDecl(..), HsBind(..), LHsBinds,
emptyGroup, appendGroups,
import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import LoadIface ( loadSrcInterface, loadSysInterface )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceExtName(..), IfaceConDecls(..),
- tyThingToIfaceDecl )
-import IfaceType ( IfaceType, toIfaceType,
- interactiveExtNameFun )
-import IfaceEnv ( lookupOrig, ifaceExportNames )
-import Module ( lookupModuleEnv, moduleSetElts, mkModuleSet )
+import IfaceEnv ( ifaceExportNames )
+import Module ( moduleSetElts, mkModuleSet )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( isImplicitId, setIdType, globalIdDetails )
+import Id ( setIdType )
import MkId ( unsafeCoerceId )
-import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule, isBuiltInSyntax, nameParent_maybe )
-import OccName ( occNameUserString, isTcOcc )
+import Name ( nameOccName, nameModule, isBuiltInSyntax )
+import OccName ( isTcOcc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
bindIOName, thenIOName, returnIOName )
-import HscTypes ( InteractiveContext(..), HomeModInfo(..),
- availNames, availName, ModIface(..), icPrintUnqual,
+import HscTypes ( InteractiveContext(..),
+ ModIface(..), icPrintUnqual,
Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
-import Panic ( ghcError, GhcException(..) )
-import SrcLoc ( SrcLoc, unLoc, noSrcSpan )
+import SrcLoc ( unLoc, noSrcSpan )
#endif
import FastString ( mkFastString )
+import Maybes ( MaybeErr(..) )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
- checkForPackageModule (hsc_dflags hsc_env) this_mod;
-
-- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
-- 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 = rdr_env,
-- Dump output and return
tcDump final_env ;
return final_env
- }}}}
-
--- This is really a sanity check that the user has given -package-name
--- if necessary. -package-name is only necessary when the package database
--- already contains the current package, because then we can't tell
--- whether a given module is in the current package or not, without knowing
--- the name of the current package.
-checkForPackageModule dflags this_mod
- | not (isHomeModule dflags this_mod),
- Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
- let
- ppr_pkg = ppr (mkPackageId (package pkg))
- in
- addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
- ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
- ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
- | otherwise = return ()
+ }}}}}
+
+
+-- 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,
-- If not, fail; if so, try to print it.
-- The two-step process avoids getting two errors: one from
-- the expression itself, and one from the 'print it' part
- do { tcGhciStmts [let_stmt]; tcGhciStmts [let_stmt, print_it] }
+ -- This two-step story is very clunky, alas
+ do { checkNoErrs (tcGhciStmts [let_stmt])
+ --- checkNoErrs defeats the error recovery of let-bindings
+ ; tcGhciStmts [let_stmt, print_it] }
]}
mkPlan stmt@(L loc (BindStmt {}))
\begin{code}
#ifdef GHCI
-getModuleExports :: HscEnv -> Module -> IO (Maybe NameSet)
+-- 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.
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
getModuleExports hsc_env mod
- = initTcPrintErrors hsc_env iNTERACTIVE (tcGetModuleExports mod)
+ = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
tcGetModuleExports :: Module -> TcM NameSet
tcGetModuleExports mod = do
-- Load any orphan-module interfaces,
-- so their instances are visible
ifaceExportNames (mi_exports iface)
-\end{code}
-\begin{code}
-getModuleContents
- :: HscEnv
- -> Module -- Module to inspect
- -> Bool -- Grab just the exports, or the whole toplev
- -> IO (Maybe [IfaceDecl])
-
-getModuleContents hsc_env mod exports_only
- = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
- where
- get_mod_contents exports_only
- | not exports_only -- We want the whole top-level type env
- -- so it had better be a home module
- = do { hpt <- getHpt
- ; case lookupModuleEnv hpt mod of
- Just mod_info -> return (map (toIfaceDecl ext_nm) $
- filter wantToSee $
- typeEnvElts $
- md_types (hm_details mod_info))
- Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
- -- This is a system error; the module should be in the HPT
- }
-
- | otherwise -- Want the exports only
- = do { iface <- load_iface mod
- ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
- , avail <- avails ]
- }
-
- get_decl (mod, avail)
- = do { main_name <- lookupOrig mod (availName avail)
- ; thing <- tcLookupGlobal main_name
- ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
-
- ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
-
----------------------
-filter_decl occs decl@(IfaceClass {ifSigs = sigs})
- = decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
- = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
-filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
- | keep_con occs con = decl
- | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
-filter_decl occs decl
- = decl
-
-keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
-keep_con occs con = ifConOcc con `elem` occs
-
-wantToSee (AnId id) = not (isImplicitId id)
-wantToSee (ADataCon _) = False -- They'll come via their TyCon
-wantToSee _ = True
-
----------------------
load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
where
doc = ptext SLIT("context for compiling statements")
----------------------
-noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
- <+> quotes (ppr mod)
-\end{code}
-
-\begin{code}
-type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
- [(IfaceType,SrcLoc)] -- Instances
- )
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
-
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
lookup_rdr_name rdr_name
-
lookup_rdr_name rdr_name = do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
}
+tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ tcLookupGlobal name
+
+
tcRnGetInfo :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [GetInfoResult])
+ -> Name
+ -> IO (Maybe (TyThing, Fixity, [Instance]))
-- Used to implemnent :info in GHCi
--
-- but we want to treat it as *both* a data constructor
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
-tcRnGetInfo hsc_env ictxt rdr_name
+tcRnGetInfo hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env ictxt $ do {
+ let ictxt = hsc_IC hsc_env in
+ setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
-- That way we will find all the instance declarations
-- (Packages have not orphan modules, and we assume that
-- in the home package all relevant modules are loaded.)
- loadUnqualIfaces ictxt ;
-
- good_names <- lookup_rdr_name rdr_name ;
-
- -- And lookup up the entities, avoiding duplicates, which arise
- -- because constructors and record selectors are represented by
- -- their parent declaration
- let { do_one name = do { thing <- tcLookupGlobal name
- ; fixity <- lookupFixityRn name
- ; ispecs <- lookupInsts print_unqual thing
- ; return (str, toIfaceDecl ext_nm thing, fixity,
- getSrcLoc thing,
- [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun)
- | dfun <- map instanceDFunId ispecs ]
- ) }
- where
- -- str is the the naked occurrence name
- -- after stripping off qualification and parens (+)
- str = occNameUserString (nameOccName name)
-
- ; parent_is_there n
- | Just p <- nameParent_maybe n = p `elem` good_names
- | otherwise = False
- } ;
-
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
-
- mapM do_one (filter (not . parent_is_there) good_names)
- -- Filter out names whose parent is also there
- -- Good example is '[]', which is both a type and data constructor
- -- in the same type
- }
- where
- ext_nm = interactiveExtNameFun print_unqual
- print_unqual = icPrintUnqual ictxt
+ loadUnqualIfaces ictxt
+
+ thing <- tcLookupGlobal name
+ fixity <- lookupFixityRn name
+ ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+ return (thing, fixity, ispecs)
+
lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
-- Filter the instances by the ones whose tycons (or clases resp)
| isExternalName name = print_unqual (nameModule name) (nameOccName name)
| otherwise = True
-toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
-toIfaceDecl ext_nm thing
- = tyThingToIfaceDecl ext_nm (munge thing)
- where
- -- munge transforms a thing to its "parent" thing
- munge (ADataCon dc) = ATyCon (dataConTyCon dc)
- munge (AnId id) = case globalIdDetails id of
- RecordSelId tc lbl -> ATyCon tc
- ClassOpId cls -> AClass cls
- other -> AnId id
- munge other_thing = other_thing
-
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
-- This is so that we can accurately report the instances for