\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkExportEnv, getModuleContents, tcRnStmt,
+ getModuleContents, tcRnStmt,
tcRnGetInfo, GetInfoResult,
tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ getModuleExports,
#endif
tcRnModule,
tcTopSrcDecls,
import StaticFlags ( opt_PprStyle_Debug )
import Packages ( moduleToPackageConfig, mkPackageId, package,
isHomeModule )
-import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
+import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
+ SpliceDecl(..), HsBind(..), LHsBinds,
+ emptyGroup, appendGroups,
nlHsApp, nlHsVar, pprLHsBinds )
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
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, iDFunId )
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 ( 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 )
#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 )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
+ isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
-import InstEnv ( 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, dfunToIfaceInst )
-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 Bag ( unitBag )
-import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcLoc, unLoc, noSrcSpan )
#endif
import FastString ( mkFastString )
import Util ( sortLe )
-import Bag ( unionBags, snocBag )
+import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
import Maybe ( isJust )
\end{code}
\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
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
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 emptyGroup
+ else
+ Nothing })
$ do {
traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
-- 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 ;
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_binds = binds',
+ tcg_rules = rules',
tcg_fords = fords' } } ;
- -- Compare the hi-boot iface (if any) with the real thing
- checkHiBootIface tcg_env' boot_iface ;
-
-- 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'
+ -- 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 :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
= 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 :: TcGblEnv -> ModDetails -> 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.
+--
+-- 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_inst boot_insts
- ; mapM_ check_one (typeEnvElts 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
|| name `elem` dfun_names
dfun_names = map getName boot_insts
- check_inst inst
- | null [i | i <- local_insts, idType i `tcEqType` idType inst]
- = addErrTc (instMisMatch inst)
- | otherwise
- = return ()
+ 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)
bootMisMatch thing
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
instMisMatch inst
- = hang (ptext SLIT("instance") <+> ppr (idType inst))
+ = hang (ppr inst)
2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
\end{code}
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)
}}
------------------------------------------------
-- 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
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}
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
-- (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 ;
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
\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 || not (isTauTy 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] ;
-- 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}
\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}
---------------------
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?
-- 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)
= 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
-- their parent declaration
let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
- ; dfuns <- 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) | dfun <- dfuns]
+ [(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)
+
+ ; 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 [DFunId]
+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 []
+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)
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}
ppr_rules rules ]
-ppr_types :: [Var] -> TypeEnv -> SDoc
-ppr_types dfun_ids type_env
+ppr_types :: [Instance] -> TypeEnv -> SDoc
+ppr_types ispecs type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
+ dfun_ids = map instanceDFunId ispecs
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
-- that the type checker has invented. Top-level user-defined things
-- have External names.
-ppr_insts :: [Var] -> SDoc
-ppr_insts [] = empty
-ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
+ppr_insts :: [Instance] -> SDoc
+ppr_insts [] = empty
+ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
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
projects / ghc-hetmet.git / blobdiff