X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=ed1dce663a7a69ec3c69fd3928fec89fd501a701;hb=2eb105009654588b2130997509645841800681b9;hp=33c6aec5748c895348905e29f55271c1cf005dfd;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 33c6aec..ed1dce6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -44,6 +44,7 @@ import Bag import Outputable import UniqSupply import Unique +import UniqFM import DynFlags import StaticFlags import FastString @@ -369,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) @@ -395,6 +397,9 @@ tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } @@ -475,7 +480,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) } @@ -491,7 +497,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) } @@ -557,6 +564,19 @@ recoverM recover thing Left exn -> recover Right res -> returnM res } + +----------------------- +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +-- Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM f [] = return [] +mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) + ; rs <- mapAndRecoverM f xs + ; return (case mb_r of + Left _ -> rs + Right r -> r:rs) } + + ----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) -- (tryTc m) executes m, and returns @@ -871,9 +891,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; @@ -913,8 +935,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