isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
)
import PrelNames ( ioTyConName, printName,
- returnIOName, bindIOName, failIOName, runMainName,
+ returnIOName, bindIOName, failIOName, thenIOName, runIOName,
dollarMainName, itName
)
import MkId ( unsafeCoerceId )
TypecheckedForeignDecl, TypecheckedRuleDecl,
TypecheckedCoreBind,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
- zonkExpr, zonkIdBndr, zonkCoreBinds
+ zonkExpr, zonkIdBndr
)
import Rename ( RnResult(..) )
tc_stmts names stmts
- = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id ->
- tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id ->
- tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id ->
+ = mapNF_Tc tcLookupGlobalId
+ [returnIOName, failIOName, bindIOName, thenIOName] `thenNF_Tc` \ io_ids ->
tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
let
+ return_id = head io_ids -- Rather gruesome
+
io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
-- mk_return builds the expression
traceTc (text "tcs 4") `thenNF_Tc_`
returnTc (mkHsLet const_binds $
- HsDoOut DoExpr tc_stmts return_id bind_id fail_id
- (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
+ HsDo DoExpr tc_stmts io_ids
+ (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
ids)
where
combine stmt (ids, stmts) = (ids, stmt:stmts)
lie_rules `plusLIE`
lie_main
in
- tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
- traceTc (text "endsimpltop") `thenTc_`
+ tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
+ traceTc (text "endsimpltop") `thenTc_`
+
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
fixTc (\ ~(unf_env, _, _, _) ->
-- This fixTc follows the same general plan as tcImports,
-- which is better commented (below)
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
-- tcImports recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
- traceTc (text "Tc1") `thenNF_Tc_`
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
+ traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
-> HomeSymbolTable
-> ModIface -- Iface for this module (just module & fixities)
-> [RenamedHsDecl]
- -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedCoreBind]))
+ -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
typecheckCoreModule dflags pcs hst mod_iface decls
= do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
- (tcCoreDecls this_mod decls `thenTc` \ (env,bs) ->
- zonkCoreBinds bs `thenNF_Tc` \ bs' ->
- returnTc (env, bs'))
+ tcCoreDecls this_mod decls
-- ; printIfaceDump dflags maybe_tc_stuff
-- (in the event that it needs to be, I'm returning the PCS passed in.)
; case maybe_tc_stuff of
Nothing -> return Nothing
- Just (e,bs) -> return (Just (pcs, e, bs)) }
+ Just result -> return (Just (pcs, result)) }
where
this_mod = mi_module mod_iface
core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
+
tcCoreDecls :: Module
-> [RenamedHsDecl] -- All interface-file decls
- -> TcM (TypeEnv, [TypecheckedCoreBind])
+ -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
tcCoreDecls this_mod decls
-- The decls are all TyClD declarations coming from External Core input.
= let
tycl_decls = [d | TyClD d <- decls]
+ rule_decls = [d | RuleD d <- decls]
core_decls = filter isCoreDecl tycl_decls
in
fixTc (\ ~(unf_env, _) ->
-- This fixTc follows the same general plan as tcImports,
-- which is better commented.
-- [ Q: do we need to tie a knot for External Core? ]
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
- tcCoreBinds tycl_decls `thenTc` \ core_binds ->
- tcGetEnv `thenTc` \ env ->
- returnTc (env, core_binds)
- ) `thenTc` \ ~(final_env,bs) ->
- let
- src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
- in
- returnTc (mkTypeEnv src_things, bs)
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ tcCoreBinds core_decls `thenTc` \ core_prs ->
+ let
+ local_ids = map fst core_prs
+ in
+ tcExtendGlobalValEnv local_ids $
+
+ tcIfaceRules rule_decls `thenTc` \ rules ->
+
+ let
+ src_things = filter (isLocalThing this_mod) tycl_things
+ ++ map AnId local_ids
+ in
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (env, (mkTypeEnv src_things, core_prs, rules))
+ ) `thenTc` \ (_, result) ->
+ returnTc result
\end{code}
b) Main.main :: forall a1...an. IO t, for some type t
Then we build
- $main = PrelTopHandler.runMain Main.main
+ $main = GHC.TopHandler.runIO Main.main
The function
- PrelTopHandler :: IO a -> IO ()
+ GHC.TopHandler.runIO :: IO a -> IO a
catches the top level exceptions.
It accepts a Main.main of any type (IO a).
newTyVarTy liftedTypeKind `thenNF_Tc` \ ty ->
tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) ->
zonkTcType ty `thenNF_Tc` \ ty ->
- ASSERT( is_io_unit ty )
+ ASSERT( is_io ty )
let
dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
in
returnTc (VarMonoBind dollar_main_id main_expr, lie)
where
- rhs = HsApp (HsVar runMainName) (HsVar main_name)
+ rhs = HsApp (HsVar runIOName) (HsVar main_name)
-is_io_unit :: Type -> Bool -- True for IO ()
-is_io_unit tau = case tcSplitTyConApp_maybe tau of
- Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg
+is_io :: Type -> Bool -- True for IO a
+is_io tau = case tcSplitTyConApp_maybe tau of
+ Just (tc, [_]) -> getName tc == ioTyConName
other -> False
mainCtxt = ptext SLIT("When checking the type of 'main'")
projects / ghc-hetmet.git / blobdiff