X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=f118f47ab523785dca713f1e3f78457a5da264e9;hp=e2cbc226f7a5497e077610ad1dbf29a17b122685;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hpb=0560e796f1d813582e066a5f2bec2684c71df44d diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index e2cbc22..f118f47 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -3,6 +3,13 @@ % \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -23,6 +30,7 @@ import TcType import InstEnv import FamInstEnv +import Coercion import Var import Id import VarSet @@ -36,6 +44,7 @@ import Bag import Outputable import UniqSupply import Unique +import UniqFM import DynFlags import StaticFlags import FastString @@ -84,12 +93,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this | otherwise = Nothing ; gbl_env = TcGblEnv { - tcg_mod = mod, - tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, - tcg_fix_env = emptyNameEnv, - tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_mod = mod, + tcg_src = hsc_src, + tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = Nothing, + 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, @@ -112,7 +122,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc = Nothing, - tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing + tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing, + tcg_hpc = False } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -129,7 +140,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - addBreakpointBindings $ do { r <- tryM do_this ; case r of Right res -> return (Just res) @@ -156,12 +166,6 @@ initTcPrintErrors env mod todo = do return res \end{code} -\begin{code} -addBreakpointBindings :: TcM a -> TcM a -addBreakpointBindings thing_inside - = thing_inside -\end{code} - %************************************************************************ %* * Initialisation @@ -182,7 +186,7 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside ; let { env = Env { env_top = hsc_env, env_us = us_var, env_gbl = gbl_env, - env_lcl = lcl_env } } + env_lcl = lcl_env} } ; runIOEnv env thing_inside } @@ -324,7 +328,7 @@ newUniqueSupply newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) } + ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys @@ -366,7 +370,8 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } + dflags <- getDOpts ; + ioToTcRn (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -403,6 +408,14 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a +extendRecFieldEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> + env {tcg_field_env = old_env `plusNameEnv` new_bit}) + getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} @@ -464,7 +477,8 @@ addLongErrAt loc msg extra = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -480,7 +494,8 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; + dflags <- getDOpts ; + let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } @@ -860,9 +875,11 @@ setLclTypeEnv lcl_env thing_inside recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } -keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set -keepAliveTc n = do { env <- getGblEnv; - ; updMutVar (tcg_keep env) (`addOneToNameSet` n) } +keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set +keepAliveTc id + | isLocalId id = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) } + | otherwise = return () keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set keepAliveSetTc ns = do { env <- getGblEnv; @@ -902,8 +919,8 @@ setLocalRdrEnv rdr_env thing_inside mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_tv_env = emptyUFM, + if_id_env = emptyUFM } initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside @@ -1019,5 +1036,3 @@ forkM doc thing_inside -- pprPanic "forkM" doc Just r -> r) } \end{code} - -