X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=1dd4a4297d581f258ee1727b8b529a3013daf1b3;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=1645d0e358a040d5e297348071f4a6a98e971f97;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1645d0e..1dd4a42 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -7,10 +7,15 @@ #include "HsVersions.h" module TcModule ( - tcModule + typecheckModule, + TcResults(..), + TcResultBinds(..), + TcIfaceInfo(..), + TcSpecialiseRequests(..), + TcDDumpDeriv(..) ) where -import Ubiq +IMP_Ubiq(){-uitous-} import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, TyDecl, SpecDataSig, ClassDecl, InstDecl, @@ -19,9 +24,9 @@ import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, ) import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), - TcIdOcc(..), zonkBinds, zonkInst, zonkId ) + TcIdOcc(..), zonkBinds, zonkDictBinds ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, plusLIE ) import TcBinds ( tcBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) @@ -34,54 +39,81 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) +import TcTyDecls ( mkDataBinds ) import Bag ( listToBag ) -import Class ( GenClass ) -import Id ( GenId, isDataCon, isMethodSelId, idType ) +import Class ( GenClass, classSelIds ) +import ErrUtils ( Warning(..), Error(..) ) +import Id ( idType, isMethodSelId, isTopLevId, GenId, IdEnv(..), nullIdEnv ) import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) -import PrelInfo ( unitTy, mkPrimIoTy ) import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnUtils ( RnEnv(..) ) import TyCon ( TyCon ) import Type ( applyTyCon ) +import TysWiredIn ( unitTy, mkPrimIoTy ) +import TyVar ( TyVarEnv(..), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey ) import Util - import FiniteMap ( emptyFM ) tycon_specs = emptyFM - - \end{code} +Outside-world interface: \begin{code} -tcModule :: GlobalNameMappers -- final renamer info for derivings - -> RenamedHsModule -- input - -> 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 - TypecheckedHsBinds, -- binds from value decls - - [(Id, TypecheckedHsExpr)]), -- constant instance binds - - ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo), - -- things for the interface generator - - ([TyCon], [Class]), - -- environments of info from this module only - - FiniteMap TyCon [(Bool, [Maybe Type])], - -- source tycon specialisation requests +-- Convenient type synonyms first: +type TcResults + = (TcResultBinds, + TcIfaceInfo, + TcSpecialiseRequests, + TcDDumpDeriv) + +type TcResultBinds + = (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 + TypecheckedHsBinds, -- binds from value decls + + [(Id, TypecheckedHsExpr)]) -- constant instance binds + +type TcIfaceInfo -- things for the interface generator + = ([Id], [TyCon], [Class], Bag InstInfo) + +type TcSpecialiseRequests + = FiniteMap TyCon [(Bool, [Maybe Type])] + -- source tycon specialisation requests + +type TcDDumpDeriv + = PprStyle -> Pretty + +--------------- +typecheckModule + :: UniqSupply + -> RnEnv -- for renaming derivings + -> RenamedHsModule + -> MaybeErr + (TcResults, -- if all goes well... + Bag Warning) -- (we can still get warnings) + (Bag Error, -- if we had errors... + Bag Warning) + +typecheckModule us rn_env mod + = initTc us (tcModule rn_env mod) +\end{code} - PprStyle -> Pretty) -- -ddump-deriving info +The internal monster: +\begin{code} +tcModule :: RnEnv -- for renaming derivings + -> RenamedHsModule -- input + -> TcM s TcResults -- output -tcModule renamer_name_funs +tcModule rn_env (HsModule mod_name verion exports imports fixities ty_decls specdata_sigs cls_decls inst_decls specinst_sigs default_decls val_decls sigs src_loc) @@ -100,31 +132,46 @@ tcModule renamer_name_funs -- 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:" $ + --trace "tcTyAndClassDecls:" $ tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag - `thenTc` \ (env, record_binds) -> + `thenTc` \ env -> -- Typecheck the instance decls, includes deriving tcSetEnv env ( - trace "tcInstDecls:" $ + --trace "tcInstDecls:" $ tcInstDecls1 inst_decls_bag specinst_sigs - mod_name renamer_name_funs fixities + mod_name rn_env fixities ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> - returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv) + returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) - ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) -> + ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) -> tcSetEnv env ( -- Default declarations tcDefaults default_decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys ( -- for the iface sigs... + -- Create any necessary record selector Ids and their bindings + -- "Necessary" includes data and newtype declarations + let + tycons = getEnv_TyCons env + classes = getEnv_Classes env + in + mkDataBinds tycons `thenTc` \ (data_ids, data_binds) -> + + -- Extend the global value environment with + -- a) constructors + -- b) record selectors + -- c) class op selectors + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv (concat (map classSelIds classes)) $ + -- Interface type signatures -- We tie a knot so that the Ids read out of interfaces are in scope -- when we read their pragmas. @@ -132,17 +179,18 @@ tcModule renamer_name_funs -- any type errors are found (ie there's an inconsistency) -- we silently discard the pragma tcInterfaceSigs sigs `thenTc` \ sig_ids -> + tcGetEnv `thenNF_Tc` \ env -> - returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) + returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) - )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> + )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> tcSetEnv env ( -- to the end... tcSetDefaultTys defaulting_tys ( -- ditto -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process - trace "tcBinds:" $ + --trace "tcBinds:" $ tcBindsAndThen (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing)) (val_decls `ThenBinds` deriv_binds) @@ -166,37 +214,42 @@ tcModule renamer_name_funs -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) tcSimplifyTop lie_alldecls `thenTc` \ const_insts -> - let - localids = getEnv_LocalIds final_env - tycons = getEnv_TyCons final_env - classes = getEnv_Classes final_env - local_tycons = filter isLocallyDefined tycons - local_classes = filter isLocallyDefined classes - - exported_ids = [v | v <- localids, - isExported v && not (isDataCon v) && not (isMethodSelId v)] - in -- Backsubstitution. Monomorphic top-level decls may have -- been instantiated by subsequent decls, and the final -- 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' -> - mapNF_Tc zonkInst const_insts `thenNF_Tc` \ const_insts' -> - mapNF_Tc (zonkId.TcId) exported_ids `thenNF_Tc` \ exported_ids' -> + -- + -- More horrible still, we have to do it in a careful order, so that + -- all the TcIds are in scope when we come across them. + -- + -- These bindings ought really to be bundled together in a huge + -- recursive group, but HsSyn doesn't have recursion among Binds, only + -- among MonoBinds. Sigh again. + zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) -> + zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) -> + + zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) -> + zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) -> + zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) -> + + let + localids = getEnv_LocalIds final_env + tycons = getEnv_TyCons final_env + classes = getEnv_Classes final_env + local_tycons = filter isLocallyDefined tycons + local_classes = filter isLocallyDefined classes + local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ] + -- the isTopLevId is doubtful... + in -- FINISHED AT LAST returnTc ( - (record_binds', cls_binds', inst_binds', val_binds', const_insts'), + (data_binds', cls_binds', inst_binds', val_binds', const_insts'), -- the next collection is just for mkInterface - (fixities, exported_ids', tycons, classes, inst_info), - - (local_tycons, local_classes), + (local_vals, local_tycons, local_classes, inst_info), tycon_specs, @@ -206,7 +259,6 @@ tcModule renamer_name_funs ty_decls_bag = listToBag ty_decls cls_decls_bag = listToBag cls_decls inst_decls_bag = listToBag inst_decls - \end{code} @@ -254,7 +306,5 @@ mainBothIdErr sty = ppStr "module Main contains definitions for both main and mainPrimIO" mainNoneIdErr sty - = panic "ToDo: sort out mainIdKey" - -- ppStr "module Main does not contain a definition for main (or mainPrimIO)" - + = ppStr "module Main does not contain a definition for main (or mainPrimIO)" \end{code}