module TcRnDriver (
#ifdef GHCI
mkExportEnv, getModuleContents, tcRnStmt,
- tcRnThing, tcRnExpr, tcRnType,
+ tcRnGetInfo, tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings )
+import TcIface ( tcExtCoreBindings, loadImportedInsts )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import TyCon ( tyConHasGenerics )
import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..),
- GhciMode(..), Dependencies(..), noDependencies,
+import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
+ GhciMode(..), isOneShot, Dependencies(..), noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TypeEnv,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
+ extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
#ifdef GHCI
import TcMType ( zonkTcType )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName )
+import Inst ( tcStdSyntaxName, tcGetInstEnvs )
+import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
import LoadIface ( loadSrcInterface )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceExtName(..), IfaceConDecls(..),
- tyThingToIfaceDecl )
+ IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
+ tyThingToIfaceDecl, dfunToIfaceInst )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, globalIdDetails )
import FieldLabel ( fieldLabelTyCon )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
+import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
import Module ( ModuleName, lookupModuleEnvByName )
-import HscTypes ( InteractiveContext(..),
- HomeModInfo(..), typeEnvElts,
+import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
+ HomeModInfo(..), typeEnvElts, typeEnvClasses,
TyThing(..), availName, availNames, icPrintUnqual,
ModIface(..), ModDetails(..) )
import BasicTypes ( RecFlag(..), Fixity )
addSrcSpan loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
+
+ -- In one-shot mode, record boot-file info in the EPS
+ ifM (isOneShot (hsc_mode hsc_env)) $
+ updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+
+ -- Update the gbl env
updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports })
$ do {
%************************************************************************
%* *
- The interactive interface
+ Type-checking external-core modules
%* *
%************************************************************************
\begin{code}
-#ifdef GHCI
-tcRnStmt :: HscEnv
- -> InteractiveContext
- -> LStmt RdrName
- -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
- -- The returned [Name] is the same as the input except for
- -- ExprStmt, in which case the returned [Name] is [itName]
- --
- -- The returned TypecheckedHsExpr is of type IO [ () ],
- -- a list of the bound values, coerced to ().
+tcRnExtCore :: HscEnv
+ -> HsExtCore RdrName
+ -> IO (Messages, Maybe ModGuts)
+ -- Nothing => some error occurred
-tcRnStmt hsc_env ictxt rdr_stmt
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+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" ;
- -- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
- traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
- failIfErrsM ;
-
- -- The real work is done here
- (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
-
- traceTc (text "tcs 1") ;
- let { -- Make all the bound ids "global" ids, now that
- -- they're notionally top-level bindings. This is
- -- important: otherwise when we come to compile an expression
- -- using these ids later, the byte code generator will consider
- -- the occurrences to be free rather than global.
- global_ids = map (globaliseId VanillaGlobal) bound_ids ;
-
- -- Update the interactive context
- rn_env = ic_rn_local_env ictxt ;
- type_env = ic_type_env ictxt ;
+ initTc hsc_env this_mod $ do {
- bound_names = map idName global_ids ;
- new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+ let { ldecls = map noLoc decls } ;
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
+ -- Deal with the type declarations; first bring their stuff
+ -- into scope, then rname them, then type check them
+ (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
- filtered_type_env = delListFromNameEnv type_env shadowed ;
- new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails` tcg_imports gbl })
+ $ do {
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- } ;
+ rn_decls <- rnTyClDecls ldecls ;
+ failIfErrsM ;
- dumpOptTcRn Opt_D_dump_tc
- (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
- text "Typechecked expr" <+> ppr tc_expr]) ;
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
- returnM (new_ic, bound_names, tc_expr)
- }
-\end{code}
+ -- Typecheck them all together so that
+ -- any mutually recursive types are done right
+ tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
+ -- Make the new type env available to stuff slurped from interface files
+ setGblEnv tcg_env $ do {
+
+ -- Now the core bindings
+ core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
-Here is the grand plan, implemented in tcUserStmt
+ -- Wrap up
+ let {
+ bndrs = bindersOfBinds core_binds ;
+ my_exports = mkNameSet (map idName bndrs) ;
+ -- ToDo: export the data types also?
- What you type The IO [HValue] that hscStmt returns
- ------------- ------------------------------------
- let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
+ final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
- pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
+ mg_deps = noDependencies, -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_rules = [],
+ mg_binds = core_binds,
- expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
- [NB: result not printed] bindings: [it]
-
- expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
- result showable) bindings: [it]
+ -- Stubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_deprecs = NoDeprecs,
+ mg_foreign = NoStubs
+ } } ;
- expr (of non-IO type,
- result not showable) ==> error
+ tcCoreDump mod_guts ;
+ return mod_guts
+ }}}}
-\begin{code}
----------------------------
-tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = noLoc $ FunBind (noLoc fresh_it) False
- [ mkSimpleMatch [] expr placeHolderType ]
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts [
- nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- nlExprStmt (nlHsApp (nlHsVar printName)
- (nlHsVar fresh_it))
- ] })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
+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 = [] }
+\end{code}
-tcUserStmt stmt = tc_stmts [stmt]
----------------------------
-tc_stmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName ;
- let {
- ret_ty = mkListTy unitTy ;
- io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
- names = map unLoc (collectStmtsBinders stmts) ;
+\begin{code}
+tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
+ -- Returns the variables free in the decls
+ -- Reason: solely to report unused imports and bindings
+tcRnSrcDecls decls
+ = do { -- Do all the declarations
+ (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
- stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
- sc_body = check_body,
- sc_ty = ret_ty } ;
+ -- 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.)
+ 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)
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body io_ret_ty ;
+ -- 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 } ;
- -- mk_return builds the expression
- -- returnIO @ [()] [coerce () x, .., coerce () z]
- --
- -- Despite the inconvenience of building the type applications etc,
- -- this *has* to be done in type-annotated post-typecheck form
- -- because we are going to return a list of *polymorphic* values
- -- coerced to type (). If we built a *source* stmt
- -- return [coerce x, ..., coerce z]
- -- 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_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
- (nlHsVar id) ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
+ rules fords ;
- io_ty = mkTyConApp ioTyCon []
- } ;
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
- -- OK, we're ready to typecheck the stmts
- traceTc (text "tcs 2") ;
- ((ids, tc_expr), lie) <- getLIE $ do {
- (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
+ -- Make the new type env available to stuff slurped from interface files
+ writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
- } ;
+ return (tcg_env { tcg_type_env = final_type_env,
+ tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
+ }
- -- 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 ;
+tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+-- Loops around dealing with each top level inter-splice group
+-- in turn, until it's dealt with the entire module
+tc_rn_src_decls ds
+ = do { let { (first_group, group_tail) = findSplice ds } ;
+ -- If ds is [] we get ([], Nothing)
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopLExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
+ -- Type check the decls up to, but not including, the first splice
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
- -- 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) ;
+ -- 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 ;
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
- bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
- nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+ setEnvs tc_envs $
+
+ -- If there is no splice, we're nearly done
+ case group_tail of {
+ Nothing -> do { -- Last thing: check for `main'
+ tcg_env <- checkMain ;
+ return (tcg_env, tcl_env)
+ } ;
+
+ -- If there's a splice, we must carry on
+ Just (SpliceDecl splice_expr, rest_ds) -> do {
+#ifndef GHCI
+ failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
+#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
+
+ -- Execute the splice
+ spliced_decls <- tcSpliceDecls rn_splice_expr ;
+
+ -- Glue them on the front of the remaining decls and loop
+ setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+ tc_rn_src_decls (spliced_decls ++ rest_ds)
+#endif /* GHCI */
+ }}}
\end{code}
-tcRnExpr just finds the type of an expression
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
+
+tcRnGroup takes a bunch of top-level source-code declarations, and
+ * renames them
+ * gets supporting declarations from interface files
+ * typechecks them
+ * zonks them
+ * and augments the TcGblEnv with the results
+
+In Template Haskell it may be called repeatedly for each group of
+declarations. It expects there to be an incoming TcGblEnv in the
+monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnExpr :: HscEnv
- -> InteractiveContext
- -> LHsExpr RdrName
- -> IO (Maybe Type)
-tcRnExpr hsc_env ictxt rdr_expr
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+ -- Returns the variables free in the decls, for unused-binding reporting
+tcRnGroup decls
+ = do { -- Rename the declarations
+ (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
+ setGblEnv tcg_env $ do {
- (rn_expr, fvs) <- rnLExpr rdr_expr ;
- failIfErrsM ;
+ -- Typecheck the declarations
+ tcTopSrcDecls rn_decls
+ }}
- -- 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) ;
- tcSimplifyInteractive lie_top ;
+------------------------------------------------
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+rnTopSrcDecls group
+ = do { -- Bring top level binders into scope
+ (rdr_env, imports) <- importsFromLocalDecls group ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails` tcg_imports gbl })
+ $ do {
- let { all_expr_ty = mkForAllTys qtvs $
- mkFunTys (map idType dict_ids) $
- res_ty } ;
- zonkTcType all_expr_ty
- }
- where
- smpl_doc = ptext SLIT("main expression")
-\end{code}
+ traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-tcRnExpr just finds the kind of a type
+ -- Rename the source decls
+ (tcg_env, rn_decls) <- rnSrcDecls group ;
+ failIfErrsM ;
-\begin{code}
-tcRnType :: HscEnv
- -> InteractiveContext
- -> LHsType RdrName
- -> IO (Maybe Kind)
-tcRnType hsc_env ictxt rdr_type
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
- rn_type <- rnLHsType doc rdr_type ;
- failIfErrsM ;
+ return (tcg_env, rn_decls)
+ }}
- -- Now kind-check the type
- (ty', kind) <- kcHsType rn_type ;
- return kind
- }
- where
- doc = ptext SLIT("In GHCi input")
-\end{code}
+------------------------------------------------
+tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls
+ (HsGroup { hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_valds = val_binds })
+ = do { -- Type-check the type and class decls, and all imported decls
+ -- The latter come in via tycl_decls
+ traceTc (text "Tc2") ;
-\begin{code}
-tcRnThing :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)])
--- Look up a RdrName and return all the TyThings it might be
--- A capitalised RdrName is given to us in the DataName namespace,
--- 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
-tcRnThing hsc_env ictxt rdr_name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
+ -- tcTyAndClassDecls recovers internally, but if anything gave rise to
+ -- an error we'd better stop now, to avoid a cascade
+
+ -- Make these type and class decls available to stuff slurped from interface files
+ writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
- -- 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 ;
+ setGblEnv tcg_env $ do {
+ -- Source-language instances, including derivings,
+ -- and import the supporting declarations
+ traceTc (text "Tc3") ;
+ (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+ setGblEnv tcg_env $ do {
- -- The successful lookups will be (Just name)
- let { (warns_s, good_names) = unzip [ (msgs, name)
- | (msgs, Just name) <- results] ;
- errs_s = [msgs | (msgs, Nothing) <- results] } ;
+ -- Foreign import declarations next. No zonking necessary
+ -- here; we can tuck them straight into the global environment.
+ traceTc (text "Tc4") ;
+ (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
+ tcExtendGlobalValEnv fi_ids $ do {
- -- Fail if nothing good happened, else add warnings
- if null good_names then
- -- No lookup succeeded, so
- -- pick the first error message and report it
- -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
- -- while the other is "X is not in scope",
- -- we definitely want the former; but we might pick the latter
- do { addMessages (head errs_s) ; failM }
- else -- Add deprecation warnings
- mapM_ addMessages warns_s ;
+ -- Default declarations
+ traceTc (text "Tc4a") ;
+ default_tys <- tcDefaults default_decls ;
+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
- -- 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
- ; let decl = toIfaceDecl ictxt thing
- ; fixity <- lookupFixityRn name
- ; return (decl, fixity, getSrcLoc thing) } ;
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
- cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ;
- results <- mapM do_one good_names ;
- return (fst (removeDups cmp results))
- }
+ -- Value declarations next
+ -- 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 {
-toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
-toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True -- Discard IdInfo
- emptyNameSet -- Show data cons
- ext_nm (munge thing)
- where
- unqual = icPrintUnqual ictxt
- ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
- | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
+ -- Second pass over class and instance declarations,
+ traceTc (text "Tc6") ;
+ (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
- -- munge transforms a thing to it's "parent" thing
- munge (ADataCon dc) = ATyCon (dataConTyCon dc)
- munge (AnId id) = case globalIdDetails id of
- RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
- ClassOpId cls -> AClass cls
- other -> AnId id
- munge other_thing = other_thing
-\end{code}
+ -- Foreign exports
+ -- They need to be zonked, so we return them
+ traceTc (text "Tc7") ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Rules
+ rules <- tcRules rule_decls ;
-\begin{code}
-setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext icxt thing_inside
- = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
- (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_type_env = ic_type_env icxt}) $
- updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
- thing_inside)
-#endif /* GHCI */
+ -- Wrap up
+ traceTc (text "Tc7a") ;
+ tcg_env <- getGblEnv ;
+ let { all_binds = tc_val_binds `unionBags`
+ inst_binds `unionBags`
+ foe_binds ;
+
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ 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)
+ }}}}}}
\end{code}
+
%************************************************************************
%* *
- Type-checking external-core modules
+ Checking for 'main'
%* *
%************************************************************************
\begin{code}
-tcRnExtCore :: HscEnv
- -> HsExtCore RdrName
- -> IO (Messages, Maybe ModGuts)
- -- Nothing => some error occurred
-
-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 this_mod $ do {
-
- let { ldecls = map noLoc decls } ;
+checkMain
+ = do { ghci_mode <- getGhciMode ;
+ tcg_env <- getGblEnv ;
- -- Deal with the type declarations; first bring their stuff
- -- into scope, then rname them, then type check them
- (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+ mb_main_mod <- readMutVar v_MainModIs ;
+ mb_main_fn <- readMutVar v_MainFunIs ;
+ let { main_mod = case mb_main_mod of {
+ Just mod -> mkModuleName mod ;
+ Nothing -> mAIN_Name } ;
+ main_fn = case mb_main_fn of {
+ Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Nothing -> main_RDR_Unqual } } ;
+
+ check_main ghci_mode tcg_env main_mod main_fn
+ }
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails` tcg_imports gbl })
- $ do {
- rn_decls <- rnTyClDecls ldecls ;
- failIfErrsM ;
+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!
+ --
+ -- ToDo: We have to return the main_name separately, because it's a
+ -- bona fide 'use', and should be recorded as such, but the others
+ -- aren't
+ --
+ -- Blimey: a whole page of code to do this...
+ | mod_name /= main_mod
+ = return tcg_env
- -- Dump trace of renaming part
- rnDump (ppr rn_decls) ;
+ | otherwise
+ = addErrCtxt mainCtxt $
+ do { mb_main <- lookupSrcOcc_maybe main_fn
+ -- Check that 'main' is in scope
+ -- It might be imported from another module!
+ ; case mb_main of {
+ Nothing -> do { complain_no_main
+ ; return tcg_env } ;
+ Just main_name -> do
+ { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
+ -- :Main.main :: IO () = runIO main
- -- Typecheck them all together so that
- -- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
- -- Make the new type env available to stuff slurped from interface files
+ ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ tcInferRho rhs
- setGblEnv tcg_env $ do {
-
- -- Now the core bindings
- core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
+ ; let { root_main_id = mkExportedLocalId rootMainName ty ;
+ main_bind = noLoc (VarBind root_main_id main_expr) }
- -- Wrap up
- let {
- bndrs = bindersOfBinds core_binds ;
- my_exports = mkNameSet (map idName bndrs) ;
- -- ToDo: export the data types also?
+ ; return (tcg_env { tcg_binds = tcg_binds tcg_env
+ `snocBag` main_bind,
+ tcg_dus = tcg_dus tcg_env
+ `plusDU` usesOnly (unitFV main_name)
+ })
+ }}}
+ where
+ mod_name = moduleName (tcg_mod tcg_env)
+
+ complain_no_main | ghci_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
+ -- and complain a second time when processing the export list.
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+ mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
+ noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
+ <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
+\end{code}
- mod_guts = ModGuts { mg_module = this_mod,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
- -- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
- } } ;
+%*********************************************************
+%* *
+ GHCi stuff
+%* *
+%*********************************************************
- tcCoreDump mod_guts ;
+\begin{code}
+#ifdef GHCI
+setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext icxt thing_inside
+ = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
+ (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt}) $
+ updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
+ thing_inside)
+\end{code}
- return mod_guts
- }}}}
-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 = [] }
-\end{code}
+\begin{code}
+tcRnStmt :: HscEnv
+ -> InteractiveContext
+ -> LStmt RdrName
+ -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
+ -- The returned [Name] is the same as the input except for
+ -- ExprStmt, in which case the returned [Name] is [itName]
+ --
+ -- The returned TypecheckedHsExpr is of type IO [ () ],
+ -- a list of the bound values, coerced to ().
+tcRnStmt hsc_env ictxt rdr_stmt
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
-%************************************************************************
-%* *
- Type-checking the top level of a module
-%* *
-%************************************************************************
+ -- Rename; use CmdLineMode because tcRnStmt is only used interactively
+ ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
+ traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
+ failIfErrsM ;
+
+ -- The real work is done here
+ (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
+
+ traceTc (text "tcs 1") ;
+ let { -- Make all the bound ids "global" ids, now that
+ -- they're notionally top-level bindings. This is
+ -- important: otherwise when we come to compile an expression
+ -- using these ids later, the byte code generator will consider
+ -- the occurrences to be free rather than global.
+ global_ids = map (globaliseId VanillaGlobal) bound_ids ;
+
+ -- Update the interactive context
+ rn_env = ic_rn_local_env ictxt ;
+ type_env = ic_type_env ictxt ;
-\begin{code}
-tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
- -- Returns the variables free in the decls
- -- Reason: solely to report unused imports and bindings
-tcRnSrcDecls decls
- = do { -- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
- -- 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.)
- 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)
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
- -- 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 } ;
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
- let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr tc_expr]) ;
- -- Make the new type env available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
+ returnM (new_ic, bound_names, tc_expr)
+ }
+\end{code}
- return (tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
- }
-tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
--- Loops around dealing with each top level inter-splice group
--- in turn, until it's dealt with the entire module
-tc_rn_src_decls ds
- = do { let { (first_group, group_tail) = findSplice ds } ;
- -- If ds is [] we get ([], Nothing)
+Here is the grand plan, implemented in tcUserStmt
- -- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
+ What you type The IO [HValue] that hscStmt returns
+ ------------- ------------------------------------
+ let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
- -- 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 ;
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
- setEnvs tc_envs $
+ expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
+ [NB: result not printed] bindings: [it]
+
+ expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
+ result showable) bindings: [it]
- -- If there is no splice, we're nearly done
- case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
- return (tcg_env, tcl_env)
- } ;
+ expr (of non-IO type,
+ result not showable) ==> error
- -- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
-#ifndef GHCI
- failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
-#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
+\begin{code}
+---------------------------
+tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
+tcUserStmt (L _ (ExprStmt expr _))
+ = newUnique `thenM` \ uniq ->
+ let
+ fresh_it = itName uniq
+ the_bind = noLoc $ FunBind (noLoc fresh_it) False
+ [ mkSimpleMatch [] expr placeHolderType ]
+ in
+ tryTcLIE_ (do { -- Try this if the other fails
+ traceTc (text "tcs 1b") ;
+ tc_stmts [
+ nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
+ nlExprStmt (nlHsApp (nlHsVar printName)
+ (nlHsVar fresh_it))
+ ] })
+ (do { -- Try this first
+ traceTc (text "tcs 1a") ;
+ tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
- -- Execute the splice
- spliced_decls <- tcSpliceDecls rn_splice_expr ;
+tcUserStmt stmt = tc_stmts [stmt]
- -- Glue them on the front of the remaining decls and loop
- setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
- tc_rn_src_decls (spliced_decls ++ rest_ds)
-#endif /* GHCI */
- }}}
-\end{code}
+---------------------------
+tc_stmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ let {
+ ret_ty = mkListTy unitTy ;
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ names = map unLoc (collectStmtsBinders stmts) ;
-%************************************************************************
-%* *
- Type-checking the top level of a module
-%* *
-%************************************************************************
+ stmt_ctxt = SC { sc_what = DoExpr,
+ sc_rhs = check_rhs,
+ sc_body = check_body,
+ sc_ty = ret_ty } ;
-tcRnGroup takes a bunch of top-level source-code declarations, and
- * renames them
- * gets supporting declarations from interface files
- * typechecks them
- * zonks them
- * and augments the TcGblEnv with the results
+ check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
+ check_body body = tcCheckRho body io_ret_ty ;
-In Template Haskell it may be called repeatedly for each group of
-declarations. It expects there to be an incoming TcGblEnv in the
-monad; it augments it and returns the new TcGblEnv.
+ -- mk_return builds the expression
+ -- returnIO @ [()] [coerce () x, .., coerce () z]
+ --
+ -- Despite the inconvenience of building the type applications etc,
+ -- this *has* to be done in type-annotated post-typecheck form
+ -- because we are going to return a list of *polymorphic* values
+ -- coerced to type (). If we built a *source* stmt
+ -- return [coerce x, ..., coerce z]
+ -- 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_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ (nlHsVar id) ;
-\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
- -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
- setGblEnv tcg_env $ do {
+ io_ty = mkTyConApp ioTyCon []
+ } ;
- -- Typecheck the declarations
- tcTopSrcDecls rn_decls
- }}
+ -- OK, we're ready to typecheck the stmts
+ traceTc (text "tcs 2") ;
+ ((ids, tc_expr), lie) <- getLIE $ do {
+ (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
+ do {
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ ids <- mappM tcLookupId names ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
-------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-rnTopSrcDecls group
- = do { -- Bring top level binders into scope
- (rdr_env, imports) <- importsFromLocalDecls group ;
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails` tcg_imports gbl })
- $ do {
+ io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
+ return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
+ } ;
- traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
- failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+ -- 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 ;
- -- Rename the source decls
- (tcg_env, rn_decls) <- rnSrcDecls group ;
- failIfErrsM ;
+ -- Build result expression and zonk it
+ let { expr = mkHsLet const_binds tc_expr } ;
+ zonked_expr <- zonkTopLExpr expr ;
+ zonked_ids <- zonkTopBndrs ids ;
- -- Dump trace of renaming part
- rnDump (ppr rn_decls) ;
+ -- 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 (tcg_env, rn_decls)
- }}
+ return (zonked_ids, zonked_expr)
+ }
+ where
+ combine stmt (ids, stmts) = (ids, stmt:stmts)
+ bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+ nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+\end{code}
-------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls
- (HsGroup { hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_valds = val_binds })
- = do { -- Type-check the type and class decls, and all imported decls
- -- The latter come in via tycl_decls
- traceTc (text "Tc2") ;
- tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
- -- tcTyAndClassDecls recovers internally, but if anything gave rise to
- -- an error we'd better stop now, to avoid a cascade
-
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+tcRnExpr just finds the type of an expression
+\begin{code}
+tcRnExpr :: HscEnv
+ -> InteractiveContext
+ -> LHsExpr RdrName
+ -> IO (Maybe Type)
+tcRnExpr hsc_env ictxt rdr_expr
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- setGblEnv tcg_env $ do {
- -- Source-language instances, including derivings,
- -- and import the supporting declarations
- traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
- setGblEnv tcg_env $ do {
+ (rn_expr, fvs) <- rnLExpr rdr_expr ;
+ failIfErrsM ;
- -- Foreign import declarations next. No zonking necessary
- -- here; we can tuck them straight into the global environment.
- traceTc (text "Tc4") ;
- (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
- tcExtendGlobalValEnv fi_ids $ do {
+ -- 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) ;
+ tcSimplifyInteractive lie_top ;
- -- Default declarations
- traceTc (text "Tc4a") ;
- default_tys <- tcDefaults default_decls ;
- updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-
- -- Value declarations next
- -- 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 {
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map idType dict_ids) $
+ res_ty } ;
+ zonkTcType all_expr_ty
+ }
+ where
+ smpl_doc = ptext SLIT("main expression")
+\end{code}
- -- Second pass over class and instance declarations,
- traceTc (text "Tc6") ;
- (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
+tcRnExpr just finds the kind of a type
- -- Foreign exports
- -- They need to be zonked, so we return them
- traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+\begin{code}
+tcRnType :: HscEnv
+ -> InteractiveContext
+ -> LHsType RdrName
+ -> IO (Maybe Kind)
+tcRnType hsc_env ictxt rdr_type
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- -- Rules
- rules <- tcRules rule_decls ;
+ rn_type <- rnLHsType doc rdr_type ;
+ failIfErrsM ;
- -- Wrap up
- traceTc (text "Tc7a") ;
- tcg_env <- getGblEnv ;
- let { all_binds = tc_val_binds `unionBags`
- inst_binds `unionBags`
- foe_binds ;
+ -- Now kind-check the type
+ (ty', kind) <- kcHsType rn_type ;
+ return kind
+ }
+ where
+ doc = ptext SLIT("In GHCi input")
- -- Extend the GblEnv with the (as yet un-zonked)
- -- bindings, rules, foreign decls
- 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)
- }}}}}}
+#endif /* GHCi */
\end{code}
-%*********************************************************
-%* *
- mkGlobalContext: make up an interactive context
-
- Used for initialising the lexical environment
- of the interactive read-eval-print loop
-%* *
-%*********************************************************
+%************************************************************************
+%* *
+ More GHCi stuff, to do with browsing and getting info
+%* *
+%************************************************************************
\begin{code}
#ifdef GHCI
mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only
-> IO GlobalRdrEnv
-
mkExportEnv hsc_env exports
= do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
mappM getModuleExports exports
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnvByName hpt mod of
- Just mod_info -> return (map (toIfaceDecl ictxt) $
+ Just mod_info -> return (map toIfaceDecl $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
get_decl avail
= do { thing <- tcLookupGlobal (availName avail)
- ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
+ ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
---------------------
noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
<+> quotes (ppr mod)
-#endif
\end{code}
-%************************************************************************
-%* *
- Checking for 'main'
-%* *
-%************************************************************************
-
\begin{code}
-checkMain
- = do { ghci_mode <- getGhciMode ;
- tcg_env <- getGblEnv ;
+tcRnGetInfo :: HscEnv
+ -> InteractiveContext
+ -> RdrName
+ -> IO (Maybe [(IfaceDecl,
+ Fixity, SrcLoc,
+ [(IfaceInst, SrcLoc)])])
+-- Used to implemnent :info in GHCi
+--
+-- Look up a RdrName and return all the TyThings it might be
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- 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
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- mb_main_mod <- readMutVar v_MainModIs ;
- mb_main_fn <- readMutVar v_MainFunIs ;
- let { main_mod = case mb_main_mod of {
- Just mod -> mkModuleName mod ;
- Nothing -> mAIN_Name } ;
- main_fn = case mb_main_fn of {
- Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
- Nothing -> main_RDR_Unqual } } ;
-
- check_main ghci_mode tcg_env main_mod main_fn
- }
+ -- 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 ;
-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!
- --
- -- ToDo: We have to return the main_name separately, because it's a
- -- bona fide 'use', and should be recorded as such, but the others
- -- aren't
- --
- -- Blimey: a whole page of code to do this...
- | mod_name /= main_mod
- = return tcg_env
+ traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
+ -- The successful lookups will be (Just name)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
- | otherwise
- = addErrCtxt mainCtxt $
- do { mb_main <- lookupSrcOcc_maybe main_fn
- -- Check that 'main' is in scope
- -- It might be imported from another module!
- ; case mb_main of {
- Nothing -> do { complain_no_main
- ; return tcg_env } ;
- Just main_name -> do
- { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
- -- :Main.main :: IO () = runIO main
+ -- Fail if nothing good happened, else add warnings
+ if null good_names then
+ -- No lookup succeeded, so
+ -- pick the first error message and report it
+ -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
+ -- while the other is "X is not in scope",
+ -- we definitely want the former; but we might pick the latter
+ do { addMessages (head errs_s) ; failM }
+ else -- Add deprecation warnings
+ mapM_ addMessages warns_s ;
+
+ -- 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
+ ; let decl = toIfaceDecl thing
+ ; fixity <- lookupFixityRn name
+ ; insts <- lookupInsts thing
+ ; return (decl, fixity, getSrcLoc thing,
+ map mk_inst insts) } ;
+ -- For the SrcLoc, the 'thing' has better info than
+ -- the 'name' because getting the former forced the
+ -- declaration to be loaded into the cache
+ mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
+ cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
+ results <- mapM do_one good_names ;
+ return (fst (removeDups cmp results))
+ }
- ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
- tcInferRho rhs
+lookupInsts :: TyThing -> TcM [DFunId]
+lookupInsts (AClass cls)
+ = do { loadImportedInsts cls [] -- [] means load all instances for cls
+ ; inst_envs <- tcGetInstEnvs
+ ; return [df | (_,_,df) <- classInstances inst_envs cls] }
+
+lookupInsts (ATyCon tc)
+ = do { eps <- getEps -- Load all instances for all classes that are
+ -- in the type environment (which are all the ones
+ -- we've seen in any interface file so far
+ ; mapM_ (\c -> loadImportedInsts c [])
+ (typeEnvClasses (eps_PTE eps))
+ ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
+ ; return (get home_ie ++ get pkg_ie) }
+ where
+ get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
+ relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ tc_name = tyConName tc
- ; let { root_main_id = mkExportedLocalId rootMainName ty ;
- main_bind = noLoc (VarBind root_main_id main_expr) }
+lookupInsts other = return []
- ; return (tcg_env { tcg_binds = tcg_binds tcg_env
- `snocBag` main_bind,
- tcg_dus = tcg_dus tcg_env
- `plusDU` usesOnly (unitFV main_name)
- })
- }}}
+
+toIfaceDecl :: TyThing -> IfaceDecl
+toIfaceDecl thing
+ = tyThingToIfaceDecl True -- Discard IdInfo
+ emptyNameSet -- Show data cons
+ ext_nm (munge thing)
where
- mod_name = moduleName (tcg_mod tcg_env)
-
- complain_no_main | ghci_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
- -- and complain a second time when processing the export list.
+ ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
- mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
- noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
- <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
-\end{code}
+ -- munge transforms a thing to it's "parent" thing
+ munge (ADataCon dc) = ATyCon (dataConTyCon dc)
+ munge (AnId id) = case globalIdDetails id of
+ RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
+ ClassOpId cls -> AClass cls
+ other -> AnId id
+ munge other_thing = other_thing
+#endif /* GHCI */
+\end{code}
%************************************************************************
%* *
projects / ghc-hetmet.git / blobdiff