X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=02b586a16d8eceaae2cefabab90d6bf256b4a809;hb=f4c9d2b23bd63b48566e0ca3b13c8bdfc4cd0c0b;hp=52ac93b5f126d4d65f83bf562002afb968c917ca;hpb=4e3255388e8b99ccdae290bfcb6cd666b8c93d4a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 52ac93b..02b586a 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -33,7 +33,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType, isUnLiftedType ) +import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) import TcBinds ( tcTopBinds ) import TcDefaults ( tcDefaults ) @@ -41,36 +41,39 @@ import TcEnv ( tcExtendGlobalValEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings, loadImportedInsts ) +import TcIface ( tcExtCoreBindings ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules ) +import LoadIface ( loadOrphanModules, loadHiBootInterface ) +import IfaceEnv ( lookupOrig ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) import CoreSyn ( IdCoreRule, bindersOfBinds ) +import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc ) +import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet -import TyCon ( tyConHasGenerics ) -import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc ) +import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) +import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ), - GhciMode(..), isOneShot, Dependencies(..), noDependencies, - Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), TypeEnv, +import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), + GhciMode(..), noDependencies, isOneShot, + Deprecs( NoDeprecs ), ModIface(..), plusDeprecs, + ForeignStubs(NoStubs), TyThing(..), + TypeEnv, lookupTypeEnv, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - emptyFixityEnv + emptyFixityEnv, availName ) #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), - LStmt, LHsExpr, LHsType, + LStmt, LHsExpr, LHsType, mkMatchGroup, collectStmtsBinders, mkSimpleMatch, placeHolderType, nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), @@ -80,10 +83,13 @@ import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) import TcExpr ( tcCheckRho ) +import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType ) +import TcUnify ( unifyTyConApp ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, + isUnLiftedType, tyClsNamesOfDFunHead ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) import Inst ( tcStdSyntaxName, tcGetInstEnvs ) @@ -96,7 +102,6 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), tyThingToIfaceDecl, dfunToIfaceInst ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, globalIdDetails ) -import FieldLabel ( fieldLabelTyCon ) import MkId ( unsafeCoerceId ) import DataCon ( dataConTyCon ) import TyCon ( tyConName ) @@ -111,16 +116,17 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, retu import Module ( ModuleName, lookupModuleEnvByName ) import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), HomeModInfo(..), typeEnvElts, typeEnvClasses, - TyThing(..), availName, availNames, icPrintUnqual, - ModIface(..), ModDetails(..) ) + availNames, icPrintUnqual, + ModDetails(..), Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Bag ( unitBag ) import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) +import SrcLoc ( SrcLoc ) #endif import FastString ( mkFastString ) -import Util ( sortLt ) +import Util ( sortLe ) import Bag ( unionBags, snocBag ) import Maybe ( isJust ) @@ -151,13 +157,14 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports -- The normal case initTc hsc_env this_mod $ - addSrcSpan loc $ + setSrcSpan loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; - -- In one-shot mode, record boot-file info in the EPS - ifM (isOneShot (hsc_mode hsc_env)) $ - updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ; + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ; -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, @@ -261,7 +268,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ; + tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ; -- Make the new type env available to stuff slurped from interface files setGblEnv tcg_env $ do { @@ -318,8 +325,10 @@ tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls - = do { -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ; + = do { boot_names <- loadHiBootInterface ; + + -- Do all the declarations + (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -345,6 +354,9 @@ tcRnSrcDecls decls let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; + -- Compre the hi-boot iface (if any) with the real thing + checkHiBootIface final_type_env boot_names ; + -- Make the new type env available to stuff slurped from interface files writeMutVar (tcg_type_env_var tcg_env) final_type_env ; @@ -352,15 +364,15 @@ tcRnSrcDecls decls tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) } -tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module -tc_rn_src_decls ds +tc_rn_src_decls boot_names ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ; + tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -391,11 +403,82 @@ tc_rn_src_decls ds -- Glue them on the front of the remaining decls and loop setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls (spliced_decls ++ rest_ds) + tc_rn_src_decls boot_names (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} +%************************************************************************ +%* * + Comparing the hi-boot interface with the real thing +%* * +%************************************************************************ + +In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded +into the External Package Table. Once we've typechecked the body of the +module, we want to compare what we've found (gathered in a TypeEnv) with +the hi-boot stuff in the EPT. We do so here, using the export list of +the hi-boot interface as our checklist. + +\begin{code} +checkHiBootIface :: TypeEnv -> [Name] -> TcM () +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. +checkHiBootIface env boot_names + = mapM_ (check_one env) boot_names + +---------------- +check_one local_env name + = do { eps <- getEps + + -- Look up the hi-boot one; + -- it should jolly well be there (else GHC bug) + ; case lookupTypeEnv (eps_PTE eps) name of { + Nothing -> pprPanic "checkHiBootIface" (ppr name) ; + Just boot_thing -> + + -- Look it up in the local type env + -- It should be there, but it's a programmer error if not + case lookupTypeEnv local_env name of + Nothing -> addErrTc (missingBootThing boot_thing) + Just real_thing -> check_thing boot_thing real_thing + } } + +---------------- +check_thing (ATyCon boot_tc) (ATyCon real_tc) + | isSynTyCon boot_tc && isSynTyCon real_tc, + defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2 + = return () + + | tyConKind boot_tc == tyConKind real_tc + = return () + where + (tvs1, defn1) = getSynTyConDefn boot_tc + (tvs2, defn2) = getSynTyConDefn boot_tc + +check_thing (AnId boot_id) (AnId real_id) + | idType boot_id `tcEqType` idType real_id + = return () + +check_thing (ADataCon dc1) (ADataCon dc2) + | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2) + = return () + + -- Can't declare a class in a hi-boot file + +check_thing boot_thing real_thing -- Default case; failure + = addErrAt (srcLocSpan (getSrcLoc real_thing)) + (bootMisMatch real_thing) + +---------------- +missingBootThing thing + = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module") +bootMisMatch thing + = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file") +\end{code} + %************************************************************************ %* * @@ -415,15 +498,15 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) +tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup decls +tcRnGroup boot_names decls = do { -- Rename the declarations (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tcTopSrcDecls rn_decls + tcTopSrcDecls boot_names rn_decls }} ------------------------------------------------ @@ -449,8 +532,8 @@ rnTopSrcDecls group }} ------------------------------------------------ -tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls +tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls boot_names (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -461,7 +544,7 @@ tcTopSrcDecls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ; + tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ; -- tcTyAndClassDecls recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade @@ -572,7 +655,7 @@ check_main ghci_mode tcg_env main_mod main_fn { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runIO main - ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs ; let { root_main_id = mkExportedLocalId rootMainName ty ; @@ -706,7 +789,7 @@ tcUserStmt (L _ (ExprStmt expr _)) let fresh_it = itName uniq the_bind = noLoc $ FunBind (noLoc fresh_it) False - [ mkSimpleMatch [] expr placeHolderType ] + (mkMatchGroup [mkSimpleMatch [] expr]) in tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; @@ -731,12 +814,14 @@ tc_stmts stmts names = map unLoc (collectStmtsBinders stmts) ; stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = check_rhs, + sc_rhs = infer_rhs, sc_body = check_body, sc_ty = ret_ty } ; - check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; - check_body body = tcCheckRho body io_ret_ty ; + infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs + ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty + ; return (rhs', pat_ty) } ; + check_body body = tcCheckRho body io_ret_ty ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -828,7 +913,7 @@ tcRnExpr hsc_env ictxt rdr_expr smpl_doc = ptext SLIT("main expression") \end{code} -tcRnExpr just finds the kind of a type +tcRnType just finds the kind of a type \begin{code} tcRnType :: HscEnv @@ -927,16 +1012,16 @@ getModuleContents hsc_env ictxt mod exports_only --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) - = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons}) + = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) } filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) | keep_con occs con = decl | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? filter_decl occs decl = decl -keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs -keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs +keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs +keep_con occs con = ifConOcc con `elem` occs availOccs avail = map nameOccName (availNames avail) @@ -1048,9 +1133,9 @@ toIfaceDecl thing -- munge transforms a thing to it's "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) munge (AnId id) = case globalIdDetails id of - RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) - ClassOpId cls -> AClass cls - other -> AnId id + RecordSelId tc lbl -> ATyCon tc + ClassOpId cls -> AClass cls + other -> AnId id munge other_thing = other_thing #endif /* GHCI */ @@ -1135,9 +1220,9 @@ ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids) ppr_sigs :: [Var] -> SDoc ppr_sigs ids -- Print type signatures; sort by OccName - = vcat (map ppr_sig (sortLt lt_sig ids)) + = vcat (map ppr_sig (sortLe le_sig ids)) where - lt_sig id1 id2 = getOccName id1 < getOccName id2 + le_sig id1 id2 = getOccName id1 <= getOccName id2 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) ppr_rules :: [IdCoreRule] -> SDoc