\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
+ tcRnStmt, tcRnExpr, tcRnType,
+ tcRnLookupRdrName,
+ tcRnLookupName,
+ tcRnGetInfo,
+ getModuleExports,
#endif
- tcRnModule, checkOldIface,
- importSupportingDecls, tcTopSrcDecls,
- tcRnIface, tcRnExtCore
+ tcRnModule,
+ tcTopSrcDecls,
+ tcRnExtCore
) where
#include "HsVersions.h"
+import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
-import DsMeta ( templateHaskellNames )
#endif
-import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
-import DriverState ( v_MainModIs, v_MainFunIs )
-import DriverUtil ( split_longest_prefix )
-import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
- Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
- HsGroup(..), SpliceDecl(..),
- mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
- isSrcRule, collectStmtsBinders
- )
-import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
- emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
-
-import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames,
- returnIOName, runIOName,
- dollarMainName, itName, mAIN_Name, unsafeCoerceName
- )
-import MkId ( unsafeCoerceId )
-import RdrName ( RdrName, getRdrName, mkRdrUnqual,
- lookupRdrEnv, elemRdrEnv )
-
-import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
- ruleDeclFVs, instDeclFVs, tyClDeclFVs )
-import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
- zonkTopDecls, mkHsLet,
- zonkTopExpr, zonkTopBndrs
- )
-
-import TcExpr ( tcInferRho, tcCheckRho )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_PprStyle_Debug )
+import Packages ( checkForPackageConflicts, mkHomeModules )
+import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
+ SpliceDecl(..), HsBind(..), LHsBinds,
+ emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
+ nlHsApp, nlHsVar, pprLHsBinds )
+import RdrHsSyn ( findSplice )
+
+import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
+ main_RDR_Unqual )
+import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
+import TcHsSyn ( zonkTopDecls )
+import TcExpr ( tcInferRho )
import TcRnMonad
-import TcMType ( newTyVarTy, zonkTcType )
-import TcType ( Type, liftedTypeKind,
- tyVarsOfType, tcFunResultTy, tidyTopType,
- mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
- )
-import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
-import Inst ( showLIE, tcStdSyntaxName )
-import TcBinds ( tcTopBinds )
-import TcClassDcl ( tcClassDecls2 )
+import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
+import Inst ( showLIE )
+import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
+import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv,
- tcExtendInstEnv, tcExtendRules,
- tcLookupTyCon, tcLookupGlobal,
- tcLookupId
- )
+import TcEnv ( tcExtendGlobalValEnv, iDFunId )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
-import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
-import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
-import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
+import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
+import TcIface ( tcExtCoreBindings, tcHiBootIface )
+import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
+import LoadIface ( loadOrphanModules )
+import RnNames ( importsFromLocalDecls, rnImports, rnExports,
+ reportUnusedNames, reportDeprecations )
+import RnEnv ( lookupSrcOcc_maybe )
+import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
+import PprCore ( pprRules, pprCoreBindings )
+import CoreSyn ( CoreRule, bindersOfBinds )
+import DataCon ( dataConWrapId )
+import ErrUtils ( Messages, mkDumpDoc, showPass )
+import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
+import Var ( Var )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv )
+import OccName ( mkVarOcc, mkOccFS, varName )
+import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
+ mkExternalName )
+import NameSet
+import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import SrcLoc ( srcLocSpan, Located(..), noLoc )
+import DriverPhases ( HscSource(..), isHsBoot )
+import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
+ HscEnv(..), ExternalPackageState(..),
+ IsBootInterface, noDependencies,
+ Deprecs( NoDeprecs ), plusDeprecs,
+ ForeignStubs(NoStubs), TyThing(..),
+ TypeEnv, lookupTypeEnv, hptInstances,
+ extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
+ emptyFixityEnv
+ )
+import Outputable
-import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
- reportUnusedNames )
-import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
-import RnHiFiles ( readIface, loadOldIface )
-import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
- ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
-import RnExpr ( rnStmts, rnExpr )
-import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
-
-import CoreUnfold ( unfoldingTemplate )
-import CoreSyn ( IdCoreRule, Bind(..) )
-import PprCore ( pprIdRules, pprCoreBindings )
+#ifdef GHCI
+import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
+ HsLocalBinds(..), HsValBinds(..),
+ LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds,
+ collectLStmtsBinders, collectLStmtBinders, nlVarPat,
+ placeHolderType, noSyntaxExpr )
+import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
+ unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
+import RnSource ( addTcgDUs )
+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, 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 IfaceEnv ( ifaceExportNames )
+import Module ( moduleSetElts, mkModuleSet )
+import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
+import Id ( setIdType )
+import MkId ( unsafeCoerceId )
+import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
-import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
-import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
import IdInfo ( GlobalIdDetails(..) )
-import Var ( Var, setGlobalIdDetails )
-import Module ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
-import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, nameOccName )
+import Kind ( Kind )
+import Var ( globaliseId )
+import Name ( nameOccName, nameModule, isBuiltInSyntax )
+import OccName ( isTcOcc )
import NameEnv ( delListFromNameEnv )
-import NameSet
-import TyCon ( tyConGenInfo )
-import BasicTypes ( EP(..), RecFlag(..) )
-import SrcLoc ( noSrcLoc )
-import Outputable
-import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
- ModIface, ModDetails(..), ModGuts(..),
- HscEnv(..),
- ModIface(..), ModDetails(..), IfaceDecls(..),
- GhciMode(..), noDependencies,
- Deprecations(..), plusDeprecs,
- emptyGlobalRdrEnv,
- GenAvailInfo(Avail), availsToNameSet,
- ForeignStubs(..),
- TypeEnv, TyThing, typeEnvTyCons,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
- extendLocalRdrEnv, emptyFixityEnv
- )
-#ifdef GHCI
-import RdrName ( rdrEnvElts )
-import RnHiFiles ( loadInterface )
-import RnEnv ( mkGlobalRdrEnv )
-import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
- isLocalGRE )
+import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
+ bindIOName, thenIOName, returnIOName )
+import HscTypes ( InteractiveContext(..),
+ ModIface(..), icPrintUnqual,
+ Dependencies(..) )
+import BasicTypes ( Fixity )
+import SrcLoc ( unLoc )
#endif
-import DATA_IOREF ( readIORef )
import FastString ( mkFastString )
-import Panic ( showException )
-import List ( partition )
-import Util ( sortLt )
+import Maybes ( MaybeErr(..) )
+import Util ( sortLe )
+import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+
+import Maybe ( isJust )
\end{code}
\begin{code}
-tcRnModule :: HscEnv -> PersistentCompilerState
- -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe TcGblEnv)
-
-tcRnModule hsc_env pcs
- (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
+tcRnModule :: HscEnv
+ -> HscSource
+ -> Bool -- True <=> save renamed syntax
+ -> Located (HsModule RdrName)
+ -> IO (Messages, Maybe TcGblEnv)
+
+tcRnModule hsc_env hsc_src save_rn_decls
+ (L loc (HsModule maybe_mod export_ies
+ import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_mod = case maybe_mod of
- Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted
- Just mod -> mod } ; -- The normal case
+ Nothing -> mAIN -- 'module M where' is omitted
+ Just (L _ mod) -> mod } ; -- The normal case
- initTc hsc_env pcs this_mod $ addSrcLoc loc $
- do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
+ initTc hsc_env hsc_src this_mod $
+ setSrcSpan loc $
+ do {
+ -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
- updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
- tcg_imports = tcg_imports gbl `plusImportAvails` imports })
- $ do {
+
+ let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports
+
+ -- We want instance declarations from all home-package
+ -- modules below this one, including boot modules, except
+ -- ourselves. The 'except ourselves' is so that we don't
+ -- get the instances from this module's hs-boot file
+ ; want_instances :: Module -> Bool
+ ; want_instances mod = mod `elemModuleEnv` dep_mods
+ && mod /= this_mod
+ ; 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 }) ;
+
+ 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 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
failIfErrsM ;
+ -- Load any orphan-module interfaces, so that
+ -- their rules and instance decls will be found
+ loadOrphanModules (imp_orphs imports) ;
+
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
+ tcg_env <- if isHsBoot hsc_src then
+ tcRnHsBootDecls local_decls
+ else
+ tcRnSrcDecls 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
+ -- that we don't bleat about re-exporting a deprecated
+ -- thing (especially via 'module Foo' export item)
+ -- Only uses in the body of the module are complained about
+ reportDeprecations tcg_env ;
+
+ -- Process the export list
+ exports <- rnExports (isJust maybe_mod) export_ies ;
+
-- Check whether the entire module is deprecated
-- This happens only once per module
- -- Returns the full new deprecations; a module deprecation
- -- over-rides the earlier ones
let { mod_deprecs = checkModDeprec mod_deprec } ;
- updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
- $ do {
- -- Process the export list
- export_avails <- exportsFromAvail maybe_mod exports ;
- updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
- $ do {
-
- -- Get any supporting decls for the exports that have not already
- -- been sucked in for the declarations in the body of the module.
- -- (This can happen if something is imported only to be re-exported.)
- --
- -- Importing these supporting declarations is required
- -- *only* to gether usage information
- -- (see comments with MkIface.mkImportInfo for why)
- -- For OneShot compilation we could just throw away the decls
- -- but for Batch or Interactive we must put them in the type
- -- envt because they've been removed from the holding pen
- let { export_fvs = availsToNameSet export_avails } ;
- tcg_env <- importSupportingDecls export_fvs ;
- setGblEnv tcg_env $ do {
+ -- Add exports and deprecations to envt
+ let { final_env = tcg_env { tcg_exports = exports,
+ tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
+ tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
+ mod_deprecs }
+ -- A module deprecation over-rides the earlier ones
+ } ;
-- Report unused names
- let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
- reportUnusedNames tcg_env all_dus ;
+ reportUnusedNames export_ies final_env ;
-- Dump output and return
- tcDump tcg_env ;
- return tcg_env
- }}}}}}}
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Closing up the interface decls}
-%* *
-%*********************************************************
-
-Suppose we discover we don't need to recompile. Then we start from the
-IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
-
-\begin{code}
-tcRnIface :: HscEnv
- -> PersistentCompilerState
- -> ModIface -- Get the decls from here
- -> IO (PersistentCompilerState, Maybe ModDetails)
- -- Nothing <=> errors happened
-tcRnIface hsc_env pcs
- (ModIface {mi_module = mod, mi_decls = iface_decls})
- = initTc hsc_env pcs mod $ do {
-
- -- Get the supporting decls, and typecheck them all together
- -- so that any mutually recursive types are done right
- extra_decls <- slurpImpDecls needed ;
- env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
-
- returnM (ModDetails { md_types = tcg_type_env env,
- md_insts = tcg_insts env,
- md_rules = hsCoreRules (tcg_rules env)
- -- All the rules from an interface are of the IfaceRuleOut form
- }) }
- where
- rule_decls = dcl_rules iface_decls
- inst_decls = dcl_insts iface_decls
- tycl_decls = dcl_tycl iface_decls
- group = emptyGroup { hs_ruleds = rule_decls,
- hs_instds = inst_decls,
- hs_tyclds = tycl_decls }
- needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
- unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
- unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
- ubiquitousNames
- -- Data type decls with record selectors,
- -- which may appear in the decls, need unpackCString
- -- and friends. It's easier to just grab them right now.
-
-hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
--- All post-typechecking Iface rules have the form IfaceRuleOut
-hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
+ tcDump final_env ;
+ return final_env
+ }}}}}
+
+
+-- The program is not allowed to contain two modules with the same
+-- name, and we check for that here. It could happen if the home package
+-- contains a module that is also present in an external package, for example.
+checkConflicts imports this_mod and_then = do
+ dflags <- getDOpts
+ let
+ dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports))
+ -- don't forget to include the current module!
+
+ mb_dep_pkgs = checkForPackageConflicts
+ dflags dep_mods (imp_dep_pkgs imports)
+ --
+ case mb_dep_pkgs of
+ Failed msg ->
+ do addErr msg; failM
+ Succeeded _ ->
+ updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods })
+ and_then
\end{code}
%************************************************************************
%* *
- The interactive interface
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef GHCI
-tcRnStmt :: HscEnv -> PersistentCompilerState
- -> InteractiveContext
- -> RdrNameStmt
- -> IO (PersistentCompilerState,
- Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
- -- 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 pcs ictxt rdr_stmt
- = initTc hsc_env pcs iNTERACTIVE $
- setInteractiveContext ictxt $ do {
-
- -- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ([rn_stmt], fvs) <- initRnInteractive ictxt
- (rnStmts DoExpr [rdr_stmt]) ;
- traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
- failIfErrsM ;
-
- -- Suck in the supporting declarations and typecheck them
- tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
- -- NB: an earlier version deleted (rdrEnvElts local_env) from
- -- the fvs. But (a) that isn't necessary, because previously
- -- bound things in the local_env will be in the TypeEnv, and
- -- the renamer doesn't re-slurp such things, and
- -- (b) it's WRONG to delete them. Consider in GHCi:
- -- Mod> let x = e :: T
- -- Mod> let y = x + 3
- -- We need to pass 'x' among the fvs to slurpImpDecls, so that
- -- the latter can see that T is a gate, and hence import the Num T
- -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
- setGblEnv tcg_env $ do {
-
- -- 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 bound_ids ;
- globaliseId id = setGlobalIdDetails id VanillaGlobal ;
-
- -- Update the interactive context
- rn_env = ic_rn_local_env ictxt ;
- type_env = ic_type_env ictxt ;
-
- bound_names = map idName global_ids ;
- new_rn_env = extendLocalRdrEnv rn_env bound_names ;
-
- -- 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 <- [lookupRdrEnv rn_env rdr_name] ] ;
-
- filtered_type_env = delListFromNameEnv type_env shadowed ;
- new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
-
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- } ;
-
- dumpOptTcRn Opt_D_dump_tc
- (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
- text "Typechecked expr" <+> ppr tc_expr]) ;
-
- returnM (new_ic, bound_names, tc_expr)
- }}
-\end{code}
-
-
-Here is the grand plan, implemented in tcUserStmt
-
- 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,...]
-
- pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
-
- expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
- [NB: result not printed] bindings: [it]
-
- expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
- result showable) bindings: [it]
-
- expr (of non-IO type,
- result not showable) ==> error
-
-
-\begin{code}
----------------------------
-tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
-tcUserStmt (ExprStmt expr _ loc)
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = FunMonoBind fresh_it False
- [ mkSimpleMatch [] expr placeHolderType loc ] loc
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts [
- LetStmt (MonoBind the_bind [] NonRecursive),
- ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
- placeHolderType loc] })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
-
-tcUserStmt stmt = tc_stmts [stmt]
-
----------------------------
-tc_stmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName ;
- let {
- ret_ty = mkListTy unitTy ;
- names = collectStmtsBinders stmts ;
-
- stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
- sc_body = check_body,
- sc_ty = ret_ty } ;
-
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ;
-
- -- ret_expr is the expression
- -- returnIO [coerce () x, .., coerce () z]
- ret_stmt = ResultStmt ret_expr noSrcLoc ;
- ret_expr = HsApp (HsVar returnIOName)
- (ExplicitList placeHolderType (map mk_item names)) ;
- mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
-
- all_stmts = stmts ++ [ret_stmt] ;
-
- io_ty = mkTyConApp ioTyCon []
- } ;
-
- -- 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 all_stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- return (ids, []) } ;
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, HsDo DoExpr tc_stmts io_ids
- (mkTyConApp ioTyCon [ret_ty]) noSrcLoc)
- } ;
-
- -- 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 <- tcSimplifyTop lie ;
-
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
-
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
-\end{code}
-
-
-tcRnExpr just finds the type of an expression
-
-\begin{code}
-tcRnExpr :: HscEnv -> PersistentCompilerState
- -> InteractiveContext
- -> RdrNameHsExpr
- -> IO (PersistentCompilerState, Maybe Type)
-tcRnExpr hsc_env pcs ictxt rdr_expr
- = initTc hsc_env pcs iNTERACTIVE $
- setInteractiveContext ictxt $ do {
-
- (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
- failIfErrsM ;
-
- -- Suck in the supporting declarations and typecheck them
- tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
- setGblEnv tcg_env $ 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) ;
- tcSimplifyTop lie_top ;
-
- 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}
-
-
-\begin{code}
-tcRnThing :: HscEnv -> PersistentCompilerState
- -> InteractiveContext
- -> RdrName
- -> IO (PersistentCompilerState, Maybe [TyThing])
--- Look up a RdrName and return all the TyThings it might be
--- We treat a capitalised RdrName as both a data constructor
--- and as a type or class constructor; hence we return up to two results
-tcRnThing hsc_env pcs ictxt rdr_name
- = initTc hsc_env pcs iNTERACTIVE $
- setInteractiveContext ictxt $ 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 <- initRnInteractive ictxt
- (mapM (tryTc . lookupOccRn) rdr_names) ;
-
- -- 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] } ;
-
- -- Fail if nothing good happened, else add warnings
- if null good_names then -- Fail
- do { addMessages (head errs_s) ; failM }
- else -- Add deprecation warnings
- mapM_ addMessages warns_s ;
-
- -- Slurp in the supporting declarations
- tcg_env <- importSupportingDecls (mkFVs good_names) ;
- setGblEnv tcg_env $ do {
-
- -- And lookup up the entities
- mapM tcLookupGlobal good_names
- }}
-\end{code}
-
-
-\begin{code}
-setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m 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 })
- thing_inside
-
-initRnInteractive :: InteractiveContext -> RnM a -> TcM a
--- Set the local RdrEnv from the interactive context
-initRnInteractive ictxt rn_thing
- = initRn CmdLineMode $
- setLocalRdrEnv (ic_rn_local_env ictxt) $
- rn_thing
-#endif
-\end{code}
-
-%************************************************************************
-%* *
Type-checking external-core modules
%* *
%************************************************************************
\begin{code}
-tcRnExtCore :: HscEnv -> PersistentCompilerState
- -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe ModGuts)
+tcRnExtCore :: HscEnv
+ -> HsExtCore RdrName
+ -> IO (Messages, Maybe ModGuts)
-- Nothing => some error occurred
-tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
- -- For external core, the module name is syntactically reqd
- -- Rename the (Core) module. It's a bit like an interface
- -- file: all names are original names
+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 pcs this_mod $ addSrcLoc loc $ do {
+ initTc hsc_env ExtCoreFile this_mod $ do {
- -- Rename the source, only in interface mode.
- -- rnSrcDecls handles fixity decls etc too, which won't occur
- -- but that doesn't matter
- let { local_group = mkGroup decls } ;
- (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
- (rnSrcDecls local_group) ;
- failIfErrsM ;
+ let { ldecls = map noLoc decls } ;
- -- Get the supporting decls
- rn_imp_decls <- slurpImpDecls (duUses dus) ;
- let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
+ -- Deal with the type declarations; first bring their stuff
+ -- into scope, then rname them, then type check them
+ tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+
+ setGblEnv tcg_env $ do {
+
+ rn_decls <- rnTyClDecls ldecls ;
+ failIfErrsM ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
- rnStats rn_imp_decls ;
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- typecheckIfaceDecls rn_decls ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
+ -- Make the new type env available to stuff slurped from interface files
+
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
- tcExtendGlobalValEnv (map fst core_prs) $ do {
-
+ core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
+
-- Wrap up
let {
- bndrs = map fst core_prs ;
- my_exports = map (Avail . idName) bndrs ;
+ bndrs = bindersOfBinds core_binds ;
+ my_exports = mkNameSet (map idName bndrs) ;
-- ToDo: export the data types also?
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
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,
- mg_rules = hsCoreRules (tcg_rules tcg_env),
- mg_binds = [Rec core_prs],
+ mg_rules = [],
+ mg_binds = core_binds,
-- Stubs
mg_rdr_env = emptyGlobalRdrEnv,
return mod_guts
}}}}
+
+mkFakeGroup decls -- Rather clumsy; lots of unused fields
+ = emptyRdrGroup { hs_tyclds = decls }
\end{code}
%************************************************************************
\begin{code}
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
+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, dus), lie) <- getLIE (tc_rn_src_decls 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) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
traceTc (text "Tc8") ;
- setEnvs tc_envs $ do {
+ inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
-- Setting the global env exposes the instances to tcSimplifyTop
- -- Setting the local env exposes the local Ids, so that
- -- we get better error messages (monomorphism restriction)
- inst_binds <- tcSimplifyTop lie ;
+ -- 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.
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
- return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
- tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
- dus)
- }}
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+ ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
+ tcg_binds = binds',
+ 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 ;
-tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+ -- Compare the hi-boot iface (if any) with the real thing
+ dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
-tc_rn_src_decls ds
+ return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
+ }
+
+tc_rn_src_decls :: ModDetails -> [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 boot_details ds
= 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@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
-- If there is no splice, we're nearly done
case group_tail of {
Nothing -> do { -- Last thing: check for `main'
- (tcg_env, main_fvs) <- checkMain ;
- return ((tcg_env, tcl_env),
- src_dus1 `plusDU` usesOnly main_fvs)
+ tcg_env <- checkMain ;
+ return (tcg_env, tcl_env)
} ;
-- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
+ 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) <- initRn SourceMode $
- addSrcLoc splice_loc $
- rnExpr splice_expr ;
- tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
- setGblEnv tcg_env $ do {
+ (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
- (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
-
- return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
- }
+ setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\end{code}
+%************************************************************************
+%* *
+ Compiling hs-boot source files, and
+ comparing the hi-boot interface with the real thing
+%* *
+%************************************************************************
+
+\begin{code}
+tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
+tcRnHsBootDecls decls
+ = do { let { (first_group, group_tail) = findSplice decls }
+
+ ; case group_tail of
+ Just stuff -> spliceInHsBootErr stuff
+ Nothing -> return ()
+
+ -- Rename the declarations
+ ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; setGblEnv tcg_env $ do {
+
+ -- Todo: check no foreign decls, no rules, no default decls
+
+ -- Typecheck type/class decls
+ ; traceTc (text "Tc2")
+ ; let tycl_decls = hs_tyclds rn_group
+ ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck instance decls
+ ; traceTc (text "Tc3")
+ ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck value declarations
+ ; traceTc (text "Tc5")
+ ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+
+ -- Wrap up
+ -- No simplification or zonking to do
+ ; traceTc (text "Tc7a")
+ ; gbl_env <- getGblEnv
+
+ -- Make the final type-env
+ -- Include the dfun_ids so that their type sigs get
+ -- are written into the interface file
+ ; let { type_env0 = tcg_type_env gbl_env
+ ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
+ ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
+ ; dfun_ids = map iDFunId inst_infos }
+ ; return (gbl_env { tcg_type_env = type_env2 })
+ }}}}
+
+spliceInHsBootErr (SpliceDecl (L loc _), _)
+ = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
+\end{code}
+
+Once we've typechecked the body of the module, we want to compare what
+we've found (gathered in a TypeEnv) with the hi-boot details (if any).
+
+\begin{code}
+checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
+-- 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
+-- of boot_names is empty.
+--
+-- The bindings we return give bindings for the dfuns defined in the
+-- hs-boot file, such as $fbEqT = $fEqT
+
+checkHiBootIface
+ (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
+ (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
+ = do { mapM_ check_one (typeEnvElts boot_type_env)
+ ; dfun_binds <- mapM check_inst boot_insts
+ ; return (unionManyBags dfun_binds) }
+ where
+ check_one boot_thing
+ | no_check name
+ = return ()
+ | otherwise
+ = case lookupTypeEnv local_type_env name of
+ Nothing -> addErrTc (missingBootThing boot_thing)
+ Just real_thing -> check_thing boot_thing real_thing
+ where
+ name = getName boot_thing
+
+ 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
+ dfun_names = map getName boot_insts
+
+ 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))
+ where
+ boot_dfun = instanceDFunId boot_inst
+ boot_inst_ty = idType boot_dfun
+ local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
+
+----------------
+check_thing (ATyCon boot_tc) (ATyCon real_tc)
+ | isSynTyCon boot_tc && isSynTyCon real_tc,
+ defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
+ = return ()
+
+ | tyConKind boot_tc == tyConKind real_tc
+ = return ()
+ where
+ (tvs1, defn1) = getSynTyConDefn boot_tc
+ (tvs2, defn2) = getSynTyConDefn boot_tc
+
+check_thing (AnId boot_id) (AnId real_id)
+ | idType boot_id `tcEqType` idType real_id
+ = return ()
+
+check_thing (ADataCon dc1) (ADataCon dc2)
+ | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
+ = return ()
+
+ -- Can't declare a class in a hi-boot file
+
+check_thing boot_thing real_thing -- Default case; failure
+ = addErrAt (srcLocSpan (getSrcLoc real_thing))
+ (bootMisMatch real_thing)
+
+----------------
+missingBootThing thing
+ = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
+bootMisMatch thing
+ = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+instMisMatch inst
+ = hang (ppr inst)
+ 2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
+\end{code}
+
%************************************************************************
%* *
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup decls
+tcRnGroup boot_details decls
= do { -- Rename the declarations
- (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
+ (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tc_envs <- tcTopSrcDecls rn_decls ;
-
- return (tc_envs, src_dus)
+ tcTopSrcDecls boot_details rn_decls
}}
------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
+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 {
+ tcg_env <- importsFromLocalDecls group ;
+ setGblEnv tcg_env $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
- (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
- setGblEnv tcg_env $ do {
-
+ (tcg_env, rn_decls) <- rnSrcDecls group ;
failIfErrsM ;
- -- Import consquential imports
- let { src_fvs = duUses src_dus } ;
- rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
- let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
+ -- save the renamed syntax, if we want it
+ let { tcg_env'
+ | Just grp <- tcg_rn_decls tcg_env
+ = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
+ | otherwise
+ = tcg_env };
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
- rnStats rn_imp_decls ;
- return (tcg_env, rn_decls, src_dus)
- }}}
+ return (tcg_env', rn_decls)
+ }}
------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls
+tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- tcg_env <- tcTyClDecls tycl_decls ;
- setGblEnv tcg_env $ do {
+ tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details 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) ;
+
+
+ setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
- setGblEnv tcg_env $ do {
- tcg_env <- importSupportingDecls fvs ;
+ (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
setGblEnv tcg_env $ do {
-- 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 $
- updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
- $ do {
+ tcExtendGlobalValEnv fi_ids $ do {
-- Default declarations
traceTc (text "Tc4a") ;
-- Value declarations next
-- We also typecheck any extra binds that came out
- -- of the "deriving" process
+ -- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` 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,
- -- plus rules and foreign exports, to generate bindings
traceTc (text "Tc6") ;
- (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
- tcExtendGlobalValEnv dm_ids $ do {
- inst_binds <- tcInstDecls2 inst_infos ;
+ (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
showLIE (text "after instDecls2") ;
-- Foreign exports
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-- Rules
- -- Need to partition them because the source rules
- -- must be zonked before adding them to tcg_rules
- -- NB: built-in rules come in as IfaceRuleOut's, and
- -- get added to tcg_rules right here by tcExtendRules
rules <- tcRules rule_decls ;
- let { (src_rules, iface_rules) = partition isSrcRule rules } ;
- tcExtendRules iface_rules $ do {
-- Wrap up
+ traceTc (text "Tc7a") ;
tcg_env <- getGblEnv ;
- let { all_binds = tc_val_binds `AndMonoBinds`
- inst_binds `AndMonoBinds`
- cls_dm_binds `AndMonoBinds`
+ 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 `andMonoBinds` all_binds,
- tcg_rules = tcg_rules tcg_env ++ src_rules,
- tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
-
- return (tcg_env', lcl_env)
- }}}}}}}}}
+ 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', tcl_env)
+ }}}}}}
\end{code}
-\begin{code}
-tcTyClDecls :: [RenamedTyClDecl]
- -> TcM TcGblEnv
-
--- tcTyClDecls deals with
--- type and class decls (some source, some imported)
--- interface signatures (checked lazily)
---
--- It returns the TcGblEnv for this module, and side-effects the
--- persistent compiler state to reflect the things imported from
--- other modules
-
-tcTyClDecls tycl_decls
- = checkNoErrs $
- -- tcTyAndClassDecls recovers internally, but if anything gave rise to
- -- an error we'd better stop now, to avoid a cascade
-
- traceTc (text "TyCl1") `thenM_`
- tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
- -- Returns the extended environment
- setGblEnv tcg_env $
-
- traceTc (text "TyCl2") `thenM_`
- tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
- -- Returns the extended environment
-
- returnM tcg_env
-\end{code}
-
-
%************************************************************************
%* *
- Load the old interface file for this module (unless
- we have it aleady), and check whether it is up to date
-
+ Checking for 'main'
%* *
%************************************************************************
\begin{code}
-checkOldIface :: HscEnv
- -> PersistentCompilerState
- -> Module
- -> FilePath -- Where the interface file is
- -> Bool -- Source unchanged
- -> Maybe ModIface -- Old interface from compilation manager, if any
- -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
- -- Nothing <=> errors happened
-
-checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
- = do { showPass (hsc_dflags hsc_env)
- ("Checking old interface for " ++ moduleUserString mod) ;
-
- initTc hsc_env pcs mod
- (check_old_iface iface_path source_unchanged maybe_iface)
- }
-
-check_old_iface iface_path source_unchanged maybe_iface
- = -- CHECK WHETHER THE SOURCE HAS CHANGED
- ifM (not source_unchanged)
- (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
- `thenM_`
-
- -- If the source has changed and we're in interactive mode, avoid reading
- -- an interface; just return the one we might have been supplied with.
- getGhciMode `thenM` \ ghci_mode ->
- if (ghci_mode == Interactive) && not source_unchanged then
- returnM (outOfDate, maybe_iface)
- else
-
- case maybe_iface of {
- Just old_iface -> -- Use the one we already have
- checkVersions source_unchanged old_iface `thenM` \ recomp ->
- returnM (recomp, Just old_iface)
-
- ; Nothing ->
-
- -- Try and read the old interface for the current module
- -- from the .hi file left from the last time we compiled it
- getModule `thenM` \ this_mod ->
- readIface this_mod iface_path False `thenM` \ read_result ->
- case read_result of {
- Left err -> -- Old interface file not found, or garbled; give up
- traceHiDiffs (text "FYI: cannot read old interface file:"
- $$ nest 4 (text (showException err))) `thenM_`
- returnM (outOfDate, Nothing)
-
- ; Right parsed_iface ->
-
- -- We found the file and parsed it; now load it
- tryTc (initRn (InterfaceMode this_mod)
- (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) ->
- case mb_iface of {
- Nothing -> -- Something went wrong in loading. The main likely thing
- -- is that the usages mentioned B.f, where B.hi and B.hs no
- -- longer exist. Then newGlobalName2 fails with an error message
- -- This isn't an error; we just don't have an old iface file to
- -- look at. Spit out a traceHiDiffs for info though.
- traceHiDiffs (text "FYI: loading old interface file failed"
- $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
- return (outOfDate, Nothing)
-
- ; Just iface ->
-
- -- At last, we have got the old iface; check its versions
- checkVersions source_unchanged iface `thenM` \ recomp ->
- returnM (recomp, Just iface)
+checkMain :: TcM TcGblEnv
+-- If we are in module Main, check that 'main' is defined.
+checkMain
+ = do { ghci_mode <- getGhciMode ;
+ tcg_env <- getGblEnv ;
+ dflags <- getDOpts ;
+ let { main_mod = case mainModIs dflags of {
+ Just mod -> mkModule mod ;
+ Nothing -> mAIN } ;
+ main_fn = case mainFunIs dflags of {
+ Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Nothing -> main_RDR_Unqual } } ;
+
+ check_main ghci_mode tcg_env main_mod main_fn
+ }
+
+
+check_main ghci_mode tcg_env main_mod main_fn
+ | mod /= main_mod
+ = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ return tcg_env
+
+ | 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 { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+ ; complain_no_main
+ ; return tcg_env } ;
+ Just main_name -> do
+ { 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
+
+ -- 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
+ (mkOccFS varName 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,
+ tcg_dus = tcg_dus tcg_env
+ `plusDU` usesOnly (unitFV main_name)
+ -- Record the use of 'main', so that we don't
+ -- complain about it being defined but not used
+ })
}}}
+ where
+ mod = 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.
+
+ 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}
+%*********************************************************
+%* *
+ GHCi stuff
+%* *
+%*********************************************************
+
+\begin{code}
+#ifdef GHCI
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let
+ -- Initialise the tcg_inst_env with instances
+ -- from all home modules. This mimics the more selective
+ -- call to hptInstances in tcRnModule
+ dfuns = hptInstances hsc_env (\mod -> True)
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
+
+ updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
+
+ do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ ; thing_inside }
+\end{code}
-%************************************************************************
-%* *
- Type-check and rename supporting declarations
- This is used to deal with the free vars of a splice,
- or derived code: slurp in the necessary declarations,
- typecheck them, and add them to the EPS
-%* *
-%************************************************************************
\begin{code}
-importSupportingDecls :: FreeVars -> TcM TcGblEnv
--- Completely deal with the supporting imports needed
--- by the specified free-var set
-importSupportingDecls fvs
- = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
- decls <- slurpImpDecls fvs ;
- traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
- typecheckIfaceDecls (mkGroup decls) }
-
-typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
- -- The decls are all interface-file declarations
- -- Usually they are all from other modules, but when we are reading
- -- this module's interface from a file, it's possible that some of
- -- them are for the module being compiled.
- -- That is why the tcExtendX functions need to do partitioning.
- --
- -- If all the decls are from other modules, the returned TcGblEnv
- -- will have an empty tc_genv, but its tc_inst_env
- -- cache may have been augmented.
-typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_ruleds = rule_decls })
- = do { -- Typecheck the type, class, and interface-sig decls
- tcg_env <- tcTyClDecls tycl_decls ;
- setGblEnv tcg_env $ do {
-
- -- Typecheck the instance decls, and rules
- -- Note that imported dictionary functions are already
- -- in scope from the preceding tcTyClDecls
- tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
- tcExtendInstEnv dfuns $
- tcRules rule_decls `thenM` \ rules ->
- tcExtendRules rules $
+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 hsc_env ictxt $ do {
+
+ -- Rename; use CmdLineMode because tcRnStmt is only used interactively
+ (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
+ traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
+ failIfErrsM ;
- getGblEnv -- Return the environment
- }}
+ -- The real work is done here
+ (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
+ -- 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.
+ --
+ -- (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 zonked_ids ;
+
+ -- Update the interactive context
+ rn_env = ic_rn_local_env ictxt ;
+ type_env = ic_type_env ictxt ;
+
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+
+ -- 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] ] ;
+
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
+
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr zonked_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
+-- Give the Id a Global Name, and tidy its type
+ = setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
\end{code}
+Here is the grand plan, implemented in tcUserStmt
+ 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,...]
-%*********************************************************
-%* *
- mkGlobalContext: make up an interactive context
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ 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]
+
+ expr (of non-IO type,
+ result not showable) ==> error
- Used for initialising the lexical environment
- of the interactive read-eval-print loop
-%* *
-%*********************************************************
\begin{code}
-#ifdef GHCI
-mkGlobalContext
- :: HscEnv -> PersistentCompilerState
- -> [Module] -- Expose these modules' top-level scope
- -> [Module] -- Expose these modules' exports only
- -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
-
-mkGlobalContext hsc_env pcs toplevs exports
- = initTc hsc_env pcs iNTERACTIVE $ do {
-
- toplev_envs <- mappM getTopLevScope toplevs ;
- export_envs <- mappM getModuleExports exports ;
- returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
- (toplev_envs ++ export_envs))
+---------------------------
+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 $ FunBind (L loc fresh_it) False matches emptyNameSet
+ matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsIn (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]
+
+---------------------------
+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] ;
+
+ names = map unLoc (collectLStmtsBinders stmts) ;
+
+ -- 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 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)
+ } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc (text "tcs 2") ;
+ ((tc_stmts, ids), lie) <- getLIE $
+ tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
+ 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}
-getTopLevScope :: Module -> TcRn m GlobalRdrEnv
-getTopLevScope mod
- = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
- case mi_globals iface of
- Nothing -> panic "getTopLevScope"
- Just env -> returnM env }
-
-getModuleExports :: Module -> TcRn m GlobalRdrEnv
-getModuleExports mod
- = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
- returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
- where
- prov_fn n = NonLocalDef ImplicitImport
- add env (mod,avails)
- = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
-contextDoc = text "context for compiling statements"
+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 hsc_env ictxt $ do {
+
+ (rn_expr, fvs) <- rnLExpr rdr_expr ;
+ failIfErrsM ;
+
+ -- 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 ;
+ qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
+
+ 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}
+tcRnType just finds the kind of a type
+
\begin{code}
-getModuleContents
- :: HscEnv
- -> PersistentCompilerState -- IN: persistent compiler state
- -> Module -- module to inspect
- -> Bool -- grab just the exports, or the whole toplev
- -> IO (PersistentCompilerState, Maybe [TyThing])
-
-getModuleContents hsc_env pcs mod exports_only
- = initTc hsc_env pcs iNTERACTIVE $ do {
-
- -- Load the interface if necessary (a home module will certainly
- -- alraedy be loaded, but a package module might not be)
- iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
-
- let { export_names = availsToNameSet export_avails ;
- export_avails = [ avail | (mn, avails) <- mi_exports iface,
- avail <- avails ] } ;
-
- all_names <- if exports_only then
- return export_names
- else case mi_globals iface of {
- Just rdr_env ->
- return (get_locals rdr_env) ;
-
- Nothing -> do { addErr (noRdrEnvErr mod) ;
- return export_names } } ;
- -- Invariant; we only have (not exports_only)
- -- for a home module so it must already be in the HIT
- -- So the Nothing case is a bug
-
- env <- importSupportingDecls all_names ;
- setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
+tcRnType :: HscEnv
+ -> InteractiveContext
+ -> LHsType RdrName
+ -> IO (Maybe Kind)
+tcRnType hsc_env ictxt rdr_type
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env ictxt $ do {
+
+ rn_type <- rnLHsType doc rdr_type ;
+ failIfErrsM ;
+
+ -- Now kind-check the type
+ (ty', kind) <- kcHsType rn_type ;
+ return kind
}
where
- -- Grab all the things from the global env that are locally def'd
- get_locals rdr_env = mkNameSet [ gre_name gre
- | elts <- rdrEnvElts rdr_env,
- gre <- elts,
- isLocalGRE gre ]
- -- Make a set because a name is often in the envt in
- -- both qualified and unqualified forms
-
-noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
- <+> quotes (ppr mod)
-#endif
+ doc = ptext SLIT("In GHCi input")
+
+#endif /* GHCi */
\end{code}
+
%************************************************************************
%* *
- Checking for 'main'
+ More GHCi stuff, to do with browsing and getting info
%* *
%************************************************************************
\begin{code}
-checkMain
- = do { ghci_mode <- getGhciMode ;
- tcg_env <- getGblEnv ;
+#ifdef GHCI
+-- 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)
+
+load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
+ where
+ doc = ptext SLIT("context for compiling statements")
+
+
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+tcRnLookupRdrName hsc_env rdr_name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ 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 } ;
- 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
- }
+ -- 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)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
+ -- 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 ;
+
+ return good_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, in which case
- -- we have to drag in its.
- --
- -- Also form the definition
- -- $main = runIO main
- -- so we need to slurp in runIO too.
- --
- -- 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, emptyFVs)
-
- -- Check that 'main' is in scope
- -- It might be imported from another module!
- --
- -- We use a guard for this (rather than letting lookupSrcName fail)
- -- because it's not an error in ghci)
- | not (main_fn `elemRdrEnv` rdr_env)
- = do { complain_no_main; return (tcg_env, emptyFVs) }
-
- | otherwise -- OK, so the appropriate 'main' is in scope
- --
- = do { main_name <- lookupSrcName main_fn ;
- tcg_env <- importSupportingDecls (unitFV runIOName) ;
+tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ tcLookupGlobal name
- addSrcLoc (getSrcLoc main_name) $
- addErrCtxt mainCtxt $
- setGblEnv tcg_env $ do {
-
- -- $main :: IO () = runIO main
- let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
- (main_expr, ty) <- tcInferRho rhs ;
- let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
- main_bind = VarMonoBind dollar_main_id main_expr ;
- tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
- `andMonoBinds` main_bind } } ;
+tcRnGetInfo :: HscEnv
+ -> Name
+ -> IO (Maybe (TyThing, Fixity, [Instance]))
- return (tcg_env', unitFV main_name)
- }}
+-- 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 name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ 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
+
+ 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)
+-- are in scope unqualified. Otherwise we list a whole lot too many!
+lookupInsts print_unqual (AClass cls)
+ = do { inst_envs <- tcGetInstEnvs
+ ; return [ ispec
+ | ispec <- classInstances inst_envs cls
+ , plausibleDFun print_unqual (instanceDFunId ispec) ] }
+
+lookupInsts print_unqual (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)
+ ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
+ ; return [ ispec
+ | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , let dfun = instanceDFunId ispec
+ , relevant dfun
+ , plausibleDFun print_unqual dfun ] }
where
- mod_name = moduleName (tcg_mod tcg_env)
- rdr_env = tcg_rdr_env 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.
+ relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ tc_name = tyConName tc
- 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}
+lookupInsts print_unqual other = return []
+plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
+ = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
+ where
+ 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
+-- This is so that we can accurately report the instances for
+-- something
+loadUnqualIfaces ictxt
+ = initIfaceTcRn $
+ mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
+ where
+ unqual_mods = [ nameModule name
+ | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
+ let name = gre_name gre,
+ isTcOcc (nameOccName name), -- Types and classes only
+ unQualOK gre ] -- In scope unqualified
+ doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
+#endif /* GHCI */
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-rnDump :: SDoc -> TcRn m ()
+rnDump :: SDoc -> TcRn ()
-- Dump, with a banner, if -ddump-rn
-rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
+rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
-tcDump :: TcGblEnv -> TcRn m ()
+tcDump :: TcGblEnv -> TcRn ()
tcDump env
= do { dflags <- getDOpts ;
}
where
short_dump = pprTcGblEnv env
- full_dump = ppr (tcg_binds env)
+ full_dump = pprLHsBinds (tcg_binds env)
-- NB: foreign x-d's have undefined's in their types;
-- hence can't show the tc_fords
ppr_rules rules ]
-ppr_types :: [Var] -> TypeEnv -> SDoc
-ppr_types dfun_ids type_env
+ppr_types :: [Instance] -> TypeEnv -> SDoc
+ppr_types ispecs type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
+ dfun_ids = map instanceDFunId ispecs
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
-- that the type checker has invented. Top-level user-defined things
-- have External names.
-ppr_insts :: [Var] -> SDoc
-ppr_insts [] = empty
-ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
+ppr_insts :: [Instance] -> SDoc
+ppr_insts [] = empty
+ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
- -- Print type signatures
- -- Convert to HsType so that we get source-language style printing
- -- And sort by RdrName
- = vcat $ map ppr_sig $ sortLt lt_sig $
- [ (getRdrName id, toHsType (tidyTopType (idType id)))
- | id <- ids ]
+ -- Print type signatures; sort by OccName
+ = vcat (map ppr_sig (sortLe le_sig ids))
where
- lt_sig (n1,_) (n2,_) = n1 < n2
- ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
-
+ le_sig id1 id2 = getOccName id1 <= getOccName id2
+ ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
-ppr_rules :: [IdCoreRule] -> SDoc
+ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (pprIdRules rs),
+ nest 4 (pprRules rs),
ptext SLIT("#-}")]
ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
- nest 2 (vcat (map ppr_gen_tycon tcs))
- ]
-
--- x&y are now Id's, not CoreExpr's
-ppr_gen_tycon tycon
- | Just ep <- tyConGenInfo tycon
- = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
-
- | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
-
-ppr_ep (EP from to)
- = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
- ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
- ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
- ]
- where
- (_,from_tau) = tcSplitForAllTys (idType from)
+ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
+ nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}