listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ failTc, failWithTc, addErrTc, addErrsTc, warnTc,
+ recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
addErrTcM, addInstErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcGetUnique, tcGetUniques, tcGetDFunUniq,
+ doptsTc, getDOptsTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts ( opt_PprStyle_Debug )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( TyVarSet )
-import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
+ splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import SrcLoc ( SrcLoc )
import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
-import UniqFM ( UniqFM, emptyUFM )
+import UniqFM ( emptyUFM )
import Unique ( Unique )
-import BasicTypes ( Unused )
+import CmdLineOpts
import Outputable
-import FastString ( FastString )
import IOExts ( IORef, newIORef, readIORef, writeIORef,
unsafeInterleaveIO, fixIO
\begin{code}
type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
- -- ToDo: nuke the 's' part
- -- The difference between the two is
- -- now for documentation purposes only
type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
-- Used only in this file for type signatures which
\end{code}
\begin{code}
--- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
-initTc :: UniqSupply
- -> (TcRef (UniqFM a) -> TcEnv)
+initTc :: DynFlags
+ -> TcEnv
+ -> SrcLoc
-> TcM r
- -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
+ -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
-initTc us initenv do_this
+initTc dflags tc_env src_loc do_this
= do {
+ us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
tvs_var <- newIORef emptyUFM ;
let
- init_down = TcDown [] us_var dfun_var
- noSrcLoc
+ init_down = TcDown dflags [] us_var dfun_var
+ src_loc
[] errs_var
- init_env = initenv tvs_var
;
- maybe_res <- catch (do { res <- do_this init_down init_env ;
+ maybe_res <- catch (do { res <- do_this init_down tc_env ;
return (Just res)})
(\_ -> return Nothing) ;
(warns,errs) <- readIORef errs_var ;
- return (maybe_res, warns, errs)
+ return (maybe_res, (warns, errs))
}
-- Monadic operations
\begin{code}
forkNF_Tc :: NF_TcM r -> NF_TcM r
-forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
+forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
tv_var' <- newIORef emptyUFM ;
- let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
+ let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
m down' env
-- ToDo: optionally dump any error messages
})
addErrTc :: Message -> NF_TcM ()
addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc [] = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
+
-- The 'M' variants do the TidyEnv bit
failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
failWithTcM env_and_msg
\begin{code}
data TcDown
- = TcDown
- [Type] -- Types used for defaulting
+ = TcDown {
+ tc_dflags :: DynFlags,
+ tc_def :: [Type], -- Types used for defaulting
- (TcRef UniqSupply) -- Unique supply
- (TcRef DFunNameSupply) -- Name supply for dictionary function names
+ tc_us :: (TcRef UniqSupply), -- Unique supply
+ tc_ds :: (TcRef DFunNameSupply), -- Name supply for
+ -- dictionary function names
- SrcLoc -- Source location
- ErrCtxt -- Error context
- (TcRef (Bag WarnMsg, Bag ErrMsg))
+ tc_loc :: SrcLoc, -- Source location
+ tc_ctxt :: ErrCtxt, -- Error context
+ tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
+ }
type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
-- Innermost first. Monadic so that we have a chance
-- These selectors are *local* to TcMonad.lhs
\begin{code}
-getTcErrs (TcDown def us ds loc ctxt errs) = errs
-setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
+
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
+
+getLoc (TcDown{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
-getDefaultTys (TcDown def us ds loc ctxt errs) = def
-setDefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
+getUniqSupplyVar (TcDown{tc_us=us}) = us
+getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
-getLoc (TcDown def us ds loc ctxt errs) = loc
-setLoc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt errs
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+setErrCtxt down msg = down{tc_ctxt=[msg]}
+addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
-getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
-getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
+doptsTc :: DynFlag -> TcM Bool
+doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
+ = return (dopt dflag dflags)
-setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg] errs
-addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
-getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt
+getDOptsTc :: TcM DynFlags
+getDOptsTc (TcDown{tc_dflags=dflags}) env_down
+ = return dflags
\end{code}
projects / ghc-hetmet.git / blobdiff