X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=113c82e0fd656a74916b108fc0acfc10d23d0b9c;hp=9f2df4d2df410bcecb7ed08af559dc23890dbd8a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=4250d64191132fd493985549eda5ca05b82a663f diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9f2df4d..113c82e 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -7,21 +7,26 @@ #include "HsVersions.h" module TcModule ( - tcModule + typecheckModule, + SYN_IE(TcResults), + SYN_IE(TcResultBinds), + SYN_IE(TcIfaceInfo), + SYN_IE(TcSpecialiseRequests), + SYN_IE(TcDDumpDeriv) ) where -import Ubiq +IMP_Ubiq(){-uitous-} import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, TyDecl, SpecDataSig, ClassDecl, InstDecl, SpecInstSig, DefaultDecl, Sig, Fake, InPat, FixityDecl, IE, ImportDecl ) -import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) -import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), - TcIdOcc(..), zonkBinds, zonkInst, zonkId ) +import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) ) +import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), + TcIdOcc(..), zonkBinds, zonkDictBinds ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, plusLIE ) import TcBinds ( tcBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) @@ -29,57 +34,85 @@ import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, tcLookupLocalValueByKey, tcLookupTyConByKey ) +import SpecEnv ( SpecEnv ) import TcIfaceSig ( tcInterfaceSigs ) 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 ( SYN_IE(Warning), SYN_IE(Error) ) +import Id ( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv ) import Maybes ( catMaybes ) -import Name ( isExported, isLocallyDefined ) -import PrelInfo ( unitTy, mkPrimIoTy ) +import Name ( isLocallyDefined ) import Pretty -import RnUtils ( RnEnv(..) ) +import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( TyCon ) -import Type ( mkSynTy ) +import Type ( applyTyCon ) +import TysWiredIn ( unitTy, mkPrimIoTy ) +import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) -import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey ) +import Unique ( iOTyConKey ) import Util - -import FiniteMap ( emptyFM ) +import FiniteMap ( emptyFM, FiniteMap ) tycon_specs = emptyFM - - \end{code} +Outside-world interface: \begin{code} -tcModule :: RnEnv -- for renaming 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 rn_env (HsModule mod_name verion exports imports fixities @@ -95,18 +128,23 @@ tcModule rn_env -- pragmas, which is done lazily [ie failure just drops the pragma -- without having any global-failure effect]. + -- trace "tc1" $ + fixTc (\ ~(_, _, _, _, _, _, sig_ids) -> + + -- trace "tc2" $ 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, record_binds) -> + `thenTc` \ env -> + --trace "tc3" $ -- Typecheck the instance decls, includes deriving tcSetEnv env ( --trace "tcInstDecls:" $ @@ -114,17 +152,35 @@ tcModule rn_env mod_name rn_env fixities ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> + --trace "tc4" $ 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, inst_info, deriv_binds, ddump_deriv) -> - ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) -> + --trace "tc5" $ 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,11 +188,14 @@ 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 -> + --trace "tc6" $ - 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, _) -> + --trace "tc7" $ tcSetEnv env ( -- to the end... tcSetDefaultTys defaulting_tys ( -- ditto @@ -148,6 +207,7 @@ tcModule rn_env (val_decls `ThenBinds` deriv_binds) ( -- Second pass over instance declarations, -- to compile the bindings themselves. + --trace "tc8" $ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> tcGetEnv `thenNF_Tc` \ env -> @@ -157,46 +217,50 @@ tcModule rn_env `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) -> - checkTopLevelIds mod_name final_env `thenTc_` - -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a -- top-level decl falls under the monomorphism -- restriction, and no subsequent decl instantiates its -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) + --trace "tc9" $ 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,53 +270,4 @@ tcModule rn_env ty_decls_bag = listToBag ty_decls cls_decls_bag = listToBag cls_decls inst_decls_bag = listToBag inst_decls - -\end{code} - - -%************************************************************************ -%* * -\subsection{Error checking code} -%* * -%************************************************************************ - - -checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type. - -\begin{code} -checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s () -checkTopLevelIds mod final_env - | 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 (mkSynTy io_tc [unitTy]) - (idType main) - - (Nothing, Just prim) -> tcAddErrCtxt primCtxt $ - unifyTauTy (mkPrimIoTy unitTy) - (idType prim) - - (Just _ , Just _ ) -> failTc mainBothIdErr - (Nothing, Nothing) -> failTc mainNoneIdErr - ) - -mainCtxt sty - = ppStr "main should have type IO ()" - -primCtxt sty - = ppStr "mainPrimIO should have type PrimIO ()" - -mainBothIdErr sty - = ppStr "module Main contains definitions for both main and mainPrimIO" - -mainNoneIdErr sty - = ppStr "module Main does not contain a definition for main (or mainPrimIO)" \end{code}