X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=96819e40da0c36ecb636fbd40de55707b1bdc36c;hb=bc0c8f53ac133c5cbf3bdbb7c08946392cad44b5;hp=9d7b16d83e27744d2993122bfb2d772d284030f9;hpb=573ef10b2afd99d3c6a36370a9367609716c97d2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9d7b16d..96819e4 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -4,257 +4,288 @@ \section[TcModule]{Typechecking a whole module} \begin{code} -#include "HsVersions.h" - module TcModule ( typecheckModule, - SYN_IE(TcResults), - SYN_IE(TcResultBinds), - SYN_IE(TcIfaceInfo), - SYN_IE(TcSpecialiseRequests), - SYN_IE(TcDDumpDeriv) + TcResults, + TcDDumpDeriv ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, - TyDecl, SpecDataSig, ClassDecl, InstDecl, - SpecInstSig, DefaultDecl, Sig, Fake, InPat, - FixityDecl, IE, ImportDecl - ) -import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) ) -import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), - TcIdOcc(..), zonkBinds, zonkDictBinds ) +import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv ) +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) +import RnHsSyn ( RenamedHsModule ) +import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds ) -import TcMonad hiding ( rnMtoTcM ) -import Inst ( Inst, plusLIE ) -import TcBinds ( tcBindsAndThen ) +import TcMonad +import Inst ( Inst, emptyLIE, plusLIE ) +import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds, - getEnv_TyCons, getEnv_Classes, - tcLookupLocalValueByKey, tcLookupTyConByKey ) +import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv, + getEnv_TyCons, getEnv_Classes, tcLookupLocalValue, + tcLookupTyCon, initEnv ) +import TcExpr ( tcId ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcInstUtil ( buildInstanceEnvs, InstInfo ) +import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) import TcTyDecls ( mkDataBinds ) +import TcType ( TcType, tcInstType ) +import TcKind ( TcKind, kindToTcKind ) -import Bag ( listToBag ) -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 ( isLocallyDefined ) -import Pretty -import RnUtils ( SYN_IE(RnEnv) ) -import TyCon ( TyCon ) -import Type ( applyTyCon ) -import TysWiredIn ( unitTy, mkPrimIoTy ) -import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv ) +import RnMonad ( RnNameSupply(..) ) +import Bag ( isEmptyBag ) +import ErrUtils ( WarnMsg, ErrMsg, + pprBagOfErrors, dumpIfSet + ) +import Id ( idType, GenId ) +import Name ( Name, isLocallyDefined, pprModule, NamedThing(..) ) +import TyCon ( TyCon, tyConKind ) +import Class ( Class, classSelIds, classTyCon ) +import Type ( mkTyConApp, Type ) +import TyVar ( emptyTyVarEnv ) +import TysWiredIn ( unitTy ) +import PrelMods ( mAIN ) +import PrelInfo ( main_NAME, ioTyCon_NAME ) import Unify ( unifyTauTy ) -import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, - filterUFM, eltsUFM ) -import Unique ( iOTyConKey ) +import Unique ( Unique ) +import UniqSupply ( UniqSupply ) import Util - -import FiniteMap ( emptyFM, FiniteMap ) -tycon_specs = emptyFM +import Bag ( Bag, isEmptyBag ) +import FiniteMap ( FiniteMap ) +import Outputable \end{code} Outside-world interface: \begin{code} + -- Convenient type synonyms first: type TcResults - = (TcResultBinds, - TcIfaceInfo, - TcSpecialiseRequests, + = (TypecheckedMonoBinds, + [TyCon], [Class], + Bag InstInfo, -- Instance declaration information 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 +type TcDDumpDeriv = SDoc --------------- typecheckModule :: UniqSupply - -> RnEnv -- for renaming derivings + -> RnNameSupply -> 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) + -> IO (Maybe TcResults) + +typecheckModule us rn_name_supply mod + = let + (maybe_result, warns, errs) = + initTc us initEnv (tcModule rn_name_supply mod) + in + print_errs warns >> + print_errs errs >> + + dumpIfSet opt_D_dump_tc "Typechecked" + (case maybe_result of + Just (binds, _, _, _, _) -> ppr binds + Nothing -> text "Typecheck failed") >> + + dumpIfSet opt_D_dump_deriv "Derived instances" + (case maybe_result of + Just (_, _, _, _, dump_deriv) -> dump_deriv + Nothing -> empty) >> + + return (if isEmptyBag errs then + maybe_result + else + Nothing) + +print_errs errs + | isEmptyBag errs = return () + | otherwise = printErrs (pprBagOfErrors errs) \end{code} The internal monster: \begin{code} -tcModule :: RnEnv -- for renaming derivings +tcModule :: RnNameSupply -- for renaming derivings -> RenamedHsModule -- input -> TcM s TcResults -- output -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) - - = ASSERT(null imports) +tcModule rn_name_supply + (HsModule mod_name verion exports imports fixities decls src_loc) + = tcAddSrcLoc src_loc $ -- record where we're starting - tcAddSrcLoc src_loc $ -- record where we're starting - - -- Tie the knot for inteface-file value declaration signatures - -- This info is only used inside the knot for type-checking the - -- pragmas, which is done lazily [ie failure just drops the pragma + fixTc (\ ~(unf_env ,_) -> + -- unf_env is used for type-checking interface pragmas + -- which is done lazily [ie failure just drops the pragma -- without having any global-failure effect]. + -- + -- unf_env is also used to get the pragam info for dfuns. + + -- The knot for instance information. This isn't used at all + -- till we type-check value declarations + fixTc ( \ ~(rec_inst_mapper, _, _, _, _) -> + + -- Type-check the type and class decls + -- trace "tcTyAndClassDecls:" $ + tcTyAndClassDecls1 unf_env rec_inst_mapper decls `thenTc` \ env -> + + -- trace "tc3" $ + -- Typecheck the instance decls, includes deriving + tcSetEnv env ( + -- trace "tcInstDecls:" $ + tcInstDecls1 unf_env decls mod_name rn_name_supply + ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> + + -- trace "tc4" $ + buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper -> + + returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) + + -- End of inner fix loop + ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) -> + + -- trace "tc5" $ + tcSetEnv env $ + + -- Default declarations + tcDefaults decls `thenTc` \ defaulting_tys -> + tcSetDefaultTys defaulting_tys $ + + -- Create any necessary record selector Ids and their bindings + -- "Necessary" includes data and newtype declarations + let + tycons = getEnv_TyCons env + classes = getEnv_Classes env + local_tycons = filter isLocallyDefined tycons + local_classes = filter isLocallyDefined classes + in + mkDataBinds tycons `thenTc` \ (data_ids, data_binds) -> + + -- Extend the global value environment with + -- (a) constructors + -- (b) record selectors + -- (c) class op selectors + -- (d) default-method ids + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv (concat (map classSelIds classes)) $ + + -- Extend the TyCon envt with the tycons corresponding to + -- the classes, and the global value environment with the + -- corresponding data cons. + -- They are mentioned in types in interface files. + tcExtendGlobalValEnv (map classDataCon classes) $ + tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon)) + | clas <- classes, + let tycon = classTyCon clas + ] $ - fixTc (\ ~(_, _, _, _, _, _, sig_ids) -> - tcExtendGlobalValEnv sig_ids ( + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + tcInterfaceSigs unf_env decls `thenTc` \ 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, _, _, _, _) -> - -- Type-check the type and class decls - --trace "tcTyAndClassDecls:" $ - tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag - `thenTc` \ env -> + -- Value declarations next. + -- We also typecheck any extra binds that came out of the "deriving" process + -- trace "tcBinds:" $ + tcTopBindsAndThen + (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing)) + (get_val_decls decls `ThenBinds` deriv_binds) + ( tcGetEnv `thenNF_Tc` \ env -> + returnTc ((EmptyMonoBinds, env), emptyLIE) + ) `thenTc` \ ((val_binds, final_env), lie_valdecls) -> + tcSetEnv final_env $ - -- Typecheck the instance decls, includes deriving - tcSetEnv env ( - --trace "tcInstDecls:" $ - tcInstDecls1 inst_decls_bag specinst_sigs - mod_name rn_env fixities - ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> - buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> + -- Second pass over class and instance declarations, + -- to compile the bindings themselves. + -- trace "tc8" $ + tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> + tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> - returnTc (inst_mapper, env, 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... + -- Check that "main" has the right signature + tcCheckMainSig mod_name `thenTc_` - -- Create any necessary record selector Ids and their bindings - -- "Necessary" includes data and newtype declarations + -- 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" $ let - tycons = getEnv_TyCons env - classes = getEnv_Classes env + lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls 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. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - tcInterfaceSigs sigs `thenTc` \ sig_ids -> - tcGetEnv `thenNF_Tc` \ env -> + tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> - returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) - )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> + -- Backsubstitution. This must be done last. + -- Even tcCheckMainSig and tcSimplifyTop may do some unification. + let + all_binds = data_binds `AndMonoBinds` + val_binds `AndMonoBinds` + inst_binds `AndMonoBinds` + cls_binds `AndMonoBinds` + const_inst_binds + in + zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> - tcSetEnv env ( -- to the end... - tcSetDefaultTys defaulting_tys ( -- ditto + returnTc (really_final_env, + (all_binds', local_tycons, local_classes, inst_info, ddump_deriv)) - -- Value declarations next. - -- We also typecheck any extra binds that came out of the "deriving" process - --trace "tcBinds:" $ - tcBindsAndThen - (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing)) - (val_decls `ThenBinds` deriv_binds) - ( -- Second pass over instance declarations, - -- to compile the bindings themselves. - tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> - tcGetEnv `thenNF_Tc` \ env -> - returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)), - lie_instdecls `plusLIE` lie_clasdecls, - () )) - - `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) -> - - -- 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.) - tcSimplifyTop lie_alldecls `thenTc` \ const_insts -> - - -- 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. - -- - -- 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 ( - (data_binds', cls_binds', inst_binds', val_binds', const_insts'), + -- End of outer fix loop + ) `thenTc` \ (final_env, stuff) -> + returnTc stuff - -- the next collection is just for mkInterface - (local_vals, local_tycons, local_classes, inst_info), +get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] +\end{code} - tycon_specs, - ddump_deriv - ))) - where - ty_decls_bag = listToBag ty_decls - cls_decls_bag = listToBag cls_decls - inst_decls_bag = listToBag inst_decls +\begin{code} +tcCheckMainSig mod_name + | mod_name /= mAIN + = returnTc () -- A non-main module + + | otherwise + = -- Check that main is defined + tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) -> + tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id -> + case maybe_main_id of { + Nothing -> failWithTc noMainErr ; + Just main_id -> + + -- Check that it has the right type (or a more general one) + let + expected_ty = mkTyConApp ioTyCon [unitTy] + in + tcInstType emptyTyVarEnv expected_ty `thenNF_Tc` \ expected_tau -> + tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) -> + tcSetErrCtxt mainTyCheckCtxt $ + unifyTauTy expected_tau + main_tau `thenTc_` + checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id)) + } + + +mainTyCheckCtxt + = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")] + +noMainErr + = hsep [ptext SLIT("Module"), quotes (pprModule mAIN), + ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] + +mainTyMisMatch :: Type -> TcType s -> ErrMsg +mainTyMisMatch expected actual + = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")]) + 4 (vcat [ + hsep [ptext SLIT("Expected:"), ppr expected], + hsep [ptext SLIT("Inferred:"), ppr actual] + ]) \end{code}