\begin{code}
module TcModule (
typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
- typecheckExtraDecls,
+ typecheckExtraDecls, typecheckCoreModule,
TcResults(..)
) where
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isSourceInstDecl, nullBinds, mkSimpleMatch, placeHolderType
+ isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
)
-import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
- returnIOName, bindIOName, failIOName,
- itName
+import PrelNames ( ioTyConName, printName,
+ returnIOName, bindIOName, failIOName, thenIOName, runMainName,
+ dollarMainName, itName
)
import MkId ( unsafeCoerceId )
-import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt,
- RenamedHsExpr, RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
+import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedHsExpr,
+ RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
+ TypecheckedCoreBind,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
zonkExpr, zonkIdBndr
)
+import Rename ( RnResult(..) )
import MkIface ( pprModDetails )
import TcExpr ( tcMonoExpr )
import TcMonad
-import TcMType ( newTyVarTy, zonkTcType, tcInstType )
+import TcMType ( newTyVarTy, zonkTcType )
import TcType ( Type, liftedTypeKind, openTypeKind,
- tyVarsOfType, tidyType, tcFunResultTy,
- mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
+ tyVarsOfType, tcFunResultTy,
+ mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys,
+ tcSplitTyConApp_maybe, isUnitTy
)
import TcMatches ( tcStmtsAndThen )
-import Inst ( emptyLIE, plusLIE )
+import Inst ( LIE, emptyLIE, plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
-import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
+import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
tcLookupGlobalId, tcLookupTyCon,
- TcTyThing(..), TyThing(..), tcLookupId
+ TyThing(..), tcLookupId
)
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
-import TcIfaceSig ( tcInterfaceSigs )
-import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, tcInstDecls2 )
-import TcUnify ( unifyTauTy )
+import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
+import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
import CoreUnfold ( unfoldingTemplate )
import ErrUtils ( printErrorsAndWarnings, errorsFound,
dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
import Rules ( extendRuleBase )
-import Id ( Id, idType, idUnfolding )
-import Module ( Module, moduleName )
-import Name ( Name )
-import NameEnv ( lookupNameEnv )
+import Id ( Id, mkLocalId, idType, idUnfolding, setIdLocalExported )
+import Module ( Module )
+import Name ( Name, getName, getSrcLoc )
import TyCon ( tyConGenInfo )
-import BasicTypes ( EP(..), Fixity, RecFlag(..) )
+import BasicTypes ( EP(..), RecFlag(..) )
import SrcLoc ( noSrcLoc )
import Outputable
import IO ( stdout )
tcSetDefaultTys defaultDefaultTys $
-- Typecheck the extra declarations
- tcExtraDecls pcs this_mod iface_decls `thenTc` \ (new_pcs, env) ->
+ tcExtraDecls pcs hst this_mod iface_decls `thenTc` \ (new_pcs, env) ->
tcSetEnv env $
tcExtendGlobalTypeEnv ic_type_env $
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
+ HsDoOut DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
ids)
where
tcSetDefaultTys defaultDefaultTys $
-- Typecheck the extra declarations
- tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, env) ->
+ tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, env) ->
-- Now typecheck the expression
tcSetEnv env $
typecheckExtraDecls dflags pcs hst unqual this_mod decls
= typecheck dflags pcs hst unqual $
- tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, _) ->
+ tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, _) ->
returnTc new_pcs
tcExtraDecls :: PersistentCompilerState
+ -> HomeSymbolTable
-> Module
-> [RenamedHsDecl]
-> TcM (PersistentCompilerState, TcEnv)
+ -- Returned environment includes instances
-tcExtraDecls pcs this_mod decls
+tcExtraDecls pcs hst this_mod decls
= tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
let
pcs_rules = new_pcs_rules
}
in
- -- Add the new instances
- tcSetEnv env (tcSetInstEnv new_pcs_insts tcGetEnv) `thenNF_Tc` \ new_env ->
+ -- Initialise the instance environment
+ tcSetEnv env (
+ initInstEnv new_pcs hst `thenNF_Tc` \ inst_env ->
+ tcSetInstEnv inst_env tcGetEnv
+ ) `thenNF_Tc` \ new_env ->
returnTc (new_pcs, new_env)
\end{code}
:: DynFlags
-> PersistentCompilerState
-> HomeSymbolTable
- -> ModIface -- Iface for this module
-> PrintUnqualified -- For error printing
- -> [RenamedHsDecl]
+ -> RnResult
-> IO (Maybe (PersistentCompilerState, TcResults))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module)
}
-typecheckModule dflags pcs hst mod_iface unqual decls
+typecheckModule dflags pcs hst unqual rn_result
= do { maybe_tc_result <- typecheck dflags pcs hst unqual $
- tcModule pcs hst get_fixity this_mod decls
+ tcModule pcs hst rn_result
; printTcDump dflags unqual maybe_tc_result
; return maybe_tc_result }
- where
- this_mod = mi_module mod_iface
- fixity_env = mi_fixities mod_iface
-
- get_fixity :: Name -> Maybe Fixity
- get_fixity nm = lookupNameEnv fixity_env nm
-
tcModule :: PersistentCompilerState
-> HomeSymbolTable
- -> (Name -> Maybe Fixity)
- -> Module
- -> [RenamedHsDecl]
+ -> RnResult
-> TcM (PersistentCompilerState, TcResults)
-tcModule pcs hst get_fixity this_mod decls
+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
-- 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 get_fixity this_mod
+ 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
- tcInstDecls1 new_pcs hst unf_env
- get_fixity this_mod
- tycl_decls src_inst_decls `thenTc` \ (inst_env, inst_info, deriv_binds) ->
- tcSetInstEnv inst_env $
+ 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_`
traceTc (text "Tc7") `thenNF_Tc_`
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
traceTc (text "Tc8") `thenNF_Tc_`
- tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
+ 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 this_mod `thenTc_`
+ 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
lie_instdecls `plusLIE`
lie_clasdecls `plusLIE`
lie_fodecls `plusLIE`
- lie_rules
+ 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.
let
- all_binds = val_binds `AndMonoBinds`
- inst_binds `AndMonoBinds`
- cls_dm_binds `AndMonoBinds`
- const_inst_binds `AndMonoBinds`
- foe_binds
+ 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) ->
rule_decls = [d | RuleD d <- decls]
inst_decls = [d | InstD d <- decls]
val_decls = [d | ValD d <- decls]
+
+ core_binds = [d | d <- tycl_decls, isCoreDecl d]
(src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
(src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
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 :: RecTcEnv
-> PersistentCompilerState
-> HomeSymbolTable
- -> (Name -> Maybe Fixity)
-> Module
-> [RenamedTyClDecl]
-> [RenamedInstDecl]
-- tcImports is only called when processing source code,
-- so that any interface-file declarations are for other modules, not this one
-tcImports unf_env pcs hst get_fixity this_mod
+tcImports unf_env pcs hst this_mod
tycl_decls inst_decls rule_decls
-- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
-- which is done lazily [ie failure just drops the pragma
-- 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
add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
\end{code}
+\begin{code}
+typecheckCoreModule
+ :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> ModIface -- Iface for this module (just module & fixities)
+ -> [RenamedHsDecl]
+ -> 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
+
+-- ; printIfaceDump dflags maybe_tc_stuff
+
+ -- Q: Is it OK not to extend PCS here?
+ -- (in the event that it needs to be, I'm returning the PCS passed in.)
+ ; case maybe_tc_stuff of
+ Nothing -> return Nothing
+ 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], [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 this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+
+ 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}
+
%************************************************************************
%* *
%************************************************************************
We must check that in module Main,
- a) main is defined
- b) main :: forall a1...an. IO t, for some type t
+ a) Main.main is in scope
+ b) Main.main :: forall a1...an. IO t, for some type t
-If we have
- main = error "Urk"
-then the type of main will be
- main :: forall a. a
-and that should pass the test too.
+Then we build
+ $main = PrelTopHandler.runMain Main.main
-So we just instantiate the type and unify with IO t, and declare
-victory if doing so succeeds.
+The function
+ PrelTopHandler :: IO a -> IO ()
+catches the top level exceptions.
+It accepts a Main.main of any type (IO a).
\begin{code}
-tcCheckMain :: Module -> TcM ()
-tcCheckMain this_mod
- | not (moduleName this_mod == mAIN_Name )
- = returnTc ()
-
- | otherwise
- = -- First unify the main_id with IO t, for any old t
- tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
- case maybe_thing of
- Just (ATcId main_id) -> check_main_ty (idType main_id)
- other -> addErrTc noMainErr
+tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
+tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
+
+tcCheckMain (Just main_name)
+ = tcLookupId main_name `thenNF_Tc` \ main_id ->
+ -- If it is not Nothing, it should be in the env
+ tcAddSrcLoc (getSrcLoc main_id) $
+ tcAddErrCtxt mainCtxt $
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ ty ->
+ tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) ->
+ zonkTcType ty `thenNF_Tc` \ ty ->
+ ASSERT( is_io_unit ty )
+ let
+ dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
+ in
+ returnTc (VarMonoBind dollar_main_id main_expr, lie)
where
- check_main_ty main_ty
- = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
- tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
- tcAddErrCtxtM (mainTypeCtxt main_ty) $
- if not (null theta) then
- failWithTc empty -- Context has the error message
- else
- unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
-
-mainTypeCtxt main_ty tidy_env
- = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
- returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
- quotes (ppr (tidyType tidy_env main_ty')))
-
-noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
- ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
+ rhs = HsApp (HsVar runMainName) (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
+ other -> False
+
+mainCtxt = ptext SLIT("When checking the type of 'main'")
\end{code}
else return ()
dumpIfSet_dyn dflags Opt_D_dump_tc
- "Typechecked" (ppr (tc_binds results))
+ -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
+ "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
printIfaceDump dflags Nothing = return ()
projects / ghc-hetmet.git / blobdiff