X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=dcf1636609d321cf3b0b35603601a2e01b78273d;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=9fb7177daef292b5e67d4b3089b815c1d42db6fe;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 9fb7177..dcf1636 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,9 +6,11 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkExportEnv, getModuleContents, tcRnStmt, - tcRnGetInfo, GetInfoResult, - tcRnExpr, tcRnType, + tcRnStmt, tcRnExpr, tcRnType, + tcRnLookupRdrName, + tcRnLookupName, + tcRnGetInfo, + getModuleExports, #endif tcRnModule, tcTopSrcDecls, @@ -24,119 +26,109 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import Packages ( moduleToPackageConfig, mkPackageId, package, - isHomeModule ) -import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), +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, rootMainName, mAIN, +import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, main_RDR_Unqual ) -import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, - plusGlobalRdrEnv ) +import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) -import InstEnv ( extendInstEnvList ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv ) +import TcEnv ( tcExtendGlobalValEnv, iDFunId ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings ) +import TcIface ( tcExtCoreBindings, tcHiBootIface ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules, loadHiBootInterface ) -import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, +import LoadIface ( loadOrphanModules ) +import RnNames ( importsFromLocalDecls, rnImports, rnExports, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) -import PprCore ( pprIdRules, pprCoreBindings ) -import CoreSyn ( IdCoreRule, bindersOfBinds ) +import PprCore ( pprRules, pprCoreBindings ) +import CoreSyn ( CoreRule, bindersOfBinds ) import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) -import Id ( mkExportedLocalId, isLocalId, idName, idType ) +import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import VarEnv ( varEnvElts ) -import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) -import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName ) +import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import OccName ( mkVarOccFS ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, + mkExternalName ) import NameSet -import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) +import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), +import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, + HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, hptInstances, lookupType, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, + TypeEnv, lookupTypeEnv, hptInstances, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, emptyFixityEnv ) import Outputable #ifdef GHCI -import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), - LStmt, LHsExpr, LHsType, mkMatchGroup, - collectStmtsBinders, mkSimpleMatch, - nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) -import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), - Provenance(..), ImportSpec(..), - lookupLocalRdrEnv, extendLocalRdrEnv ) +import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), + HsLocalBinds(..), HsValBinds(..), + LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, + collectLStmtsBinders, collectLStmtBinders, nlVarPat, + mkFunBind, placeHolderType, noSyntaxExpr ) +import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, + unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) -import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) -import TcExpr ( tcCheckRho ) -import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) -import TcUnify ( unifyTyConApp ) -import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) +import TcMatches ( tcStmts, tcDoStmt ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, - isUnLiftedType, tyClsNamesOfDFunHead ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, + isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) -import Inst ( tcStdSyntaxName, tcGetInstEnvs ) -import InstEnv ( DFunId, classInstances, instEnvElts ) +import Inst ( tcGetInstEnvs ) +import InstEnv ( classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) -import RnNames ( exportsToAvails ) -import LoadIface ( loadSrcInterface, ifaceInstGates ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), - tyThingToIfaceDecl, dfunToIfaceInst ) -import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType, - interactiveExtNameFun, isLocalIfaceExtName ) -import IfaceEnv ( lookupOrig ) +import LoadIface ( loadSrcInterface, loadSysInterface ) +import IfaceEnv ( ifaceExportNames ) +import Module ( moduleSetElts, mkModuleSet ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( Id, isImplicitId, setIdType, globalIdDetails ) +import Id ( setIdType ) import MkId ( unsafeCoerceId ) -import DataCon ( dataConTyCon ) import TyCon ( tyConName ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( interactiveSrcLoc, unLoc ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName ) -import OccName ( occNameUserString ) +import Name ( nameOccName, nameModule, isBuiltInSyntax ) +import OccName ( isTcOcc ) import NameEnv ( delListFromNameEnv ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) -import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses, - availNames, availName, ModIface(..), icPrintUnqual, - ModDetails(..), Dependencies(..) ) -import BasicTypes ( RecFlag(..), Fixity ) -import Bag ( unitBag ) -import ListSetOps ( removeDups ) -import Panic ( ghcError, GhcException(..) ) -import SrcLoc ( SrcLoc ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, + bindIOName, thenIOName, returnIOName ) +import HscTypes ( InteractiveContext(..), + ModIface(..), icPrintUnqual, + Dependencies(..) ) +import BasicTypes ( Fixity, RecFlag(..) ) +import SrcLoc ( unLoc ) #endif import FastString ( mkFastString ) +import Maybes ( MaybeErr(..) ) import Util ( sortLe ) -import Bag ( unionBags, snocBag ) +import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) import Maybe ( isJust ) \end{code} @@ -153,11 +145,13 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv -> HscSource + -> Bool -- True <=> save renamed syntax -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec)) +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 @@ -167,19 +161,20 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ do { - checkForPackageModule (hsc_dflags hsc_env) this_mod; - -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; let { dep_mods :: ModuleEnv (Module, IsBootInterface) ; dep_mods = imp_dep_mods imports - ; is_dep_mod :: Module -> Bool - ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of - Nothing -> False - Just (_, is_boot) -> not is_boot - ; home_insts = hptInstances hsc_env is_dep_mod + -- 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 @@ -187,11 +182,17 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies -- 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_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)) ; @@ -222,7 +223,7 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies reportDeprecations tcg_env ; -- Process the export list - exports <- exportsFromAvail (isJust maybe_mod) export_ies ; + exports <- rnExports (isJust maybe_mod) export_ies ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -242,23 +243,27 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies -- Dump output and return tcDump final_env ; return final_env - }}}} - --- This is really a sanity check that the user has given -package-name --- if necessary. -package-name is only necessary when the package database --- already contains the current package, because then we can't tell --- whether a given module is in the current package or not, without knowing --- the name of the current package. -checkForPackageModule dflags this_mod - | not (isHomeModule dflags this_mod), - Just (pkg,_) <- moduleToPackageConfig dflags this_mod = - let - ppr_pkg = ppr (mkPackageId (package pkg)) - in - addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+> - ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$ - ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.') - | otherwise = return () + }}}}} + + +-- The program is not allowed to contain two modules with the same +-- name, and we check for that here. It could happen if the home package +-- contains a module that is also present in an external package, for example. +checkConflicts imports this_mod and_then = do + dflags <- getDOpts + let + dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) + -- don't forget to include the current module! + + mb_dep_pkgs = checkForPackageConflicts + dflags dep_mods (imp_dep_pkgs imports) + -- + case mb_dep_pkgs of + Failed msg -> + do addErr msg; failM + Succeeded _ -> + updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) + and_then \end{code} @@ -284,11 +289,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Deal with the type declarations; first bring their stuff -- into scope, then rname them, then type check them - (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ; + tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ; - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` tcg_imports gbl }) - $ do { + setGblEnv tcg_env $ do { rn_decls <- rnTyClDecls ldecls ; failIfErrsM ; @@ -298,7 +301,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] 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 { @@ -319,6 +322,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 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, @@ -338,10 +342,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) }}}} mkFakeGroup decls -- Rather clumsy; lots of unused fields - = HsGroup { hs_tyclds = decls, -- This is the one we want - hs_valds = [], hs_fords = [], - hs_instds = [], hs_fixds = [], hs_depds = [], - hs_ruleds = [], hs_defds = [] } + = emptyRdrGroup { hs_tyclds = decls } \end{code} @@ -360,10 +361,11 @@ tcRnSrcDecls decls -- 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 - boot_names <- loadHiBootInterface ; + mod <- getModule ; + boot_iface <- tcHiBootIface mod ; -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ; + (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 @@ -384,30 +386,34 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + tcDump tcg_env ; (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; - let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; - - -- Compre the hi-boot iface (if any) with the real thing - checkHiBootIface final_type_env boot_names ; + 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 ; - return (tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) + -- Compare the hi-boot iface (if any) with the real thing + dfun_binds <- checkHiBootIface tcg_env' boot_iface ; + + return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) } -tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +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_names ds +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@(tcg_env,tcl_env) <- tcRnGroup boot_names 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 @@ -438,7 +444,7 @@ tc_rn_src_decls boot_names ds -- Glue them on the front of the remaining decls and loop setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_names (spliced_decls ++ rest_ds) + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} @@ -468,7 +474,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls) + ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -478,55 +484,73 @@ tcRnHsBootDecls decls -- Typecheck value declarations ; traceTc (text "Tc5") - ; new_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_ids <- tcHsBootSigs (hs_valds rn_group) -- Wrap up -- No simplification or zonking to do ; traceTc (text "Tc7a") ; gbl_env <- getGblEnv - ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids } - ; return (gbl_env { tcg_type_env = final_type_env }) + -- 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} -In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded -into the External Package Table. 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 stuff in the EPT. We do so here, using the export list of -the hi-boot interface as our checklist. +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 :: TypeEnv -> [Name] -> TcM () +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. -checkHiBootIface env boot_names - = mapM_ (check_one env) boot_names - ----------------- -check_one local_env name - | isWiredInName name -- No checking for wired-in names. In particular, 'error' - = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot) - | otherwise - = do { (eps,hpt) <- getEpsAndHpt - - -- Look up the hi-boot one; - -- it should jolly well be there (else GHC bug) - ; case lookupType hpt (eps_PTE eps) name of { - Nothing -> pprPanic "checkHiBootIface" (ppr name) ; - Just boot_thing -> - - -- Look it up in the local type env - -- It should be there, but it's a programmer error if not - case lookupTypeEnv local_env name of - Nothing -> addErrTc (missingBootThing boot_thing) - Just real_thing -> check_thing boot_thing real_thing - } } +-- +-- 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) @@ -537,8 +561,8 @@ check_thing (ATyCon boot_tc) (ATyCon real_tc) | tyConKind boot_tc == tyConKind real_tc = return () where - (tvs1, defn1) = getSynTyConDefn boot_tc - (tvs2, defn2) = getSynTyConDefn boot_tc + (tvs1, defn1) = synTyConDefn boot_tc + (tvs2, defn2) = synTyConDefn boot_tc check_thing (AnId boot_id) (AnId real_id) | idType boot_id `tcEqType` idType real_id @@ -559,6 +583,9 @@ 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} @@ -580,42 +607,46 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) +tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_names decls +tcRnGroup boot_details decls = do { -- Rename the declarations (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tcTopSrcDecls boot_names rn_decls + tcTopSrcDecls boot_details rn_decls }} ------------------------------------------------ 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 { - traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ; failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls (tcg_env, rn_decls) <- rnSrcDecls group ; failIfErrsM ; + -- 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) ; - return (tcg_env, rn_decls) + return (tcg_env', rn_decls) }} ------------------------------------------------ -tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_names +tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -626,7 +657,7 @@ tcTopSrcDecls boot_names -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ; + 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 @@ -656,12 +687,12 @@ tcTopSrcDecls boot_names -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; - setLclTypeEnv lcl_env $ do { + (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; + setLclTypeEnv tcl_env $ do { -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ; + (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -684,7 +715,7 @@ tcTopSrcDecls boot_names tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, tcg_rules = tcg_rules tcg_env ++ rules, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; - return (tcg_env', lcl_env) + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -696,15 +727,15 @@ tcTopSrcDecls boot_names %************************************************************************ \begin{code} +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 } ; + let { main_mod = mainModIs dflags ; main_fn = case mainFunIs dflags of { - Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; check_main ghci_mode tcg_env main_mod main_fn @@ -712,13 +743,9 @@ checkMain check_main ghci_mode tcg_env main_mod main_fn - -- If we are in module Main, check that 'main' is defined. - -- It may be imported from another module! - -- - -- - -- Blimey: a whole page of code to do this... | mod /= main_mod - = return tcg_env + = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> + return tcg_env | otherwise = addErrCtxt mainCtxt $ @@ -726,17 +753,34 @@ check_main ghci_mode tcg_env main_mod main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { - Nothing -> do { complain_no_main + Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn) + ; complain_no_main ; return tcg_env } ; Just main_name -> do - { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } + { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) + ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runMainIO main ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs - ; let { root_main_id = mkExportedLocalId rootMainName ty ; - main_bind = noLoc (VarBind root_main_id main_expr) } + -- The function that the RTS invokes is always :Main.main, + -- which we call root_main_id. + -- (Because GHC allows the user to have a module not called + -- Main as the main module, we can't rely on the main function + -- being called "Main.main". That's why root_main_id has a fixed + -- module ":Main".) + -- We also make root_main_id an implicit Id, by making main_name + -- its parent (hence (Just main_name)). That has the effect + -- of preventing its type and unfolding from getting out into + -- the interface file. Otherwise we can end up with two defns + -- for 'main' in the interface file! + + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS FSLIT("main")) + (Just main_name) (getSrcLoc main_name) + ; root_main_id = mkExportedLocalId root_main_name ty + ; main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env `snocBag` main_bind, @@ -760,7 +804,6 @@ check_main ghci_mode tcg_env main_mod main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) \end{code} - %********************************************************* %* * GHCi stuff @@ -805,13 +848,19 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; + (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; 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 ; + (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 @@ -822,7 +871,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -- (b) Tidy their types; this is important, because :info may -- ask to look at them, and :info expects the things it looks -- up to have tidy types - global_ids = map globaliseAndTidy bound_ids ; + global_ids = map globaliseAndTidy zonked_ids ; -- Update the interactive context rn_env = ic_rn_local_env ictxt ; @@ -847,10 +896,13 @@ tcRnStmt hsc_env ictxt rdr_stmt dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr tc_expr]) ; + text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (new_ic, bound_names, tc_expr) + returnM (new_ic, bound_names, zonked_expr) } + where + bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) globaliseAndTidy :: Id -> Id globaliseAndTidy id @@ -882,45 +934,80 @@ Here is the grand plan, implemented in tcUserStmt \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 - (mkMatchGroup [mkSimpleMatch [] expr]) - 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] }) - -tcUserStmt stmt = tc_stmts [stmt] +type PlanResult = ([Id], LHsExpr Id) +type Plan = TcM PlanResult + +runPlans :: [Plan] -> TcM PlanResult +-- Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcLIE_ (runPlans ps) p + +-------------------- +mkPlan :: LStmt Name -> TcM PlanResult +mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt + = do { uniq <- newUnique -- is treated very specially + ; let fresh_it = itName uniq + the_bind = L loc $ mkFunBind (L loc fresh_it) matches + matches = [mkMatch [] expr emptyLocalBinds] + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] [])) + bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr + (HsVar bindIOName) noSyntaxExpr + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) placeHolderType + + -- The plans are: + -- [it <- e; print it] but not if it::() + -- [it <- e] + -- [let it = e; print it] + ; runPlans [ -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; ifM (isUnitTy it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } + ]} + +mkPlan stmt@(L loc (BindStmt {})) + | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt + = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) placeHolderType + -- The plans are: + -- [stmt; print v] but not if v::() + -- [stmt] + ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff }, + tcGhciStmts [stmt] + ]} + +mkPlan stmt + = tcGhciStmts [stmt] --------------------------- -tc_stmts stmts +tcGhciStmts :: [LStmt Name] -> TcM PlanResult +tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; + ret_id <- tcLookupId returnIOName ; -- return @ IO let { + io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - names = map unLoc (collectStmtsBinders stmts) ; - - stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = infer_rhs, - sc_body = check_body, - sc_ty = ret_ty } ; - - infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs - ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty - ; return (rhs', pat_ty) } ; - check_body body = tcCheckRho body io_ret_ty ; + names = map unLoc (collectLStmtsBinders stmts) ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -933,53 +1020,27 @@ tc_stmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) - (nlHsVar id) ; - - io_ty = mkTyConApp ioTyCon [] + (nlHsVar id) } ; -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; - ((ids, tc_expr), lie) <- getLIE $ do { - (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)]) } ; - - io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty)) - } ; - - -- Simplify the context right here, so that we fail - -- if there aren't enough instances. Notably, when we see - -- e - -- we use recoverTc_ to try it <- e - -- and then let it = e - -- It's the simplify step that rejects the first. - traceTc (text "tcs 3") ; - const_binds <- tcSimplifyInteractive lie ; - - -- Build result expression and zonk it - let { expr = mkHsLet const_binds tc_expr } ; - zonked_expr <- zonkTopLExpr expr ; - zonked_ids <- zonkTopBndrs ids ; - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; - - return (zonked_ids, zonked_expr) - } - where - 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))]) + ((tc_stmts, ids), lie) <- getLIE $ + tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ -> + mappM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + return (ids, mkHsDictLet const_binds $ + noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) + } \end{code} @@ -1046,128 +1107,41 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI -mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only - -> IO GlobalRdrEnv -mkExportEnv hsc_env exports - = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ - mappM getModuleExports exports - ; case mb_envs of - Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs) - Nothing -> return emptyGlobalRdrEnv - -- Some error; initTc will have printed it - } +-- ASSUMES that the module is either in the HomePackageTable or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet) +getModuleExports hsc_env mod + = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod) + +tcGetModuleExports :: Module -> TcM NameSet +tcGetModuleExports mod = do + iface <- load_iface mod + loadOrphanModules (dep_orphs (mi_deps iface)) + -- Load any orphan-module interfaces, + -- so their instances are visible + ifaceExportNames (mi_exports iface) -getModuleExports :: Module -> TcM GlobalRdrEnv -getModuleExports mod - = do { iface <- load_iface mod - ; loadOrphanModules (dep_orphs (mi_deps iface)) - -- Load any orphan-module interfaces, - -- so their instances are visible - ; names <- exportsToAvails (mi_exports iface) - ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] } - ; returnM (mkGlobalRdrEnv gres) } - -vanillaProv :: Module -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod = Imported [ImportSpec mod mod False - (srcLocSpan interactiveSrcLoc)] False -\end{code} - -\begin{code} -getModuleContents - :: HscEnv - -> InteractiveContext - -> Module -- Module to inspect - -> Bool -- Grab just the exports, or the whole toplev - -> IO (Maybe [IfaceDecl]) - -getModuleContents hsc_env ictxt mod exports_only - = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only) - where - get_mod_contents exports_only - | not exports_only -- We want the whole top-level type env - -- so it had better be a home module - = do { hpt <- getHpt - ; case lookupModuleEnv hpt mod of - Just mod_info -> return (map (toIfaceDecl ext_nm) $ - filter wantToSee $ - typeEnvElts $ - md_types (hm_details mod_info)) - Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod))) - -- This is a system error; the module should be in the HPT - } - - | otherwise -- Want the exports only - = do { iface <- load_iface mod - ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface - , avail <- avails ] - } - - get_decl (mod, avail) - = do { main_name <- lookupOrig mod (availName avail) - ; thing <- tcLookupGlobal main_name - ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) } - - ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) - ---------------------- -filter_decl occs decl@(IfaceClass {ifSigs = sigs}) - = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons}) - = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) } -filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) - | keep_con occs con = decl - | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? -filter_decl occs decl - = decl - -keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs -keep_con occs con = ifConOcc con `elem` occs - -wantToSee (AnId id) = not (isImplicitId id) -wantToSee (ADataCon _) = False -- They'll come via their TyCon -wantToSee _ = True - ---------------------- load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} where doc = ptext SLIT("context for compiling statements") ---------------------- -noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") - <+> quotes (ppr mod) -\end{code} - -\begin{code} -type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, - [(IfaceType,SrcLoc)] -- Instances - ) -tcRnGetInfo :: HscEnv - -> InteractiveContext - -> RdrName - -> IO (Maybe [GetInfoResult]) - --- 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 +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env ictxt $ do { + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + lookup_rdr_name rdr_name +lookup_rdr_name rdr_name = do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both -- constructor and type class identifiers. let { rdr_names = dataTcOccs rdr_name } ; - -- results :: [(Messages, Maybe Name)] - results <- mapM (tryTc . lookupOccRn) rdr_names ; + -- results :: [Either Messages Name] + results <- mapM (tryTcErrs . lookupOccRn) rdr_names ; traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]); -- The successful lookups will be (Just name) @@ -1185,83 +1159,92 @@ tcRnGetInfo hsc_env ictxt rdr_name 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 - ; fixity <- lookupFixityRn name - ; dfuns <- lookupInsts ext_nm thing - ; return (str, toIfaceDecl ext_nm thing, fixity, - getSrcLoc thing, - [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns] - ) } - where - -- str is the the naked occurrence name - -- after stripping off qualification and parens (+) - str = occNameUserString (nameOccName name) - } ; - - -- For the SrcLoc, the 'thing' has better info than - -- the 'name' because getting the former forced the - -- declaration to be loaded into the cache - - results <- mapM do_one good_names ; - return (fst (removeDups cmp results)) - } - where - cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2 - ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) + + return good_names + } + + +tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName hsc_env name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + tcLookupGlobal name -lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId] +tcRnGetInfo :: HscEnv + -> Name + -> IO (Maybe (TyThing, Fixity, [Instance])) + +-- 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 ext_nm (AClass cls) - = do { loadImportedInsts cls [] -- [] means load all instances for cls - ; inst_envs <- tcGetInstEnvs - ; return [ dfun - | (_,_,dfun) <- classInstances inst_envs cls - , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun)) - -- Rather an indirect/inefficient test, but there we go - , all print_tycon_unqual tycons ] } - where - print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm - print_tycon_unqual other = True -- Int etc - +lookupInsts print_unqual (AClass cls) + = do { inst_envs <- tcGetInstEnvs + ; return [ ispec + | ispec <- classInstances inst_envs cls + , plausibleDFun print_unqual (instanceDFunId ispec) ] } -lookupInsts ext_nm (ATyCon tc) +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) - ; mapM_ (\c -> loadImportedInsts c []) - (typeEnvClasses (eps_PTE eps)) ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all - ; return [ dfun - | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie + ; return [ ispec + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec , relevant dfun - , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun)) - , isLocalIfaceExtName cls ] } + , plausibleDFun print_unqual dfun ] } where relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts ext_nm other = return [] +lookupInsts print_unqual other = return [] - -toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl -toIfaceDecl ext_nm thing - = tyThingToIfaceDecl True -- Discard IdInfo - emptyNameSet -- Show data cons - ext_nm (munge thing) +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 - -- munge transforms a thing to its "parent" thing - munge (ADataCon dc) = ATyCon (dataConTyCon dc) - munge (AnId id) = case globalIdDetails id of - RecordSelId tc lbl -> ATyCon tc - ClassOpId cls -> AClass cls - other -> AnId id - munge other_thing = other_thing + 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} @@ -1323,10 +1306,11 @@ pprModGuts (ModGuts { mg_types = type_env, 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 && @@ -1337,9 +1321,9 @@ ppr_types dfun_ids type_env -- 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 @@ -1349,10 +1333,10 @@ ppr_sigs ids 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