X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=09ac7b405bd37ae52b3b8c7ad9f4b5ae2c36296b;hb=4d5d91aabe3178eb92342e39d9eedc244f5f6f5a;hp=9d34979ff5aba1d0ab83ff2c4fd0e64935570465;hpb=837824d2ff329a0f68c1434ae6812bea3ac7ec5f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 9d34979..09ac7b4 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -7,7 +7,9 @@ module TcRnDriver ( #ifdef GHCI mkExportEnv, getModuleContents, tcRnStmt, - tcRnGetInfo, tcRnExpr, tcRnType, + tcRnGetInfo, GetInfoResult, + tcRnExpr, tcRnType, + tcRnLookupRdrName, #endif tcRnModule, tcTopSrcDecls, @@ -16,17 +18,22 @@ module TcRnDriver ( #include "HsVersions.h" +import IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif -import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import DriverState ( v_MainModIs, v_MainFunIs ) -import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), +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(..), LHsBinds, + emptyGroup, appendGroups, nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) -import PrelNames ( runIOName, rootMainName, mAIN_Name, +import PrelNames ( runMainIOName, rootMainName, mAIN, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, plusGlobalRdrEnv ) @@ -35,73 +42,76 @@ import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) -import TcBinds ( tcTopBinds ) +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 IfaceEnv ( lookupOrig ) -import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, +import LoadIface ( loadOrphanModules ) +import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, 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 Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) +import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName ) import NameSet import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) -import Outputable -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), noDependencies, isOneShot, - Deprecs( NoDeprecs ), ModIface(..), plusDeprecs, +import DriverPhases ( HscSource(..), isHsBoot ) +import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, + HscEnv(..), ExternalPackageState(..), + IsBootInterface, noDependencies, + Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - emptyFixityEnv, availName + TypeEnv, lookupTypeEnv, hptInstances, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, + emptyFixityEnv ) +import Outputable + #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr, LHsType, mkMatchGroup, - collectStmtsBinders, mkSimpleMatch, placeHolderType, - nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) + collectLStmtsBinders, mkSimpleMatch, nlVarPat, + placeHolderType, noSyntaxExpr ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), - Provenance(..), ImportSpec(..), - lookupLocalRdrEnv, extendLocalRdrEnv ) + Provenance(..), ImportSpec(..), globalRdrEnvElts, + unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) -import TcExpr ( tcCheckRho ) -import TcIface ( loadImportedInsts ) -import TcMType ( zonkTcType ) -import TcUnify ( unifyTyConApp ) -import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) +import TcMType ( zonkTcType, zonkQuantifiedTyVar ) +import TcMatches ( tcStmts, tcDoStmt ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, - isUnLiftedType, tyClsNamesOfDFunHead ) + isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType ) 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 ) +import LoadIface ( loadSrcInterface, loadSysInterface ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), - tyThingToIfaceDecl, dfunToIfaceInst ) + IfaceExtName(..), IfaceConDecls(..), + tyThingToIfaceDecl ) +import IfaceType ( IfaceType, toIfaceType, + interactiveExtNameFun ) +import IfaceEnv ( lookupOrig, ifaceExportNames ) +import Module ( lookupModuleEnv, moduleSetElts, mkModuleSet ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( Id, isImplicitId, globalIdDetails ) +import Id ( isImplicitId, setIdType, globalIdDetails ) import MkId ( unsafeCoerceId ) import DataCon ( dataConTyCon ) import TyCon ( tyConName ) @@ -110,16 +120,15 @@ import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModuleName ) +import Name ( nameOccName, nameModule ) +import OccName ( occNameUserString, isTcOcc ) import NameEnv ( delListFromNameEnv ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) -import Module ( ModuleName, lookupModuleEnvByName ) -import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), - HomeModInfo(..), typeEnvElts, typeEnvClasses, - availNames, icPrintUnqual, - ModDetails(..), Dependencies(..) ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, + bindIOName, thenIOName, returnIOName ) +import HscTypes ( InteractiveContext(..), HomeModInfo(..), + availNames, availName, ModIface(..), icPrintUnqual, + Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) -import Bag ( unitBag ) import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) import SrcLoc ( SrcLoc ) @@ -127,7 +136,7 @@ import SrcLoc ( SrcLoc ) import FastString ( mkFastString ) import Util ( sortLe ) -import Bag ( unionBags, snocBag ) +import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) import Maybe ( isJust ) \end{code} @@ -143,32 +152,57 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env (L loc (HsModule maybe_mod exports - 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 - Nothing -> mkHomeModule mAIN_Name - -- 'module M where' is omitted - Just (L _ mod) -> mod } ; - -- The normal case + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mod } ; -- The normal case - initTc hsc_env this_mod $ + initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ - do { -- Deal with imports; sets tcg_rdr_env, tcg_imports + do { + checkForPackageModule (hsc_dflags hsc_env) this_mod; + + -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; - -- In one-shot mode, record boot-file info in the EPS - ifM (isOneShot (hsc_mode hsc_env)) $ - updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ; + 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 }) ; -- Update the gbl env - updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports }) - $ do { + updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = rdr_env, + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_decls = if save_rn_decls then + Just emptyGroup + 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 @@ -181,7 +215,10 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports traceRn (text "rn1a") ; -- Rename and type check the declarations - tcg_env <- tcRnSrcDecls local_decls ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; @@ -194,20 +231,7 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports reportDeprecations tcg_env ; -- Process the export list - exports <- exportsFromAvail (isJust maybe_mod) exports ; - -{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus - -- 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) - -- We don't need the results, but sucking them in may side-effect - -- the ExternalPackageState, apart from recording usage - mappM (tcLookupGlobal . availName) export_avails ; --} + exports <- exportsFromAvail (isJust maybe_mod) export_ies ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -222,12 +246,28 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports } ; -- Report unused names - reportUnusedNames final_env ; + reportUnusedNames export_ies final_env ; -- 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 () \end{code} @@ -247,7 +287,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env this_mod $ do { + initTc hsc_env ExtCoreFile this_mod $ do { let { ldecls = map noLoc decls } ; @@ -267,13 +307,13 @@ 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 { -- Now the core bindings - core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; + core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; -- Wrap up let { @@ -284,6 +324,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 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, -- ?? @@ -324,10 +365,15 @@ tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls - = do { boot_names <- loadHiBootInterface ; + = 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_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 @@ -351,27 +397,30 @@ tcRnSrcDecls decls (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 @@ -402,46 +451,113 @@ 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} %************************************************************************ %* * - Comparing the hi-boot interface with the real thing + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing %* * %************************************************************************ -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. +\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 :: 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 -checkHiBootIface env boot_names - = mapM_ (check_one env) boot_names - ----------------- -check_one local_env name - = do { eps <- getEps - - -- Look up the hi-boot one; - -- it should jolly well be there (else GHC bug) - ; case lookupTypeEnv (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 - } } +-- 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) @@ -471,9 +587,12 @@ check_thing boot_thing real_thing -- Default case; failure ---------------- missingBootThing thing - = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module") + = 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 hi-boot file") + = 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} @@ -495,15 +614,15 @@ 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 }} ------------------------------------------------ @@ -522,15 +641,22 @@ rnTopSrcDecls group (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, @@ -541,7 +667,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 @@ -614,13 +740,11 @@ tcTopSrcDecls boot_names checkMain = do { ghci_mode <- getGhciMode ; tcg_env <- getGblEnv ; - - 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 { + 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 } } ; @@ -632,12 +756,9 @@ check_main ghci_mode tcg_env main_mod main_fn -- If we are in module Main, check that 'main' is defined. -- It may be imported from another module! -- - -- ToDo: We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't -- -- Blimey: a whole page of code to do this... - | mod_name /= main_mod + | mod /= main_mod = return tcg_env | otherwise @@ -649,8 +770,8 @@ check_main ghci_mode tcg_env main_mod main_fn Nothing -> do { complain_no_main ; return tcg_env } ; Just main_name -> do - { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } - -- :Main.main :: IO () = runIO main + { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } + -- :Main.main :: IO () = runMainIO main ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs @@ -662,10 +783,12 @@ check_main ghci_mode tcg_env main_mod main_fn `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_name = moduleName (tcg_mod tcg_env) + mod = tcg_mod tcg_env complain_no_main | ghci_mode == Interactive = return () | otherwise = failWithTc noMainMsg @@ -678,7 +801,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 @@ -687,13 +809,23 @@ check_main ghci_mode tcg_env main_mod main_fn \begin{code} #ifdef GHCI -setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext icxt thing_inside - = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt}) $ - updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ - thing_inside) +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} @@ -710,10 +842,10 @@ tcRnStmt :: HscEnv tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + 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 ; @@ -721,12 +853,16 @@ tcRnStmt hsc_env ictxt rdr_stmt (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; traceTc (text "tcs 1") ; - let { -- Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - global_ids = map (globaliseId VanillaGlobal) bound_ids ; + 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 bound_ids ; -- Update the interactive context rn_env = ic_rn_local_env ictxt ; @@ -755,8 +891,14 @@ tcRnStmt hsc_env ictxt rdr_stmt returnM (new_ic, bound_names, tc_expr) } -\end{code} +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 @@ -781,7 +923,7 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) -tcUserStmt (L _ (ExprStmt expr _)) +tcUserStmt (L loc (ExprStmt expr _ _)) = newUnique `thenM` \ uniq -> let fresh_it = itName uniq @@ -790,35 +932,27 @@ tcUserStmt (L _ (ExprStmt 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)) - ] }) + tc_stmts (map (L loc) [ + LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], + ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) placeHolderType + ]) }) (do { -- Try this first traceTc (text "tcs 1a") ; - tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) + tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr + (HsVar bindIOName) noSyntaxExpr) ] }) tcUserStmt stmt = tc_stmts [stmt] --------------------------- +tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id) tc_stmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; let { 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] @@ -842,16 +976,15 @@ tc_stmts stmts -- 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)) + (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $ + do { + -- Look up the names right in the middle, + -- where they will all be in scope + ids <- mappM tcLookupId names ; + return ids } ; + + ret_id <- tcLookupId returnIOName ; -- return @ IO + return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty)) } ; -- Simplify the context right here, so that we fail @@ -875,7 +1008,6 @@ tc_stmts stmts return (zonked_ids, zonked_expr) } where - combine stmt (ids, stmts) = (ids, stmt:stmts) bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} @@ -890,7 +1022,7 @@ tcRnExpr :: HscEnv -> IO (Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { (rn_expr, fvs) <- rnLExpr rdr_expr ; failIfErrsM ; @@ -900,8 +1032,9 @@ tcRnExpr hsc_env ictxt rdr_expr ((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 $ + let { all_expr_ty = mkForAllTys qtvs' $ mkFunTys (map idType dict_ids) $ res_ty } ; zonkTcType all_expr_ty @@ -919,7 +1052,7 @@ tcRnType :: HscEnv -> IO (Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType doc rdr_type ; failIfErrsM ; @@ -943,7 +1076,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI -mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only +mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only -> IO GlobalRdrEnv mkExportEnv hsc_env exports = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ @@ -954,18 +1087,18 @@ mkExportEnv hsc_env exports -- Some error; initTc will have printed it } -getModuleExports :: ModuleName -> TcM GlobalRdrEnv +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 - ; avails <- exportsToAvails (mi_exports iface) + ; names <- ifaceExportNames (mi_exports iface) ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | avail <- avails, name <- availNames avail ] } + | name <- nameSetToList names ] } ; returnM (mkGlobalRdrEnv gres) } -vanillaProv :: ModuleName -> Provenance +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 @@ -975,20 +1108,19 @@ vanillaProv mod = Imported [ImportSpec mod mod False \begin{code} getModuleContents :: HscEnv - -> InteractiveContext - -> ModuleName -- Module to inspect + -> Module -- Module to inspect -> Bool -- Grab just the exports, or the whole toplev -> IO (Maybe [IfaceDecl]) -getModuleContents hsc_env ictxt mod exports_only +getModuleContents hsc_env mod exports_only = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only) where get_mod_contents exports_only | not exports_only -- We want the whole top-level type env -- so it had better be a home module = do { hpt <- getHpt - ; case lookupModuleEnvByName hpt mod of - Just mod_info -> return (map toIfaceDecl $ + ; case lookupModuleEnv hpt mod of + Just mod_info -> return (map (toIfaceDecl ext_nm) $ filter wantToSee $ typeEnvElts $ md_types (hm_details mod_info)) @@ -998,19 +1130,22 @@ getModuleContents hsc_env ictxt mod exports_only | otherwise -- Want the exports only = do { iface <- load_iface mod - ; avails <- exportsToAvails (mi_exports iface) - ; mappM get_decl avails + ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface + , avail <- avails ] } - get_decl avail - = do { thing <- tcLookupGlobal (availName avail) - ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) } + get_decl (mod, avail) + = do { main_name <- lookupOrig mod (availName avail) + ; thing <- tcLookupGlobal main_name + ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) } + + ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env)) --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons}) - = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) + = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) | keep_con occs con = decl | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? @@ -1020,8 +1155,6 @@ filter_decl occs decl keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs keep_con occs con = ifConOcc con `elem` occs -availOccs avail = map nameOccName (availNames avail) - wantToSee (AnId id) = not (isImplicitId id) wantToSee (ADataCon _) = False -- They'll come via their TyCon wantToSee _ = True @@ -1037,23 +1170,19 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") \end{code} \begin{code} -tcRnGetInfo :: HscEnv - -> InteractiveContext - -> RdrName - -> IO (Maybe [(IfaceDecl, - Fixity, SrcLoc, - [(IfaceInst, SrcLoc)])]) --- Used to implemnent :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env ictxt rdr_name +type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, + [(IfaceType,SrcLoc)] -- Instances + ) + +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) + +tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext 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. @@ -1078,56 +1207,100 @@ tcRnGetInfo hsc_env ictxt rdr_name do { addMessages (head errs_s) ; failM } else -- Add deprecation warnings mapM_ addMessages warns_s ; - + + return good_names + } + + +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 + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + loadUnqualIfaces ictxt ; + + good_names <- lookup_rdr_name rdr_name ; + -- And lookup up the entities, avoiding duplicates, which arise -- because constructors and record selectors are represented by -- their parent declaration - let { do_one name = do { thing <- tcLookupGlobal name - ; let decl = toIfaceDecl thing + let { do_one name = do { thing <- tcLookupGlobal name ; fixity <- lookupFixityRn name - ; insts <- lookupInsts thing - ; return (decl, fixity, getSrcLoc thing, - map mk_inst insts) } ; + ; ispecs <- lookupInsts print_unqual thing + ; return (str, toIfaceDecl ext_nm thing, fixity, + getSrcLoc thing, + [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) + | dfun <- map instanceDFunId ispecs ] + ) } + where + -- str is the the naked occurrence name + -- after stripping off qualification and parens (+) + str = occNameUserString (nameOccName name) + } ; + -- For the SrcLoc, the 'thing' has better info than -- the 'name' because getting the former forced the -- declaration to be loaded into the cache - mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ; - cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ; + results <- mapM do_one good_names ; return (fst (removeDups cmp results)) } - -lookupInsts :: TyThing -> TcM [DFunId] -lookupInsts (AClass cls) - = do { loadImportedInsts cls [] -- [] means load all instances for cls - ; inst_envs <- tcGetInstEnvs - ; return [df | (_,_,df) <- classInstances inst_envs cls] } - -lookupInsts (ATyCon tc) + where + cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2 + ext_nm = interactiveExtNameFun print_unqual + print_unqual = icPrintUnqual ictxt + +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 - ; mapM_ (\c -> loadImportedInsts c []) - (typeEnvClasses (eps_PTE eps)) + -- we've seen in any interface file so far) ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all - ; return (get home_ie ++ get pkg_ie) } + ; return [ ispec + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec + , relevant dfun + , plausibleDFun print_unqual dfun ] } where - get ie = [df | (_,_,df) <- instEnvElts ie, relevant df] relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) - tc_name = tyConName tc - -lookupInsts other = return [] + tc_name = tyConName tc +lookupInsts print_unqual other = return [] -toIfaceDecl :: TyThing -> IfaceDecl -toIfaceDecl 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 - ext_nm n = ExtPkg (nameModuleName n) (nameOccName n) + ok name | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | otherwise = True - -- munge transforms a thing to it's "parent" thing +toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +toIfaceDecl ext_nm thing + = tyThingToIfaceDecl ext_nm (munge thing) + where + -- munge transforms a thing to its "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) munge (AnId id) = case globalIdDetails id of RecordSelId tc lbl -> ATyCon tc @@ -1135,6 +1308,20 @@ toIfaceDecl thing other -> AnId id munge other_thing = other_thing +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} @@ -1196,10 +1383,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 && @@ -1210,9 +1398,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 @@ -1222,10 +1410,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