import DataCon
import Type
import Class
-import TcType ( tyClsNamesOfDFunHead )
+import TcType ( orphNamesOfDFunHead )
import Inst ( tcGetInstEnvs )
import Data.List ( sortBy )
setEnvs tc_envs $ do {
- rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+ (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
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) <- getConstraints $ 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
--
-- * 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 "Tc8" empty ;
- new_ev_binds <- setEnvs tc_envs (simplifyTop lie) ;
-
- -- Backsubstitution. This must be done last.
- -- Even simplifyTop may do some unification.
+ new_ev_binds <- simplifyTop lie ;
traceTc "Tc9" empty ;
- let { (tcg_env, _) = tc_envs
- ; TcGblEnv { tcg_type_env = type_env,
- tcg_binds = binds,
- tcg_ev_binds = cur_ev_binds,
- tcg_rules = rules,
- tcg_fords = fords } = tcg_env } ;
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!
- let { all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
- (bind_ids, ev_binds', binds', fords', rules')
- <- zonkTopDecls all_ev_binds binds rules fords ;
-
+ -- 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_fords = fords } = tcg_env
+ ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+
+ (bind_ids, ev_binds', binds', fords', imp_specs', rules')
+ <- zonkTopDecls all_ev_binds binds sig_ns rules 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_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
hs_ruleds = rule_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
- ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do {
+ ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
-- Check for illegal declarations
-- Family instance declarations are rejected here
; 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
= 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
-- and import the supporting declarations
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.
-- 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 "Tc5" empty ;
- (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
- tcTopBinds val_binds;
+ (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
+ tcTopBinds val_binds;
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
traceTc "Tc6" empty ;
- inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
+ inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
-- Foreign exports
traceTc "Tc7" empty ;
tc_deriv_binds `unionBags`
tc_aux_binds `unionBags`
inst_binds `unionBags`
- foe_binds;
+ 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_rules = tcg_rules tcg_env ++ rules,
- tcg_anns = tcg_anns tcg_env ++ annotations,
- tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_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_anns = tcg_anns tcg_env ++ annotations
+ , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
\end{code}
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) ;
-- OK, we're ready to typecheck the stmts
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
- ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ ->
+ ((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
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
- ((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ;
- ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -}
- (tyVarsOfType res_ty) lie) ;
+
+ 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) } ;
, 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 []