% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcModule]{Typechecking a whole module}
+\section[TcMovectle]{Typechecking a whole module}
\begin{code}
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ getModuleExports,
+#endif
+ tcRnImports,
tcRnLookupName,
tcRnGetInfo,
- getModuleExports,
-#endif
tcRnModule,
tcTopSrcDecls,
tcRnExtCore
import TcExpr
import TcRnMonad
import Coercion
-import Inst
import FamInst
import InstEnv
import FamInstEnv
import TcAnnotations
import TcBinds
+import TcType ( tidyTopType )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
+import TcMType
import MkIface
import IfaceSyn
import TcSimplify
import TcTyClsDecls
-import TcUnify ( withBox )
import LoadIface
import RnNames
import RnEnv
import VarEnv
import Var
import Module
-import LazyUniqFM
+import UniqFM
import Name
import NameEnv
import NameSet
import DataCon
import Type
import Class
+import TcType ( orphNamesOfDFunHead )
+import Inst ( tcGetInstEnvs )
import Data.List ( sortBy )
#ifdef GHCI
+import TcType ( isUnitTy, isTauTy )
+import CoreUtils( mkPiTypes )
import TcHsType
-import TcMType
import TcMatches
import RnTypes
import RnExpr
import MkId
import BasicTypes
import TidyPgm ( globaliseAndTidyId )
-import TcType ( isUnitTy, isTauTy, tyClsNamesOfDFunHead )
import TysWiredIn ( unitTy, mkListTy )
#endif
setEnvs tc_envs $ do {
- rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+ (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
+ mg_vect_decls = [],
mg_anns = [],
mg_binds = core_binds,
mkFakeGroup :: [LTyClDecl a] -> HsGroup a
mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = emptyRdrGroup { hs_tyclds = decls }
+ = emptyRdrGroup { hs_tyclds = [decls] }
\end{code}
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls boot_iface decls
= do { -- Do all the declarations
- (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+ (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
+ ; traceTc "Tc8" empty ;
+ ; setEnvs tc_envs $
+ do {
-- Finish simplifying class constraints
--
- -- tcSimplifyTop deals with constant or ambiguous InstIds.
+ -- simplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
-- top-level decl falls under the monomorphism restriction
-- and no subsequent decl instantiates its type.
-- thaat checkMain adds
--
-- We do it with both global and local env in scope:
- -- * the global env exposes the instances to tcSimplifyTop
- -- * the local env exposes the local Ids to tcSimplifyTop,
+ -- * the global env exposes the instances to simplifyTop
+ -- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
- traceTc (text "Tc8") ;
- inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
-
- -- Backsubstitution. This must be done last.
- -- Even tcSimplifyTop may do some unification.
- traceTc (text "Tc9") ;
- let { (tcg_env, _) = tc_envs
- ; TcGblEnv { tcg_type_env = type_env,
- tcg_binds = binds,
- tcg_rules = rules,
- tcg_fords = fords } = tcg_env
- ; all_binds = binds `unionBags` inst_binds } ;
+ new_ev_binds <- simplifyTop lie ;
+ traceTc "Tc9" empty ;
failIfErrsM ; -- Don't zonk if there have been errors
-- It's a waste of time; and we may get debug warnings
-- about strangely-typed TyCons!
- (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
-
-
- let { final_type_env = extendTypeEnvWithIds type_env bind_ids
- ; tcg_env' = tcg_env { tcg_binds = binds',
- tcg_rules = rules',
- tcg_fords = fords' } } ;
-
- setGlobalTypeEnv tcg_env' final_type_env
- }
+ -- Zonk the final code. This must be done last.
+ -- Even simplifyTop may do some unification.
+ -- This pass also warns about missing type signatures
+ let { (tcg_env, _) = tc_envs
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_sigs = sig_ns,
+ tcg_ev_binds = cur_ev_binds,
+ tcg_imp_specs = imp_specs,
+ tcg_rules = rules,
+ tcg_vects = vects,
+ tcg_fords = fords } = tcg_env
+ ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+
+ (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
+ <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
+
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+ ; tcg_env' = tcg_env { tcg_binds = binds',
+ tcg_ev_binds = ev_binds',
+ tcg_imp_specs = imp_specs',
+ tcg_rules = rules',
+ tcg_vects = vects',
+ tcg_fords = fords' } } ;
+
+ setGlobalTypeEnv tcg_env' final_type_env
+ } }
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
-- Loops around dealing with each top level inter-splice group
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
-- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
+ Just (SpliceDecl splice_expr _, rest_ds) -> do {
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
= do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
- ; (tcg_env, HsGroup {
+ ; (tcg_env, HsGroup {
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fords = for_decls,
hs_defds = def_decls,
hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
- ; setGblEnv tcg_env $ do {
+ ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
-- Check for illegal declarations
; case group_tail of
- Just (SpliceDecl d, _) -> badBootDecl "splice" d
- Nothing -> return ()
+ Just (SpliceDecl d _, _) -> badBootDecl "splice" d
+ Nothing -> return ()
; mapM_ (badBootDecl "foreign") for_decls
; mapM_ (badBootDecl "default") def_decls
; mapM_ (badBootDecl "rule") rule_decls
+ ; mapM_ (badBootDecl "vect") vect_decls
-- Typecheck type/class decls
- ; traceTc (text "Tc2")
- ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $ do {
+ ; traceTc "Tc2" empty
+ ; (tcg_env, aux_binds, dm_ids)
+ <- tcTyAndClassDecls emptyModDetails tycl_decls
+ ; setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
- ; traceTc (text "Tc3")
+ ; traceTc "Tc3" empty
; (tcg_env, inst_infos, _deriv_binds)
- <- tcInstDecls1 tycl_decls inst_decls deriv_decls
+ <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
+
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
- ; traceTc (text "Tc5")
+ ; traceTc "Tc5" empty
; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
- ; traceTc (text "Tc7a")
+ ; traceTc "Tc7a" empty
; gbl_env <- getGblEnv
-- Make the final type-env
}
; setGlobalTypeEnv gbl_env type_env3
- }}}}
+ }}}
+ ; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: String -> Located decl -> TcM ()
badBootDecl what (L loc _)
= return tcg_env
| otherwise
- = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$
- ppr boot_exports)) ;
+ = do { traceTc "checkHiBootIface" $ vcat
+ [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
-- Check the exports of the boot module, one by one
; mapM_ check_export boot_exports
-- Check instance declarations
; mb_dfun_prs <- mapM check_inst boot_insts
- ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds,
- tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
- dfun_prs = catMaybes mb_dfun_prs
- boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
- | (boot_dfun, dfun) <- dfun_prs ]
+ ; let dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+ type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
+ tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
; failIfErrsM
- ; return tcg_env' }
+ ; setGlobalTypeEnv tcg_env' type_env' }
+ -- Update the global type env *including* the knot-tied one
+ -- so that if the source module reads in an interface unfolding
+ -- mentioning one of the dfuns from the boot module, then it
+ -- can "see" that boot dfun. See Trac #4003
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
- [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+ [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
+ , text "boot_inst" <+> ppr boot_inst
+ , text "boot_inst_ty" <+> ppr boot_inst_ty
+ ])
+ ; addErrTc (instMisMatch boot_inst); return Nothing }
(dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
env = rnBndrs2 env0 tvs1 tvs2
- eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _)
- = tcEqTypeX env k1 k2
+ eqSynRhs SynFamilyTyCon SynFamilyTyCon
+ = True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
= tcEqTypeX env t1 t2
eqSynRhs _ _ = False
env0 = mkRnEnv2 emptyInScopeSet
eqAlgRhs AbstractTyCon _ = True
- eqAlgRhs OpenTyCon{} OpenTyCon{} = True
+ eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
eqListBy eqCon (data_cons tc1) (data_cons tc2)
eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
-- Fails if there are any errors
rnTopSrcDecls group
= do { -- Rename the source decls
+ traceTc "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+ traceTc "rn13" empty ;
-- save the renamed syntax, if we want it
let { tcg_env'
hs_defds = default_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
- traceTc (text "Tc2") ;
+ traceTc "Tc2" empty ;
- (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $ do {
+ setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
+
-- Source-language instances, including derivings,
-- and import the supporting declarations
- traceTc (text "Tc3") ;
+ traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
- <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
+ <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
setGblEnv tcg_env $ do {
-- Foreign import declarations next.
- traceTc (text "Tc4") ;
+ traceTc "Tc4" empty ;
(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
-- Default declarations
- traceTc (text "Tc4a") ;
+ traceTc "Tc4a" empty ;
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-- Now GHC-generated derived bindings, generics, and selectors
-- Do not generate warnings from compiler-generated code;
-- hence the use of discardWarnings
- (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
- (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $
- discardWarnings (tcTopBinds deriv_binds) ;
+ (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
+ (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $
+ discardWarnings (tcTopBinds deriv_binds) ;
-- Value declarations next
- traceTc (text "Tc5") ;
- (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
- tcTopBinds val_binds;
-
- -- Second pass over class and instance declarations,
- traceTc (text "Tc6") ;
- (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $
- tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
+ traceTc "Tc5" empty ;
+ (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
+ tcTopBinds val_binds;
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
- -- Foreign exports
- traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Second pass over class and instance declarations,
+ traceTc "Tc6" empty ;
+ inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+
+ -- Foreign exports
+ traceTc "Tc7" empty ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-- Annotations
- annotations <- tcAnnotations annotation_decls ;
+ annotations <- tcAnnotations annotation_decls ;
- -- Rules
- rules <- tcRules rule_decls ;
+ -- Rules
+ rules <- tcRules rule_decls ;
- -- Wrap up
- traceTc (text "Tc7a") ;
+ -- Vectorisation declarations
+ vects <- tcVectDecls vect_decls ;
+
+ -- Wrap up
+ traceTc "Tc7a" empty ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
tc_aux_binds `unionBags`
inst_binds `unionBags`
- foe_binds;
-
- -- Extend the GblEnv with the (as yet un-zonked)
- -- bindings, rules, foreign decls
- tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
- tcg_rules = tcg_rules tcg_env ++ rules,
- tcg_anns = tcg_anns tcg_env ++ annotations,
- tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', tcl_env)
+ foe_binds
+
+ ; sig_names = mkNameSet (collectHsValBinders val_binds)
+ `minusNameSet` getTypeSigNames val_binds
+
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
+ , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
+ specs3
+ , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names
+ , tcg_rules = tcg_rules tcg_env ++ rules
+ , tcg_vects = tcg_vects tcg_env ++ vects
+ , tcg_anns = tcg_anns tcg_env ++ annotations
+ , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+ return (tcg_env', tcl_env)
}}}}}}
\end{code}
check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
check_main dflags tcg_env
| mod /= main_mod
- = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
return tcg_env
| otherwise
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
- Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+ Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
; complain_no_main
; return tcg_env } ;
Just main_name -> do
- { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+ { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
; let loc = srcLocSpan (getSrcLoc main_name)
; ioTyCon <- tcLookupTyCon ioTyConName
- ; (main_expr, res_ty)
+ ; res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; main_expr
<- addErrCtxt mainCtxt $
- withBox liftedTypeKind $ \res_ty ->
tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
-- See Note [Root-main Id]
%*********************************************************
\begin{code}
-#ifdef GHCI
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let -- Initialise the tcg_inst_env with instances from all home modules.
-- later ids in ic_tmp_ids must shadow earlier ones with the same
-- OccName, and tcExtendIdEnv implements this behaviour.
- do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+ do { traceTc "setIC" (ppr (ic_tmp_ids icxt))
; thing_inside }
\end{code}
\begin{code}
+#ifdef GHCI
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
setInteractiveContext hsc_env ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
- (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ;
+ (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
+ return ((), emptyFVs) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
rnDump (ppr rn_stmt) ;
-- cast them all to HValues in the end!
mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
- traceTc (text "tcs 1") ;
+ traceTc "tcs 1" empty ;
let { global_ids = map globaliseAndTidyId zonked_ids } ;
-- Note [Interactively-bound Ids in GHCi]
} ;
-- OK, we're ready to typecheck the stmts
- traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
- ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+ ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context
- traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ;
- const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
- traceTc (text "TcRnDriver.tcGhciStmts: done") ;
- return (ids, mkHsDictLet const_binds $
+ traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
}
\end{code}
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
- ((_tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
- _ <- tcSimplifyInteractive lie_top ; -- Ignore the dicionary bindings
- let { all_expr_ty = mkForAllTys qtvs $
- mkFunTys (map (idType . instToId) dict_insts) $
- res_ty } ;
+ uniq <- newUnique ;
+ let { fresh_it = itName uniq } ;
+ ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
+ ((qtvs, dicts, _), lie_top) <- captureConstraints $
+ simplifyInfer TopLevel
+ False {- No MR for now -}
+ [(fresh_it, res_ty)]
+ lie ;
+
+ _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
+
+ let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
zonkTcType all_expr_ty
}
- where
- smpl_doc = ptext (sLit "main expression")
\end{code}
tcRnType just finds the kind of a type
getModuleExports hsc_env mod
= let
ic = hsc_IC hsc_env
- checkMods = ic_toplev_scope ic ++ ic_exports ic
+ checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
in
initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
return good_names
}
+#endif
tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
- -> Name
- -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
+ -> Name
+ -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
-- Used to implement :info in GHCi
--
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- let ictxt = hsc_IC hsc_env in
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ tcRnGetInfo' hsc_env name
+
+tcRnGetInfo' :: HscEnv
+ -> Name
+ -> TcRn (TyThing, Fixity, [Instance])
+tcRnGetInfo' hsc_env name
+ = let ictxt = hsc_IC hsc_env in
setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
, let dfun = instanceDFunId ispec
, relevant dfun ] }
where
- relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
tc_name = tyConName tc
lookupInsts _ = return []
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}
%************************************************************************
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
- tcg_insts = insts,
- tcg_fam_insts = fam_insts,
- tcg_rules = rules,
- tcg_imports = imports })
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_rules = rules,
+ tcg_vects = vects,
+ tcg_imports = imports })
= vcat [ ppr_types insts type_env
, ppr_tycons fam_insts type_env
- , ppr_insts insts
- , ppr_fam_insts fam_insts
- , vcat (map ppr rules)
- , ppr_gen_tycons (typeEnvTyCons type_env)
- , ptext (sLit "Dependent modules:") <+>
- ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+ , ppr_insts insts
+ , ppr_fam_insts fam_insts
+ , vcat (map ppr rules)
+ , vcat (map ppr vects)
+ , ppr_gen_tycons (typeEnvTyCons type_env)
+ , ptext (sLit "Dependent modules:") <+>
+ ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
where -- The two uses of sortBy are just to reduce unnecessary
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
- nest 4 (pprRules rs),
+ nest 2 (pprRules rs),
ptext (sLit "#-}")]
ppr_gen_tycons :: [TyCon] -> SDoc