X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=925b838297dc970d1cb1cba8388ee88abd6265cd;hb=02a06a56c6511b19ef411fd3884089ea996cc26b;hp=ef817f3f8b2abf84889dcae06dec2388f4c40408;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index ef817f3..925b838 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,10 +6,11 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkExportEnv, getModuleContents, tcRnStmt, + getModuleContents, tcRnStmt, tcRnGetInfo, GetInfoResult, tcRnExpr, tcRnType, tcRnLookupRdrName, + getModuleExports, #endif tcRnModule, tcTopSrcDecls, @@ -35,8 +36,7 @@ import RdrHsSyn ( findSplice ) import PrelNames ( runMainIOName, rootMainName, mAIN, main_RDR_Unqual ) -import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, - plusGlobalRdrEnv ) +import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad @@ -63,10 +63,9 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) +import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv ) import OccName ( mkVarOcc ) -import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, - getOccName, isWiredInName ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName ) import NameSet import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) @@ -84,55 +83,52 @@ import Outputable #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), - LStmt, LHsExpr, LHsType, mkMatchGroup, - collectLStmtsBinders, mkSimpleMatch, nlVarPat, + LStmt, LHsExpr, LHsType, mkVarBind, + collectLStmtsBinders, collectLStmtBinders, nlVarPat, placeHolderType, noSyntaxExpr ) -import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), - Provenance(..), ImportSpec(..), - lookupLocalRdrEnv, extendLocalRdrEnv ) +import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, + unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) -import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) import TcMatches ( tcStmts, tcDoStmt ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, - isUnLiftedType, tyClsNamesOfDFunHead ) + isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) import Inst ( tcGetInstEnvs ) -import InstEnv ( DFunId, classInstances, instEnvElts ) +import InstEnv ( classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) -import LoadIface ( loadSrcInterface, ifaceInstGates ) +import LoadIface ( loadSrcInterface, loadSysInterface ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), - tyThingToIfaceDecl, instanceToIfaceInst ) -import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType, - interactiveExtNameFun, isLocalIfaceExtName ) + 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, setIdType, globalIdDetails ) +import Id ( isImplicitId, setIdType, globalIdDetails ) 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, nameParent_maybe ) +import OccName ( occNameUserString, isTcOcc ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, bindIOName, thenIOName, returnIOName ) -import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses, +import HscTypes ( InteractiveContext(..), HomeModInfo(..), availNames, availName, ModIface(..), icPrintUnqual, - ModDetails(..), Dependencies(..) ) + Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) -import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, unLoc, noSrcSpan ) #endif import FastString ( mkFastString ) @@ -178,11 +174,14 @@ tcRnModule hsc_env hsc_src save_rn_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 @@ -291,11 +290,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 ; @@ -551,10 +548,11 @@ checkHiBootIface let dfun = instanceDFunId inst, idType dfun `tcEqType` boot_inst_ty ] of [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag } - (dfun:_) -> return (unitBag $ noLoc $ VarBind boot_dfun (nlHsVar dfun)) + (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) @@ -588,7 +586,7 @@ missingBootThing thing bootMisMatch thing = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") instMisMatch inst - = hang (ptext SLIT("instance") <+> ppr inst) + = hang (ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) \end{code} @@ -626,12 +624,9 @@ tcRnGroup boot_details 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 @@ -694,12 +689,12 @@ tcTopSrcDecls boot_details -- 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 ++ 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 @@ -722,7 +717,7 @@ tcTopSrcDecls boot_details 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} @@ -847,8 +842,14 @@ tcRnStmt hsc_env ictxt rdr_stmt 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 @@ -859,7 +860,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 ; @@ -884,10 +885,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 @@ -919,33 +923,65 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- -tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) -tcUserStmt (L loc (ExprStmt expr _ _)) - = newUnique `thenM` \ uniq -> - let - fresh_it = itName uniq - the_bind = noLoc $ FunBind (noLoc fresh_it) False - (mkMatchGroup [mkSimpleMatch [] expr]) - in - tryTcLIE_ (do { -- Try this if the other fails - traceTc (text "tcs 1b") ; - tc_stmts (map (L loc) [ - LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], - ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) placeHolderType - ]) }) - (do { -- Try this first - traceTc (text "tcs 1a") ; - tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr - (HsVar bindIOName) noSyntaxExpr) ] }) - -tcUserStmt stmt = tc_stmts [stmt] +type PlanResult = ([Id], LHsExpr Id) +type Plan = TcM PlanResult + +runPlans :: [Plan] -> TcM PlanResult +-- Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcLIE_ (runPlans ps) p + +-------------------- +mkPlan :: LStmt Name -> TcM PlanResult +mkPlan (L loc (ExprStmt expr _ _)) + = do { uniq <- newUnique + ; let fresh_it = itName uniq + the_bind = mkVarBind noSrcSpan fresh_it expr + let_stmt = L loc $ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive] + 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] + -- [let it = e] + ; runPlans [do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; ifM (isUnitTy it_ty) failM + ; return stuff }, + tcGhciStmts [bind_stmt], + tcGhciStmts [let_stmt, print_it], + tcGhciStmts [let_stmt] + ]} + +mkPlan stmt@(L loc _) + | [L _ v] <- collectLStmtBinders stmt -- One binder + = 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) failM + ; return stuff }, + tcGhciStmts [stmt] + ]} + | otherwise + = tcGhciStmts [stmt] --------------------------- -tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id) -tc_stmts stmts +tcGhciStmts :: [LStmt Name] -> TcM PlanResult +tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; + ret_id <- tcLookupId returnIOName ; -- return @ IO let { + io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; @@ -962,51 +998,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 { - (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $ - do { - -- Look up the names right in the middle, - -- where they will all be in scope - ids <- mappM tcLookupId names ; - return ids } ; - - ret_id <- tcLookupId returnIOName ; -- return @ IO - return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty)) - } ; - - -- Simplify the context right here, so that we fail - -- if there aren't enough instances. Notably, when we see - -- e - -- we use recoverTc_ to try it <- e - -- and then let it = e - -- It's the simplify step that rejects the first. - traceTc (text "tcs 3") ; - const_binds <- tcSimplifyInteractive lie ; - - -- Build result expression and zonk it - let { expr = mkHsLet const_binds tc_expr } ; - zonked_expr <- zonkTopLExpr expr ; - zonked_ids <- zonkTopBndrs ids ; - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; - - return (zonked_ids, zonked_expr) - } - where - bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + ((tc_stmts, ids), lie) <- getLIE $ + tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $ + mappM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + return (ids, mkHsLet const_binds $ + noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) + } \end{code} @@ -1073,33 +1085,17 @@ 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 - } - -getModuleExports :: Module -> TcM GlobalRdrEnv -getModuleExports mod - = do { iface <- load_iface mod - ; loadOrphanModules (dep_orphs (mi_deps iface)) - -- Load any orphan-module interfaces, - -- so their instances are visible - ; names <- ifaceExportNames (mi_exports iface) - ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] } - ; returnM (mkGlobalRdrEnv gres) } - -vanillaProv :: Module -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod = Imported [ImportSpec mod mod False - (srcLocSpan interactiveSrcLoc)] False +getModuleExports :: HscEnv -> Module -> IO (Maybe NameSet) +getModuleExports hsc_env mod + = initTcPrintErrors hsc_env 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) \end{code} \begin{code} @@ -1185,8 +1181,8 @@ lookup_rdr_name rdr_name = do { -- 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) @@ -1225,6 +1221,12 @@ 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 @@ -1232,7 +1234,7 @@ tcRnGetInfo hsc_env ictxt rdr_name -- their parent declaration let { do_one name = do { thing <- tcLookupGlobal name ; fixity <- lookupFixityRn name - ; ispecs <- lookupInsts ext_nm thing + ; ispecs <- lookupInsts print_unqual thing ; return (str, toIfaceDecl ext_nm thing, fixity, getSrcLoc thing, [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) @@ -1242,60 +1244,60 @@ tcRnGetInfo hsc_env ictxt rdr_name -- str is the the naked occurrence name -- after stripping off qualification and parens (+) str = occNameUserString (nameOccName name) + + ; parent_is_there n + | Just p <- nameParent_maybe n = p `elem` good_names + | otherwise = False } ; - -- For the SrcLoc, the 'thing' has better info than - -- the 'name' because getting the former forced the - -- declaration to be loaded into the cache + -- 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)) + mapM do_one (filter (not . parent_is_there) good_names) + -- Filter out names whose parent is also there + -- Good example is '[]', which is both a type and data constructor + -- in the same type } where - cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2 - ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) - + ext_nm = interactiveExtNameFun print_unqual + print_unqual = icPrintUnqual ictxt -lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [Instance] +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 +lookupInsts print_unqual (AClass cls) + = do { inst_envs <- tcGetInstEnvs ; return [ ispec | ispec <- classInstances inst_envs cls - , let (_, tycons) = ifaceInstGates (ifInstHead (instanceToIfaceInst ext_nm ispec)) - -- 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 - + , 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 (instanceToIfaceInst ext_nm dfun)) - , isLocalIfaceExtName cls ] } + , plausibleDFun print_unqual dfun ] } where - relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType (instanceDFunId df)) + relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts ext_nm other = return [] +lookupInsts print_unqual other = return [] +plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified + = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) + where + ok name | isBuiltInSyntax name = True + | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | otherwise = True toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl toIfaceDecl ext_nm thing - = tyThingToIfaceDecl True -- Discard IdInfo - emptyNameSet -- Show data cons - ext_nm (munge thing) + = tyThingToIfaceDecl ext_nm (munge thing) where -- munge transforms a thing to its "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) @@ -1304,6 +1306,21 @@ toIfaceDecl ext_nm thing ClassOpId cls -> AClass cls 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}