X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=f0303c11412b58e1954f56f5a54699719728a778;hp=abe87451049cbdfef34932679b8ac1460faaa82d;hb=bb7d80b3b8d1396d481d3b24302bee24a3d92f71;hpb=839f2da8e4c353294e0b7bf0124334532a920f5c diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index abe8745..f0303c1 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1,3 +1,7 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} module TcRnMonad( module TcRnMonad, @@ -10,56 +14,36 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all -#if defined(GHCI) && defined(BREAKPOINT) -import TypeRep ( Type(..), liftedTypeKind ) -import Var ( mkTyVar, mkGlobalId ) -import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) -import OccName ( mkOccName, tvName ) -import SrcLoc ( noSrcLoc ) -import TysWiredIn ( intTy, stringTy, mkListTy, unitTy, boolTy ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName ) -import NameEnv ( mkNameEnv ) -import TcEnv ( tcExtendIdEnv ) -#endif - -import HsSyn ( emptyLHsBinds ) -import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, - ExternalPackageState(..), HomePackageTable, - Deprecs(..), FixityEnv, FixItem, - mkPrintUnqualified ) -import Module ( Module, moduleName ) -import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) -import Type ( Type ) -import TcType ( tcIsTyVarTy, tcGetTyVar ) -import NameEnv ( extendNameEnvList, nameEnvElts ) -import InstEnv ( emptyInstEnv ) - -import Var ( setTyVarName ) -import VarSet ( emptyVarSet ) -import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv ) -import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkWarnMsg, printErrorsAndWarnings, - mkLocMessage, mkLongErrMsg ) -import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) -import NameEnv ( emptyNameEnv ) -import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) -import OccName ( emptyOccEnv, tidyOccName ) -import Bag ( emptyBag ) +import HsSyn hiding (LIE) +import HscTypes +import Module +import RdrName +import Name +import TcType +import InstEnv +import FamInstEnv + +import Var +import Id +import VarSet +import VarEnv +import ErrUtils +import SrcLoc +import NameEnv +import NameSet +import OccName +import Bag import Outputable -import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) -import UniqFM ( unitUFM ) -import Unique ( Unique ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, - dopt_unset, GhcMode ) -import StaticFlags ( opt_PprStyle_Debug ) -import Bag ( snocBag, unionBags ) -import Panic ( showException ) +import UniqSupply +import Unique +import DynFlags +import StaticFlags +import FastString +import Panic -import IO ( stderr ) -import DATA_IOREF ( newIORef, readIORef ) -import EXCEPTION ( Exception ) +import System.IO +import Data.IORef +import Control.Exception \end{code} @@ -76,15 +60,17 @@ ioToTcRn = ioToIOEnv \end{code} \begin{code} + initTc :: HscEnv -> HscSource + -> Bool -- True <=> retain renamed syntax trees -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env hsc_src mod do_this +initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; @@ -93,6 +79,10 @@ initTc hsc_env hsc_src mod do_this th_var <- newIORef False ; dfun_n_var <- newIORef 1 ; let { + maybe_rn_syntax empty_val + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, @@ -102,21 +92,27 @@ initTc hsc_env hsc_src mod do_this tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, - tcg_exports = emptyNameSet, - tcg_imports = init_imports, + tcg_exports = [], + tcg_imports = emptyImportAvails, tcg_dus = emptyDUs, - tcg_rn_imports = Nothing, - tcg_rn_exports = Nothing, - tcg_rn_decls = Nothing, + + tcg_rn_imports = maybe_rn_syntax [], + tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], + tcg_fam_insts= [], tcg_rules = [], tcg_fords = [], tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var + tcg_keep = keep_var, + tcg_doc = Nothing, + tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -148,13 +144,6 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } - where - init_imports = emptyImportAvails {imp_env = - unitUFM (moduleName mod) emptyNameSet} - -- Initialise tcg_imports with an empty set of bindings for - -- this module, so that if we see 'module M' in the export - -- list, and there are no bindings in M, we don't bleat - -- "unknown module M". initTcPrintErrors -- Used from the interactive loop only :: HscEnv @@ -162,7 +151,7 @@ initTcPrintErrors -- Used from the interactive loop only -> TcM r -> IO (Maybe r) initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile mod todo + (msgs, res) <- initTc env HsSrcFile False mod todo printErrorsAndWarnings (hsc_dflags env) msgs return res \end{code} @@ -170,28 +159,7 @@ initTcPrintErrors env mod todo = do \begin{code} addBreakpointBindings :: TcM a -> TcM a addBreakpointBindings thing_inside -#if defined(GHCI) && defined(BREAKPOINT) - = do { unique <- newUnique - ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; - tyvar = mkTyVar var liftedTypeKind; - basicType extra = (FunTy intTy - (FunTy (mkListTy unitTy) - (FunTy stringTy - (ForAllTy tyvar - (extra - (FunTy (TyVarTy tyvar) - (TyVarTy tyvar))))))); - breakpointJumpId - = mkGlobalId VanillaGlobal breakpointJumpName - (basicType id) vanillaIdInfo; - breakpointCondJumpId - = mkGlobalId VanillaGlobal breakpointCondJumpName - (basicType (FunTy boolTy)) vanillaIdInfo - } - ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside} -#else = thing_inside -#endif \end{code} %************************************************************************ @@ -355,8 +323,13 @@ newUniqueSupply newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name)) + = do { uniq <- newUnique + ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } \end{code} @@ -430,8 +403,8 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getDefaultTys :: TcRn (Maybe [Type]) -getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } +getDeclaredDefaultTys :: TcRn (Maybe [Type]) +getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} %************************************************************************ @@ -752,9 +725,12 @@ checkTc False err = failWithTc err \begin{code} addWarnTc :: Message -> TcM () -addWarnTc msg +addWarnTc msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM (env0, msg) } + +addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; - env0 <- tcInitTidyEnv ; ctxt_msgs <- do_ctxt env0 ctxt ; addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }