+ -> PrintUnqualified -- For error printing
+ -> RnResult
+ -> IO (Maybe (PersistentCompilerState, TcResults))
+ -- The new PCS is Augmented with imported information,
+ -- (but not stuff from this module)
+
+data TcResults
+ = TcResults {
+ -- All these fields have info *just for this module*
+ tc_env :: TypeEnv, -- The top level TypeEnv
+ tc_insts :: [DFunId], -- Instances
+ tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
+ tc_binds :: TypecheckedMonoBinds, -- Bindings
+ tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
+ }
+
+
+typecheckModule dflags pcs hst unqual rn_result
+ = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
+ tcModule pcs hst rn_result
+ ; printTcDump dflags unqual maybe_tc_result
+ ; return maybe_tc_result }
+
+tcModule :: PersistentCompilerState
+ -> HomeSymbolTable
+ -> RnResult
+ -> TcM (PersistentCompilerState, TcResults)
+
+tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
+ rr_fixities = fix_env, rr_main = maybe_main_name })
+ = fixTc (\ ~(unf_env, _, _) ->
+ -- Loop back the final environment, including the fully zonked
+ -- versions of bindings from this module. In the presence of mutual
+ -- recursion, interface type signatures may mention variables defined
+ -- in this module, which is why the knot is so big
+
+ -- Type-check the type and class decls, and all imported decls
+ tcImports unf_env pcs hst this_mod
+ tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
+
+ tcSetEnv env1 $
+
+ -- Do the source-language instances, including derivings
+ initInstEnv new_pcs hst `thenNF_Tc` \ inst_env1 ->
+ tcInstDecls1 (pcs_PRS new_pcs) inst_env1
+ fix_env this_mod
+ tycl_decls src_inst_decls `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
+ tcSetInstEnv inst_env2 $
+
+ -- Foreign import declarations next
+ traceTc (text "Tc4") `thenNF_Tc_`
+ tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
+ tcExtendGlobalValEnv fo_ids $
+
+ -- Default declarations
+ tcDefaults decls `thenTc` \ defaulting_tys ->
+ tcSetDefaultTys defaulting_tys $
+
+ -- Value declarations next.
+ -- We also typecheck any extra binds that came out of the "deriving" process
+ traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
+ traceTc (text "Tc5") `thenNF_Tc_`
+ tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
+
+ -- Second pass over class and instance declarations,
+ -- plus rules and foreign exports, to generate bindings
+ tcSetEnv env2 $
+ traceTc (text "Tc6") `thenNF_Tc_`
+ traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
+ tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
+ tcExtendGlobalValEnv dm_ids $
+ traceTc (text "Tc7") `thenNF_Tc_`
+ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ traceTc (text "Tc8") `thenNF_Tc_`
+ tcForeignExports this_mod decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
+ traceTc (text "Tc9") `thenNF_Tc_`
+ tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
+
+ -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
+ traceTc (text "Tc10") `thenNF_Tc_`
+ tcCheckMain maybe_main_name `thenTc` \ (main_bind, lie_main) ->
+
+ -- Deal 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. (Usually, ambiguous type variables are resolved
+ -- during the generalisation step.)
+ --
+ -- Note that we must do this *after* tcCheckMain, because of the
+ -- following bizarre case:
+ -- main = return ()
+ -- Here, we infer main :: forall a. m a, where m is a free
+ -- type variable. tcCheckMain will unify it with IO, and that
+ -- must happen before tcSimplifyTop, since the latter will report
+ -- m as ambiguous
+ let
+ lie_alldecls = lie_valdecls `plusLIE`
+ lie_instdecls `plusLIE`
+ lie_clasdecls `plusLIE`
+ lie_fodecls `plusLIE`
+ lie_rules `plusLIE`
+ lie_main
+ in
+ tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
+ traceTc (text "endsimpltop") `thenTc_`
+
+ -- Backsubstitution. This must be done last.
+ -- Even tcSimplifyTop may do some unification.
+ let
+ all_binds = val_binds `AndMonoBinds`
+ inst_binds `AndMonoBinds`
+ cls_dm_binds `AndMonoBinds`
+ const_inst_binds `AndMonoBinds`
+ foe_binds `AndMonoBinds`
+ main_bind
+ in
+ traceTc (text "Tc7") `thenNF_Tc_`
+ zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
+ tcSetEnv final_env $
+ -- zonkTopBinds puts all the top-level Ids into the tcGEnv
+ traceTc (text "Tc8") `thenNF_Tc_`
+ zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
+ traceTc (text "Tc9") `thenNF_Tc_`
+ zonkRules src_rules `thenNF_Tc` \ src_rules' ->
+
+
+ let src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
+ -- This is horribly crude; the env might be jolly big
+ in
+ traceTc (text "Tc10") `thenNF_Tc_`
+ returnTc (final_env,
+ new_pcs,
+ TcResults { tc_env = mkTypeEnv src_things,
+ tc_insts = map iDFunId inst_info,
+ tc_binds = all_binds',
+ tc_fords = foi_decls ++ foe_decls',
+ tc_rules = src_rules'
+ }
+ )
+ ) `thenTc` \ (_, pcs, tc_result) ->
+ returnTc (pcs, tc_result)