+%
+% (c) The University of Glasgow 2006
+%
+
\begin{code}
module TcRnMonad(
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 )
+#if defined(GHCI)
+import TypeRep
+import IdInfo
+import TysWiredIn
+import PrelNames
+import {-#SOURCE#-} TcEnv
#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 ( TcType, tcIsTyVarTy, tcGetTyVar )
-import NameEnv ( extendNameEnvList, nameEnvElts )
-import InstEnv ( emptyInstEnv )
-import FamInstEnv ( emptyFamInstEnv )
-
-import Var ( setTyVarName )
-import Id ( mkSysLocal )
-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, uniqsFromSupply, splitUniqSupply )
-import UniqFM ( unitUFM )
-import Unique ( Unique )
-import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set,
- dopt_unset, GhcMode )
-import StaticFlags ( opt_PprStyle_Debug )
-import FastString ( FastString )
-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}
\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 ;
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,
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,
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
-> 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}
\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}
%************************************************************************
= 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}
%************************************************************************
projects / ghc-hetmet.git / blobdiff