import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
TyDecl, SpecDataSig, ClassDecl, InstDecl,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
- FixityDecl, IE, ImportedInterface )
+ FixityDecl, IE, ImportDecl
+ )
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TcIdOcc(..), zonkBinds, zonkInst, zonkId )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
- getEnv_TyCons, getEnv_Classes)
+ getEnv_TyCons, getEnv_Classes,
+ tcLookupLocalValueByKey, tcLookupTyConByKey )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, InstInfo )
import Class ( GenClass )
import Id ( GenId, isDataCon, isMethodSelId, idType )
import Maybes ( catMaybes )
-import Name ( Name(..) )
-import Outputable ( isExported )
+import Outputable ( isExported, isLocallyDefined )
import PrelInfo ( unitTy, mkPrimIoTy )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
\begin{code}
tcModule :: GlobalNameMappers -- final renamer info for derivings
-> RenamedHsModule -- input
- -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
+ -> TcM s ((TypecheckedHsBinds, -- record selector binds
+ TypecheckedHsBinds, -- binds from class decls; does NOT
-- include default-methods bindings
TypecheckedHsBinds, -- binds from instance decls; INCLUDES
-- class default-methods binds
[(Id, TypecheckedHsExpr)]), -- constant instance binds
- ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+ ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
-- things for the interface generator
- (UniqFM TyCon, UniqFM Class),
+ ([TyCon], [Class]),
-- environments of info from this module only
FiniteMap TyCon [(Bool, [Maybe Type])],
PprStyle -> Pretty) -- -ddump-deriving info
tcModule renamer_name_funs
- (HsModule mod_name exports imports fixities
+ (HsModule mod_name verion exports imports fixities
ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
default_decls val_decls sigs src_loc)
-- pragmas, which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
- fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+ fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
tcExtendGlobalValEnv sig_ids (
-- The knot for instance information. This isn't used at all
-- till we type-check value declarations
- fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+ fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) ->
-- Type-check the type and class decls
trace "tcTyAndClassDecls:" $
tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
- `thenTc` \ env ->
+ `thenTc` \ (env, record_binds) ->
-- Typecheck the instance decls, includes deriving
tcSetEnv env (
buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
- returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+ returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv)
- ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+ ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) ->
tcSetEnv env (
-- Default declarations
-- we silently discard the pragma
tcInterfaceSigs sigs `thenTc` \ sig_ids ->
- returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+ returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
- )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+ )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
tcSetEnv env ( -- to the end...
tcSetDefaultTys defaulting_tys ( -- ditto
tycons = getEnv_TyCons final_env
classes = getEnv_Classes final_env
- local_tycons = filterUFM isLocallyDefined tycons
- local_classes = filterUFM isLocallyDefined classes
+ local_tycons = filter isLocallyDefined tycons
+ local_classes = filter isLocallyDefined classes
- exported_ids = [v | v <- eltsUFM localids,
+ exported_ids = [v | v <- localids,
isExported v && not (isDataCon v) && not (isMethodSelId v)]
in
-- Backsubstitution. Monomorphic top-level decls may have
-- simplification step may have instantiated some
-- ambiguous types. So, sadly, we need to back-substitute
-- over the whole bunch of bindings.
+ zonkBinds record_binds `thenNF_Tc` \ record_binds' ->
zonkBinds val_binds `thenNF_Tc` \ val_binds' ->
zonkBinds inst_binds `thenNF_Tc` \ inst_binds' ->
zonkBinds cls_binds `thenNF_Tc` \ cls_binds' ->
-- FINISHED AT LAST
returnTc (
- (cls_binds', inst_binds', val_binds', const_insts'),
+ (record_binds', cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
(fixities, exported_ids', tycons, classes, inst_info),
\begin{code}
checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
checkTopLevelIds mod final_env
- = if (mod /= SLIT("Main")) then
- returnTc ()
- else
- case (lookupUFM_Directly localids mainIdKey,
- lookupUFM_Directly localids mainPrimIOIdKey) of
+ | mod /= SLIT("Main")
+ = returnTc ()
+
+ | otherwise
+ = tcSetEnv final_env (
+ tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
+ tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
+ tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
+
+ case (maybe_main, maybe_prim) of
(Just main, Nothing) -> tcAddErrCtxt mainCtxt $
- unifyTauTy ty_main (idType main)
+ unifyTauTy (applyTyCon io_tc [unitTy])
+ (idType main)
+
(Nothing, Just prim) -> tcAddErrCtxt primCtxt $
- unifyTauTy ty_prim (idType prim)
+ unifyTauTy (mkPrimIoTy unitTy)
+ (idType prim)
+
(Just _ , Just _ ) -> failTc mainBothIdErr
(Nothing, Nothing) -> failTc mainNoneIdErr
- where
- localids = getEnv_LocalIds final_env
- tycons = getEnv_TyCons final_env
-
- io_tc = lookupWithDefaultUFM_Directly tycons io_panic iOTyConKey
- io_panic = panic "TcModule: type IO not in scope"
-
- ty_main = applyTyCon io_tc [unitTy]
- ty_prim = mkPrimIoTy unitTy
-
+ )
mainCtxt sty
= ppStr "main should have type IO ()"
projects / ghc-hetmet.git / blobdiff