X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=39122d35240606edcaebbe790f073032c8e56a8f;hb=f9120c200bcf613b58d742802172fb4c08171f0d;hp=46668beb8247c1aa205468f45b88743dd71b39b0;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 46668be..39122d3 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -15,7 +15,8 @@ import Ubiq 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 ) @@ -26,7 +27,8 @@ import TcBinds ( tcBindsAndThen ) 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 ) @@ -37,8 +39,7 @@ import Bag ( listToBag ) 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(..) ) @@ -60,7 +61,8 @@ tycon_specs = emptyFM \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 @@ -68,10 +70,10 @@ tcModule :: GlobalNameMappers -- final renamer info for derivings [(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])], @@ -80,7 +82,7 @@ tcModule :: GlobalNameMappers -- final renamer info for derivings 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) @@ -93,17 +95,17 @@ tcModule renamer_name_funs -- 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 ( @@ -114,9 +116,9 @@ tcModule renamer_name_funs 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 @@ -131,9 +133,9 @@ tcModule renamer_name_funs -- 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 @@ -169,10 +171,10 @@ tcModule renamer_name_funs 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 @@ -180,6 +182,7 @@ tcModule renamer_name_funs -- 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' -> @@ -188,7 +191,7 @@ tcModule renamer_name_funs -- 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), @@ -219,27 +222,27 @@ checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type. \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 ()"