X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=07a48aed1706b60fbdfbef8dd2d651eebfc6e97d;hb=1b92395bcb40f110fc3dd6e261692e28e6bbe328;hp=f428853da9b51931c7ced86f980f53e0756fa50f;hpb=ec0b859902e717c24addff49f9a83efb927fb669;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index f428853..07a48ae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -62,15 +62,17 @@ import CoreSyn import ErrUtils import Id import Var +import VarSet import Module import UniqFM import Name +import NameEnv import NameSet import TyCon import SrcLoc import HscTypes +import ListSetOps import Outputable -import Breakpoints #ifdef GHCI import Linker @@ -87,7 +89,6 @@ import TysWiredIn import IdInfo import {- Kind parts of -} Type import BasicTypes -import Data.Maybe #endif import FastString @@ -97,6 +98,8 @@ import Bag import Control.Monad ( unless ) import Data.Maybe ( isJust ) +import Foreign.Ptr ( Ptr ) + \end{code} @@ -169,6 +172,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; + -- Make the new type env available to stuff slurped from interface files + -- Must do this after checkHiBootIface, because the latter might add new + -- bindings for boot_dfuns, which may be mentioned in imported unfoldings + writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- Rename the Haddock documentation tcg_env <- rnHaddock module_info maybe_doc tcg_env ; @@ -313,7 +321,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_deprecs = NoDeprecs, mg_foreign = NoStubs, mg_hpc_info = noHpcInfo, - mg_dbg_sites = noDbgSites + mg_modBreaks = emptyModBreaks } } ; tcCoreDump mod_guts ; @@ -373,9 +381,6 @@ tcRnSrcDecls boot_iface decls tcg_rules = rules', tcg_fords = fords' } } ; - -- Make the new type env available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) final_type_env ; - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) } @@ -502,51 +507,76 @@ checkHiBootIface | otherwise = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ - ppr local_export_set $$ ppr boot_exports)) ; - ; mapM_ check_export (concatMap availNames boot_exports) - ; dfun_binds <- mapM check_inst boot_insts + ppr boot_exports)) ; + + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports + + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, + tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + + -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ "instances in boot files yet...") -- FIXME: Why? The actual comparison is not hard, but what would -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... - ; return (tcg_env { tcg_binds = binds `unionBags` unionManyBags dfun_binds }) } + + ; return tcg_env' } where - check_export name -- Name is exported by the boot iface - | name `elem` dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - | isImplicitTyThing boot_thing = return () + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + + -- Check that the actual module exports the same thing + | not (null missing_names) + = addErrTc (missingBootThing (head missing_names) "exported by") + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing = return () + + -- Check that the actual module also defines the thing, and + -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name - = do { checkTc (name `elemNameSet` local_export_set) - (missingBootThing boot_thing "exported by") - - ; let boot_decl = tyThingToIfaceDecl boot_thing + = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) real_decl = tyThingToIfaceDecl real_thing ; checkTc (checkBootDecl boot_decl real_decl) - (bootMisMatch boot_thing boot_decl real_decl) } + (bootMisMatch real_thing boot_decl real_decl) } -- The easiest way to check compatibility is to convert to -- iface syntax, where we already have good comparison functions | otherwise - = addErrTc (missingBootThing boot_thing "defined in") + = addErrTc (missingBootThing name "defined in") where - boot_thing = lookupTypeEnv boot_type_env name - `orElse` pprPanic "checkHiBootIface" (ppr name) - + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + dfun_names = map getName boot_insts - local_export_set :: NameSet - local_export_set = availsToNameSet local_exports + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + check_inst :: Instance -> TcM (Maybe (Id, Id)) + -- Returns a pair of the boot dfun in terms of the equivalent real dfun check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, idType dfun `tcEqType` boot_inst_ty ] of - [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag } - (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun)) + [] -> do { addErrTc (instMisMatch boot_inst); return Nothing } + (dfun:_) -> return (Just (local_boot_dfun, dfun)) where boot_dfun = instanceDFunId boot_inst boot_inst_ty = idType boot_dfun @@ -701,19 +731,18 @@ tcTopSrcDecls boot_details checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain - = do { ghc_mode <- getGhcMode ; - tcg_env <- getGblEnv ; + = do { tcg_env <- getGblEnv ; dflags <- getDOpts ; let { main_mod = mainModIs dflags ; main_fn = case mainFunIs dflags of { Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; - check_main ghc_mode tcg_env main_mod main_fn + check_main dflags tcg_env main_mod main_fn } -check_main ghc_mode tcg_env main_mod main_fn +check_main dflags tcg_env main_mod main_fn | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> return tcg_env @@ -753,8 +782,8 @@ check_main ghc_mode tcg_env main_mod main_fn where mod = tcg_mod tcg_env - complain_no_main | ghc_mode == Interactive = return () - | otherwise = failWithTc noMainMsg + complain_no_main | ghcLink dflags == LinkInMemory = return () + | otherwise = failWithTc noMainMsg -- In interactive mode, don't worry about the absence of 'main' -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. @@ -795,10 +824,20 @@ setInteractiveContext hsc_env icxt thing_inside in updGblEnv (\env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt, tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $ + + tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $ + -- tcExtendIdEnv does lots: + -- - it extends the local type env (tcl_env) with the given Ids, + -- - it extends the local rdr env (tcl_rdr) with the Names from + -- the given Ids + -- - it adds the free tyvars of the Ids to the tcl_tyvars + -- set. + -- + -- We should have no Ids with the same name in the + -- ic_type_env, otherwise we'll end up with shadowing in the + -- tcl_rdr, and it's random which one will be in scope. do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) ; thing_inside } @@ -846,12 +885,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -- up to have tidy types global_ids = map globaliseAndTidy zonked_ids ; - -- Update the interactive context - rn_env = ic_rn_local_env ictxt ; - type_env = ic_type_env ictxt ; - bound_names = map idName global_ids ; - new_rn_env = extendLocalRdrEnv rn_env bound_names ; {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -870,15 +904,9 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; - filtered_type_env = delListFromNameEnv type_env shadowed ; -------------------------------------------------- -} - new_type_env = extendTypeEnvWithIds type_env global_ids ; - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } + new_ic = extendInteractiveContext ictxt global_ids emptyVarSet ; } ; dumpOptTcRn Opt_D_dump_tc @@ -1109,7 +1137,7 @@ getModuleExports hsc_env mod ic = hsc_IC hsc_env checkMods = ic_toplev_scope ic ++ ic_exports ic in - initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods) + initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) -- Get the export avail info and also load all orphan and family-instance -- modules. Finally, check that the family instances of all modules in the @@ -1167,19 +1195,30 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env a +tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) +tcRnRecoverDataCon hsc_env ptr = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ - do name <- recoverDataCon a + setInteractiveContext hsc_env (hsc_IC hsc_env) $ do + name <- dataConInfoPtrToName ptr tcLookupDataCon name tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ - tcLookupGlobal name + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv -> Name @@ -1203,7 +1242,7 @@ tcRnGetInfo hsc_env name -- in the home package all relevant modules are loaded.) loadUnqualIfaces ictxt - thing <- tcLookupGlobal name + thing <- tcRnLookupName' name fixity <- lookupFixityRn name ispecs <- lookupInsts (icPrintUnqual ictxt) thing return (thing, fixity, ispecs)