\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkExportEnv, getModuleContents, tcRnStmt,
- tcRnGetInfo, GetInfoResult,
- tcRnExpr, tcRnType,
+ tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ tcRnLookupName,
+ tcRnGetInfo,
+ getModuleExports,
#endif
tcRnModule,
tcTopSrcDecls,
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,
+ emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
-import PrelNames ( runMainIOName, rootMainName, mAIN,
+import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
import TcHsSyn ( zonkTopDecls )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
-import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
+import RnNames ( importsFromLocalDecls, rnImports, rnExports,
+ mkRdrEnvAndImports, mkExportNameSet,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv )
-import OccName ( mkVarOcc )
-import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName )
+import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
+import OccName ( mkVarOccFS )
+import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
+ mkExternalName )
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
import Outputable
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType, mkMatchGroup,
- collectLStmtsBinders, mkSimpleMatch, nlVarPat,
- placeHolderType, noSyntaxExpr )
-import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
- Provenance(..), ImportSpec(..), globalRdrEnvElts,
+import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
+ HsLocalBinds(..), HsValBinds(..),
+ LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
+ collectLStmtsBinders, collectLStmtBinders, nlVarPat,
+ mkFunBind, placeHolderType, noSyntaxExpr )
+import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
-import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
+import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcMType ( zonkTcType, zonkQuantifiedTyVar )
import TcMatches ( tcStmts, tcDoStmt )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
- isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
+ isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
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 SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule )
-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 ListSetOps ( removeDups )
-import Panic ( ghcError, GhcException(..) )
-import SrcLoc ( SrcLoc )
+import BasicTypes ( Fixity, RecFlag(..) )
+import SrcLoc ( unLoc )
#endif
import FastString ( mkFastString )
+import Maybes ( MaybeErr(..) )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env hsc_src save_rn_decls
+tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
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 ;
+ -- Deal with imports;
+ rn_imports <- rnImports import_decls ;
+ (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
let { dep_mods :: ModuleEnv (Module, IsBootInterface)
; dep_mods = imp_dep_mods imports
-- 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,
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
- tcg_rn_decls = if save_rn_decls then
- Just emptyGroup
+ 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 {
reportDeprecations tcg_env ;
-- Process the export list
- exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
+ rn_exports <- rnExports export_ies ;
+ exports <- mkExportNameSet (isJust maybe_mod) rn_exports ;
-- Check whether the entire module is deprecated
-- This happens only once per module
-- 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 exports,
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
mod_deprecs }
-- 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,
}}}}
mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = HsGroup { hs_tyclds = decls, -- This is the one we want
- hs_valds = [], hs_fords = [],
- hs_instds = [], hs_fixds = [], hs_depds = [],
- hs_ruleds = [], hs_defds = [] }
+ = emptyRdrGroup { hs_tyclds = decls }
\end{code}
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 ;
| tyConKind boot_tc == tyConKind real_tc
= return ()
where
- (tvs1, defn1) = getSynTyConDefn boot_tc
- (tvs2, defn2) = getSynTyConDefn boot_tc
+ (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
-- We also typecheck any extra binds that came out
-- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
- setLclTypeEnv lcl_env $ do {
+ (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
+ setLclTypeEnv tcl_env $ do {
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
- (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
+ (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
showLIE (text "after instDecls2") ;
-- Foreign exports
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
tcg_rules = tcg_rules tcg_env ++ rules,
tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', lcl_env)
+ return (tcg_env', tcl_env)
}}}}}}
\end{code}
%************************************************************************
\begin{code}
+checkMain :: TcM TcGblEnv
+-- If we are in module Main, check that 'main' is defined.
checkMain
- = do { ghci_mode <- getGhciMode ;
+ = do { ghc_mode <- getGhcMode ;
tcg_env <- getGblEnv ;
dflags <- getDOpts ;
- let { main_mod = case mainModIs dflags of {
- Just mod -> mkModule mod ;
- Nothing -> mAIN } ;
+ let { main_mod = mainModIs dflags ;
main_fn = case mainFunIs dflags of {
- Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
- check_main ghci_mode tcg_env main_mod main_fn
+ check_main ghc_mode tcg_env main_mod main_fn
}
-check_main ghci_mode tcg_env main_mod main_fn
- -- If we are in module Main, check that 'main' is defined.
- -- It may be imported from another module!
- --
- --
- -- Blimey: a whole page of code to do this...
+check_main ghc_mode tcg_env main_mod main_fn
| mod /= main_mod
- = return tcg_env
+ = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ return tcg_env
| otherwise
= addErrCtxt mainCtxt $
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
- Nothing -> do { complain_no_main
+ Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+ ; complain_no_main
; return tcg_env } ;
Just main_name -> do
- { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
+ { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+ ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
-- :Main.main :: IO () = runMainIO main
; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
- ; let { root_main_id = mkExportedLocalId rootMainName ty ;
- main_bind = noLoc (VarBind root_main_id main_expr) }
+ -- 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!
+
+ ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
+ (mkVarOccFS FSLIT("main"))
+ (Just main_name) (getSrcLoc main_name)
+ ; root_main_id = mkExportedLocalId root_main_name ty
+ ; main_bind = noLoc (VarBind root_main_id main_expr) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
where
mod = tcg_mod tcg_env
- complain_no_main | ghci_mode == Interactive = return ()
+ complain_no_main | ghc_mode == Interactive = 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
failIfErrsM ;
-- The real work is done here
- (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
+ (bound_ids, tc_expr) <- mkPlan rn_stmt ;
+ zonked_expr <- zonkTopLExpr tc_expr ;
+ zonked_ids <- zonkTopBndrs bound_ids ;
+ -- None of the Ids should be of unboxed type, because we
+ -- cast them all to HValues in the end!
+ mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+
traceTc (text "tcs 1") ;
let { -- (a) Make all the bound ids "global" ids, now that
-- they're notionally top-level bindings. This is
-- (b) Tidy their types; this is important, because :info may
-- ask to look at them, and :info expects the things it looks
-- up to have tidy types
- global_ids = map globaliseAndTidy bound_ids ;
+ global_ids = map globaliseAndTidy zonked_ids ;
-- Update the interactive context
rn_env = ic_rn_local_env ictxt ;
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
- text "Typechecked expr" <+> ppr tc_expr]) ;
+ text "Typechecked expr" <+> ppr zonked_expr]) ;
- returnM (new_ic, bound_names, tc_expr)
+ returnM (new_ic, bound_names, zonked_expr)
}
+ where
+ bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+ nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
\begin{code}
---------------------------
-tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L loc (ExprStmt expr _ _))
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = noLoc $ FunBind (noLoc fresh_it) False
- (mkMatchGroup [mkSimpleMatch [] expr])
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts (map (L loc) [
- LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
- (HsVar thenIOName) placeHolderType
- ]) })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr
- (HsVar bindIOName) noSyntaxExpr) ] })
-
-tcUserStmt stmt = tc_stmts [stmt]
+type PlanResult = ([Id], LHsExpr Id)
+type Plan = TcM PlanResult
+
+runPlans :: [Plan] -> TcM PlanResult
+-- Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans [] = panic "runPlans"
+runPlans [p] = p
+runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
+
+--------------------
+mkPlan :: LStmt Name -> TcM PlanResult
+mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+ = do { uniq <- newUnique -- is treated very specially
+ ; let fresh_it = itName uniq
+ the_bind = L loc $ mkFunBind (L loc fresh_it) matches
+ matches = [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
+ bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
+ (HsVar bindIOName) noSyntaxExpr
+ print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ (HsVar thenIOName) placeHolderType
+
+ -- The plans are:
+ -- [it <- e; print it] but not if it::()
+ -- [it <- e]
+ -- [let it = e; print it]
+ ; runPlans [ -- Plan A
+ do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+ ; it_ty <- zonkTcType (idType it_id)
+ ; ifM (isUnitTy it_ty) failM
+ ; return stuff },
+
+ -- Plan B; a naked bind statment
+ tcGhciStmts [bind_stmt],
+
+ -- Plan C; check that the let-binding is typeable all by itself.
+ -- 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
+ -- 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 {}))
+ | [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
+ -- 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]
+ ]}
+
+mkPlan stmt
+ = tcGhciStmts [stmt]
---------------------------
-tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id)
-tc_stmts stmts
+tcGhciStmts :: [LStmt Name] -> TcM PlanResult
+tcGhciStmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
let {
+ io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
-- 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 ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
- (nlHsVar id) ;
-
- io_ty = mkTyConApp ioTyCon []
+ (nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
- ((ids, tc_expr), lie) <- getLIE $ do {
- (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- return ids } ;
-
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
- } ;
-
- -- Simplify the context right here, so that we fail
- -- if there aren't enough instances. Notably, when we see
- -- e
- -- we use recoverTc_ to try it <- e
- -- and then let it = e
- -- It's the simplify step that rejects the first.
- traceTc (text "tcs 3") ;
- const_binds <- tcSimplifyInteractive lie ;
-
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopLExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
-
- -- None of the Ids should be of unboxed type, because we
- -- cast them all to HValues in the end!
- mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
-
- return (zonked_ids, zonked_expr)
- }
- where
- bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
- nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+ ((tc_stmts, ids), lie) <- getLIE $
+ tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
+ mappM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+
+ -- Simplify the context
+ const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ return (ids, mkHsDictLet const_binds $
+ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
+ }
\end{code}
\begin{code}
#ifdef GHCI
-mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
- -> IO GlobalRdrEnv
-mkExportEnv hsc_env exports
- = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
- mappM getModuleExports exports
- ; case mb_envs of
- Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
- Nothing -> return emptyGlobalRdrEnv
- -- Some error; initTc will have printed it
- }
+-- 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
+ = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
+
+tcGetModuleExports :: Module -> TcM NameSet
+tcGetModuleExports mod = do
+ iface <- load_iface mod
+ loadOrphanModules (dep_orphs (mi_deps iface))
+ -- Load any orphan-module interfaces,
+ -- so their instances are visible
+ ifaceExportNames (mi_exports iface)
-getModuleExports :: Module -> TcM GlobalRdrEnv
-getModuleExports mod
- = do { iface <- load_iface mod
- ; loadOrphanModules (dep_orphs (mi_deps iface))
- -- Load any orphan-module interfaces,
- -- so their instances are visible
- ; names <- ifaceExportNames (mi_exports iface)
- ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | name <- nameSetToList names ] }
- ; returnM (mkGlobalRdrEnv gres) }
-
-vanillaProv :: Module -> Provenance
--- We're building a GlobalRdrEnv as if the user imported
--- all the specified modules into the global interactive module
-vanillaProv mod = Imported [ImportSpec mod mod False
- (srcLocSpan interactiveSrcLoc)] False
-\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
-- constructor and type class identifiers.
let { rdr_names = dataTcOccs rdr_name } ;
- -- results :: [(Messages, Maybe Name)]
- results <- mapM (tryTc . lookupOccRn) rdr_names ;
+ -- results :: [Either Messages Name]
+ results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
-- The successful lookups will be (Just name)
}
+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)
- } ;
-
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
-
- results <- mapM do_one good_names ;
- return (fst (removeDups cmp results))
- }
- where
- cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
- 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)
plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
= all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
where
- ok name | 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
+ ok name | isBuiltInSyntax name = True
+ | isExternalName name = print_unqual (nameModule name) (nameOccName name)
+ | otherwise = True
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
projects / ghc-hetmet.git / blobdiff