+%
+% (c) The University of Glasgow 2006
+%
+
\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,
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 Coercion
+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 LazyUniqFM
+import DynFlags
+import StaticFlags
+import FastString
+import Panic
+import Util
-import IO ( stderr )
-import DATA_IOREF ( newIORef, readIORef )
-import EXCEPTION ( Exception )
+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
+ -> 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_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,
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,
+ tcg_hpc = False
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
-- 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)
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}
-
%************************************************************************
%* *
Initialisation
; 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
}
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 () }
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) (getSrcSpan name)) }
+
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+ = do { us <- newUniqueSupply
+ ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
\end{code}
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) }
= 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) }
+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}
%************************************************************************
= 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}
\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)) }
+ addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
\begin{code}
debugTc :: TcM () -> TcM ()
-#ifdef DEBUG
-debugTc thing = thing
-#else
-debugTc thing = return ()
-#endif
+debugTc thing
+ | debugIsOn = thing
+ | otherwise = return ()
\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
-- pprPanic "forkM" doc
Just r -> r) }
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff