import Outputable
import UniqSupply
import Unique
+import LazyUniqFM
import DynFlags
import StaticFlags
import FastString
import System.IO
import Data.IORef
import Control.Exception
+import Control.Monad
\end{code}
%************************************************************************
\begin{code}
-ioToTcRn :: IO r -> TcRn r
-ioToTcRn = ioToIOEnv
-\end{code}
-
-\begin{code}
initTc :: HscEnv
-> HscSource
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
-ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true
+-- | Do it flag is true
+ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () }
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf flag doc = ifOptM flag $
- ioToIOEnv (printForUser stderr alwaysQualify doc)
+ liftIO (printForUser stderr alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
- ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
+ dflags <- getDOpts ;
+ liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
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) }
= 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) }
addErrs :: [(SrcSpan,Message)] -> TcRn ()
-addErrs msgs = mappM_ add msgs
+addErrs msgs = mapM_ add msgs
where
add (loc,msg) = addErrAt loc msg
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) }
checkErr :: Bool -> Message -> TcRn ()
-- Add the error if the bool is False
-checkErr ok msg = checkM ok (addErr msg)
+checkErr ok msg = unless ok (addErr msg)
warnIf :: Bool -> Message -> TcRn ()
warnIf True msg = addWarn msg
= do { mb_res <- try_m thing ;
case mb_res of
Left exn -> recover
- Right res -> returnM res }
+ Right res -> return 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)
= do { (msgs, mb_res) <- tryTcLIE main
; addMessages msgs
; case mb_res of
- Nothing -> failM
+ Nothing -> failM
Just val -> return val
}
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
addErrCtxt :: Message -> TcM a -> TcM a
-addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
; addErrTcM (env0, err_msg) }
addErrsTc :: [Message] -> TcM ()
-addErrsTc err_msgs = mappM_ addErrTc err_msgs
+addErrsTc err_msgs = mapM_ addErrTc err_msgs
addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
= addErrTcM local_and_msg >> failM
checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
-checkTc True err = returnM ()
+checkTc True err = return ()
checkTc False err = failWithTc err
\end{code}
extendLIEs :: [Inst] -> TcM ()
extendLIEs []
- = returnM ()
+ = return ()
extendLIEs insts
= do { lie_var <- getLIEVar ;
lie <- readMutVar lie_var ;
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;
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
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
- ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
+ ; liftIO (printErrs (full_msg defaultErrStyle))
; failM }
--------------------
; return Nothing }
}}
where
- print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle))
+ print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside