tcRnLookupName,
tcRnGetInfo,
getModuleExports,
+ tcRnRecoverDataCon,
#endif
tcRnModule,
tcTopSrcDecls,
import TcRnMonad
import TcType
import Inst
+import FamInst
import InstEnv
import FamInstEnv
import TcBinds
import Module
import UniqFM
import Name
-import NameSet
import NameEnv
+import NameSet
import TyCon
import SrcLoc
import HscTypes
+import ListSetOps
import Outputable
+import Breakpoints
#ifdef GHCI
+import Linker
+import DataCon
import TcHsType
import TcMType
import TcMatches
import IdInfo
import {- Kind parts of -} Type
import BasicTypes
-import Data.Maybe
#endif
import FastString
+import Maybes
import Util
import Bag
import Control.Monad ( unless )
-import Data.Maybe ( isJust )
\end{code}
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) ;
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 ;
+ do { -- Deal with imports;
+ tcg_env <- tcRnImports hsc_env this_mod import_decls ;
+ setGblEnv tcg_env $ do {
- -- Load any orphan-module interfaces, so that
- -- their rules and instance decls will be found
- loadOrphanModules (imp_orphs imports) ;
+ -- 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 {
- 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 ;
-
- -- 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
- } ;
+ tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
+ traceRn (text "rn4") ;
+
+ -- 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) ;
+
+ -- 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
%* *
%************************************************************************
-- 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 } ;
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
mg_binds = core_binds,
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_foreign = NoStubs,
+ mg_hpc_info = noHpcInfo,
+ mg_dbg_sites = noDbgSites
} } ;
tcCoreDump mod_guts ;
%************************************************************************
\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
- (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
+tcRnSrcDecls boot_iface decls
+ = do { -- Do all the declarations
+ (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+ -- Finish simplifying class constraints
+ --
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
+ -- top-level decl falls under the monomorphism restriction
+ -- and no subsequent decl instantiates its type.
+ --
+ -- We do this after checkMain, so that we use the type info
+ -- thaat checkMain adds
+ --
+ -- We do it with both global and local env in scope:
+ -- * the global env exposes the instances to tcSimplifyTop
+ -- * the local env exposes the local Ids to tcSimplifyTop,
+ -- so that we get better error messages (monomorphism restriction)
traceTc (text "Tc8") ;
inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
- -- Setting the global env exposes the instances to tcSimplifyTop
- -- Setting the local env exposes the local Ids to tcSimplifyTop,
- -- so that we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- 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 } ;
+ let { (tcg_env, _) = tc_envs
+ ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
+ tcg_rules = rules, tcg_fords = fords } = tcg_env
+ ; all_binds = binds `unionBags` inst_binds } ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ (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_rules = rules',
tcg_fords = fords' } } ;
- -- 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)
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
- -- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
+ -- Deal with decls up to, but not including, the first splice
+ (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
+ -- checkNoErrs: stop if renaming fails
- -- Bale out if errors; for example, error recovery when checking
- -- the RHS of 'main' can mean that 'main' is not in the envt for
- -- the subsequent checkMain test
- failIfErrsM ;
-
- setEnvs tc_envs $
+ (tcg_env, tcl_env) <- setGblEnv tcg_env $
+ tcTopSrcDecls boot_details rn_decls ;
-- If there is no splice, we're nearly done
+ setEnvs (tcg_env, tcl_env) $
case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
+ Nothing -> do { tcg_env <- checkMain ; -- Check for `main'
return (tcg_env, tcl_env)
} ;
#else
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
- failIfErrsM ; -- Don't typecheck if renaming failed
+ (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
+ -- checkNoErrs: don't typecheck if renaming failed
rnDump (ppr rn_splice_expr) ;
-- Execute the splice
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
- }}}
+ } } }
\end{code}
%************************************************************************
-- 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 {
; gbl_env <- getGblEnv
-- Make the final type-env
- -- Include the dfun_ids so that their type sigs get
+ -- Include the dfun_ids so that their type sigs
-- are written into the interface file
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
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
-- 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_imports = imports })
+ 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)
- ; dfun_binds <- mapM check_inst boot_insts
+ 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 boot_exports)) ;
+
+ -- 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 " ++
"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) }
+
+ ; return tcg_env' }
where
- check_one boot_thing
- | no_check name
- = return ()
+ check_export boot_avail -- boot_avail 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)
+
+ -- Check that the actual module exports the same thing
+ | not (null missing_names)
+ = addErrTc (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)
+ | isNothing mb_boot_thing = return ()
+
+ -- 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 boot_thing
+ = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
real_decl = tyThingToIfaceDecl real_thing
; checkTc (checkBootDecl boot_decl real_decl)
- (bootMisMatch boot_thing 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
+
| otherwise
- = addErrTc (missingBootThing boot_thing)
+ = addErrTc (missingBootThing name "defined in")
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
-
+ name = availName boot_avail
+ mb_boot_thing = lookupTypeEnv boot_type_env name
+ missing_names = case lookupNameEnv local_export_env name of
+ Nothing -> [name]
+ Just avail -> availNames boot_avail `minusList` availNames avail
+
dfun_names = map getName boot_insts
+ local_export_env :: NameEnv AvailInfo
+ local_export_env = availsToNameEnv local_exports
+
+ check_inst :: Instance -> TcM (Maybe (Id, Id))
+ -- Returns a pair of the boot dfun in terms of the equivalent real dfun
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
- [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
- (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
+ [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+ (dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
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}
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
- -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_details decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
- setGblEnv tcg_env $ do {
-
- -- Typecheck the declarations
- tcTopSrcDecls boot_details rn_decls
- }}
-
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls group
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
checkMain
- = do { ghc_mode <- getGhcMode ;
- tcg_env <- getGblEnv ;
+ = 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 ghc_mode tcg_env main_mod main_fn
+ check_main dflags tcg_env main_mod main_fn
}
-check_main ghc_mode tcg_env main_mod main_fn
+check_main dflags tcg_env main_mod main_fn
| mod /= main_mod
= traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
return tcg_env
; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
- -- The function that the RTS invokes is always :Main.main,
- -- which we call root_main_id.
- -- (Because GHC allows the user to have a module not called
- -- Main as the main module, we can't rely on the main function
- -- being called "Main.main". That's why root_main_id has a fixed
- -- module ":Main".)
- -- We also make root_main_id an implicit Id, by making main_name
- -- its parent (hence (Just main_name)). That has the effect
- -- of preventing its type and unfolding from getting out into
- -- the interface file. Otherwise we can end up with two defns
- -- for 'main' in the interface file!
-
+ -- See Note [Root-main Id]
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS FSLIT("main"))
(getSrcLoc main_name)
where
mod = tcg_mod tcg_env
- complain_no_main | ghc_mode == Interactive = return ()
- | otherwise = failWithTc noMainMsg
+ 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.
<+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
\end{code}
+Note [Root-main Id]
+~~~~~~~~~~~~~~~~~~~
+The function that the RTS invokes is always :Main.main, which we call
+root_main_id. (Because GHC allows the user to have a module not
+called Main as the main module, we can't rely on the main function
+being called "Main.main". That's why root_main_id has a fixed module
+":Main".)
+
+This is unusual: it's a LocalId whose Name has a Module from another
+module. Tiresomely, we must filter it out again in MkIface, les we
+get two defns for 'main' in the interface file!
+
+
%*********************************************************
%* *
GHCi stuff
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
tcSimplifyInteractive lie_top ;
- qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
- let { all_expr_ty = mkForAllTys qtvs' $
- mkFunTys (map idType dict_ids) $
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map (idType . instToId) dict_insts) $
res_ty } ;
zonkTcType all_expr_ty
}
-- could not be found.
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
- = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
+ = let
+ ic = hsc_IC hsc_env
+ checkMods = ic_toplev_scope ic ++ ic_exports ic
+ in
+ initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
+
+-- Get the export avail info and also load all orphan and family-instance
+-- modules. Finally, check that the family instances of all modules in the
+-- interactive context are consistent (these modules are in the second
+-- argument).
+tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
+tcGetModuleExports mod directlyImpMods
+ = do { let doc = ptext SLIT("context for compiling statements")
+ ; iface <- initIfaceTcRn $ loadSysInterface doc mod
-tcGetModuleExports :: Module -> TcM [AvailInfo]
-tcGetModuleExports mod = do
- 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 any orphan-module and family instance-module
+ -- interfaces, so their instances are visible.
+ ; loadOrphanModules (dep_orphs (mi_deps iface)) False
+ ; loadOrphanModules (dep_finsts (mi_deps iface)) True
+
+ -- Check that the family instances of all directly loaded
+ -- modules are consistent.
+ ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
+
+ ; ifaceExportNames (mi_exports iface)
+ }
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
return good_names
}
+tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
+tcRnRecoverDataCon hsc_env a
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ do name <- recoverDataCon a
+ tcLookupDataCon name
tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
tcRnLookupName hsc_env 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)
-- are in scope unqualified. Otherwise we list a whole lot too many!
tcg_rules = rules,
tcg_imports = imports })
= vcat [ ppr_types insts type_env
+ , ppr_tycons fam_insts type_env
, ppr_insts insts
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
-- that the type checker has invented. Top-level user-defined things
-- have External names.
+ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons fam_insts type_env
+ = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+ where
+ fi_tycons = map famInstTyCon fam_insts
+ tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
+ want_tycon tycon | opt_PprStyle_Debug = True
+ | otherwise = not (isImplicitTyCon tycon) &&
+ isExternalName (tyConName tycon) &&
+ not (tycon `elem` fi_tycons)
+
ppr_insts :: [Instance] -> SDoc
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
le_sig id1 id2 = getOccName id1 <= getOccName id2
ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
+ppr_tydecls :: [TyCon] -> SDoc
+ppr_tydecls tycons
+ -- Print type constructor info; sort by OccName
+ = vcat (map ppr_tycon (sortLe le_sig tycons))
+ where
+ le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
+ ppr_tycon 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"),
projects / ghc-hetmet.git / blobdiff