import FamInst
import InstEnv
import FamInstEnv
+import TcAnnotations
import TcBinds
import TcDefaults
import TcEnv
-- (in fact, it might not even need to be in the scope of
-- this tcg_env at all)
avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
- tc_envs <- extendGlobalRdrEnvRn False avails
- emptyFsEnv {- no fixity decls -} ;
+ tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ;
setEnvs tc_envs $ do {
my_exports = map (Avail . idName) bndrs ;
-- ToDo: export the data types also?
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+ final_type_env =
+ extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
mg_boot = False,
-- 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
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_rules = rules,
+ tcg_fords = fords } = tcg_env
; all_binds = binds `unionBags` inst_binds } ;
failIfErrsM ; -- Don't zonk if there have been errors
Nothing -> return ()
-- Rename the declarations
- ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; (tcg_env, HsGroup {
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fords = _,
+ hs_defds = _, -- Todo: check no foreign decls, no rules,
+ hs_ruleds = _, -- no default decls and no annotation decls
+ hs_annds = _,
+ hs_valds = val_binds }) <- 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 <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _deriv_binds)
- <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; traceTc (text "Tc5")
- ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+ ; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
-- 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 ]
+
-- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
dfun_prs = catMaybes mb_dfun_prs
boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+ dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
| (boot_dfun, dfun) <- dfun_prs ]
; failIfErrsM
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls group
- = do { -- Rename the source decls (with no shadowing; error on duplicates)
- (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
+ = do { -- Rename the source decls
+ (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-- save the renamed syntax, if we want it
let { tcg_env'
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
+ hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
traceTc (text "Tc7") ;
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Annotations
+ annotations <- tcAnnotations annotation_decls ;
+
-- Rules
rules <- tcRules rule_decls ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
inst_binds `unionBags`
- foe_binds ;
+ 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)
}}}}}}
(mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
- ; main_bind = noLoc (VarBind root_main_id rhs) }
+ ; main_bind = mkVarBind root_main_id rhs }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,