X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=006777ac1aafc8390ea9fdc32fbdae31764195a3;hb=dabfa71f33eabc5a2d10959728f772aa016f1c84;hp=f279531d5cf2ba84f22ef162fabe848fa4fe9428;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index f279531..006777a 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -25,7 +25,7 @@ import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, ) import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), - TcIdOcc(..), zonkBinds, zonkInst, zonkId ) + TcIdOcc(..), zonkBinds, zonkDictBinds ) import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, plusLIE ) @@ -40,18 +40,20 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) +import TcTyDecls ( mkDataBinds ) import Bag ( listToBag ) -import Class ( GenClass ) +import Class ( GenClass, classSelIds ) import ErrUtils ( Warning(..), Error(..) ) -import Id ( GenId, isDataCon, isMethodSelId, idType ) +import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv ) import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) -import PrelInfo ( unitTy, mkPrimIoTy ) import Pretty import RnUtils ( RnEnv(..) ) -import TyCon ( TyCon ) +import TyCon ( isDataTyCon, TyCon ) import Type ( mkSynTy ) +import TysWiredIn ( unitTy, mkPrimIoTy ) +import TyVar ( TyVarEnv(..), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) @@ -136,12 +138,12 @@ tcModule rn_env -- 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, record_binds) -> + `thenTc` \ env -> -- Typecheck the instance decls, includes deriving tcSetEnv env ( @@ -152,15 +154,30 @@ tcModule rn_env 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. @@ -168,10 +185,11 @@ tcModule rn_env -- 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 @@ -202,32 +220,39 @@ tcModule rn_env -- 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 = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ] + local_classes = filter isLocallyDefined classes + exported_ids' = filter isExported (eltsUFM ve2) + 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 (exported_ids', tycons, classes, inst_info),