X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=c86b081a2147bc50a213f248b00af27671ac431b;hp=1f02518cd69f96af0c25c8355440a7e2f2afc0b0;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=0e332efa316f51451e9dd1809eaeba873a4076e4 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 1f02518..c86b081 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -9,6 +9,8 @@ module TcRnMonad( module IOEnv ) where +#include "HsVersions.h" + import TcRnTypes -- Re-export all import IOEnv -- Re-export all @@ -20,6 +22,7 @@ import Name import TcType import InstEnv import FamInstEnv +import PrelNames ( iNTERACTIVE ) import Var import Id @@ -29,21 +32,20 @@ import ErrUtils import SrcLoc import NameEnv import NameSet -import OccName import Bag import Outputable import UniqSupply import Unique -import LazyUniqFM +import UniqFM import DynFlags import StaticFlags import FastString import Panic import Util -import Exception import System.IO import Data.IORef +import qualified Data.Set as Set import Control.Monad \end{code} @@ -68,51 +70,59 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; + meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; - dfuns_var <- newIORef emptyNameSet ; - keep_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; + used_rdr_var <- newIORef Set.empty ; th_var <- newIORef False ; - dfun_n_var <- newIORef 1 ; + lie_var <- newIORef emptyWC ; + dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ; Nothing -> newIORef emptyNameEnv } ; let { - maybe_rn_syntax empty_val + maybe_rn_syntax :: forall a. a -> Maybe a ; + 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_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, + tcg_field_env = RecFields emptyNameEnv emptyNameSet, tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_type_env = emptyNameEnv, 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_th_used = th_var, tcg_exports = [], tcg_imports = emptyImportAvails, + tcg_used_rdrnames = used_rdr_var, tcg_dus = emptyDUs, - tcg_rn_imports = maybe_rn_syntax [], + tcg_rn_imports = [], tcg_rn_exports = maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_binds = emptyLHsBinds, - tcg_warns = NoWarnings, - tcg_insts = [], - tcg_fam_insts= [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc = Nothing, - tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing, - tcg_hpc = False + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -123,7 +133,10 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE + tcl_lie = lie_var, + tcl_meta = meta_var, + tcl_untch = initTyVarUnique, + tcl_hetMetLevel = [] } ; } ; @@ -134,6 +147,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this Right res -> return (Just res) Left _ -> return Nothing } ; + -- Check for unsolved constraints + lie <- readIORef lie_var ; + if isEmptyWC lie + then return () + else pprPanic "initTc: unsolved constraints" + (pprWantedsWithLocs lie) ; + -- Collect any error messages msgs <- readIORef errs_var ; @@ -148,11 +168,9 @@ initTcPrintErrors -- Used from the interactive loop only :: HscEnv -> Module -> TcM r - -> IO (Maybe r) -initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile False mod todo - printErrorsAndWarnings (hsc_dflags env) msgs - return res + -> IO (Messages, Maybe r) + +initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo \end{code} %************************************************************************ @@ -225,20 +243,29 @@ Command-line flags getDOpts :: TcRnIf gbl lcl DynFlags getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } +xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool +xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } + doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +-- XXX setOptM and unsetOptM operate on different types. One should be renamed. + +setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} ) + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) -- | Do it flag is true -ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -ifOptM flag thing_inside = do { b <- doptM flag; +ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifDOptM flag thing_inside = do { b <- doptM flag; + if b then thing_inside else return () } + +ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } getGhcMode :: TcRnIf gbl lcl GhcMode @@ -252,29 +279,28 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } getEps :: TcRnIf gbl lcl ExternalPackageState getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } --- Updating the EPS. This should be an atomic operation. --- Note the delicate 'seq' which forces the EPS before putting it in the --- variable. Otherwise what happens is that we get --- write eps_var (....(unsafeRead eps_var)....) --- and if the .... is strict, that's obviously bottom. By forcing it beforehand --- we make the unsafeRead happen before we update the variable. - +-- | Update the external package state. Returns the second result of the +-- modifier function. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) -> TcRnIf gbl lcl a -updateEps upd_fn = do { traceIf (text "updating EPS") - ; eps_var <- getEpsVar - ; eps <- readMutVar eps_var - ; let { (eps', val) = upd_fn eps } - ; seq eps' (writeMutVar eps_var eps') - ; return val } +updateEps upd_fn = do + traceIf (text "updating EPS") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var upd_fn +-- | Update the external package state. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. updateEps_ :: (ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl () -updateEps_ upd_fn = do { traceIf (text "updating EPS_") - ; eps_var <- getEpsVar - ; eps <- readMutVar eps_var - ; let { eps' = upd_fn eps } - ; seq eps' (writeMutVar eps_var eps') } +updateEps_ upd_fn = do + traceIf (text "updating EPS_") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } @@ -291,14 +317,24 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) %************************************************************************ \begin{code} +newMetaUnique :: TcM Unique +-- The uniques for TcMetaTyVars are allocated specially +-- in guaranteed linear order, starting at zero for each module +newMetaUnique + = do { env <- getLclEnv + ; let meta_var = tcl_meta env + ; uniq <- readMutVar meta_var + ; writeMutVar meta_var (incrUnique uniq) + ; return uniq } + newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; - case splitUniqSupply us of { (us1,_) -> do { - writeMutVar u_var us1 ; - return $! uniqFromSupply us }}} + let { u_var = env_us env } ; + us <- readMutVar u_var ; + case takeUniqFromSupply us of { (uniq, us') -> do { + writeMutVar u_var us' ; + return $! uniq }}} -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving -- a chain of unevaluated supplies behind. -- NOTE 2: we use the uniq in the supply from the MutVar directly, and @@ -309,11 +345,11 @@ newUnique newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; case splitUniqSupply us of { (us1,us2) -> do { - writeMutVar u_var us1 ; - return us2 }}} + writeMutVar u_var us1 ; + return us2 }}} newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone @@ -338,41 +374,69 @@ instance MonadUnique (IOEnv (Env gbl lcl)) where %************************************************************************ \begin{code} -traceTc, traceRn, traceSplice :: SDoc -> TcRn () +newTcRef :: a -> TcRnIf gbl lcl (TcRef a) +newTcRef = newMutVar + +readTcRef :: TcRef a -> TcRnIf gbl lcl a +readTcRef = readMutVar + +writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () +writeTcRef = writeMutVar + +updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () +updTcRef = updMutVar +\end{code} + +%************************************************************************ +%* * + Debugging +%* * +%************************************************************************ + +\begin{code} +traceTc :: String -> SDoc -> TcRn () +traceTc = traceTcN 1 + +traceTcN :: Int -> String -> SDoc -> TcRn () +traceTcN level herald doc + | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $ + hang (text herald) 2 doc + | otherwise = return () + +traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace -traceTc = traceOptTcRn Opt_D_dump_tc_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -traceOptIf flag doc = ifOptM flag $ +traceOptIf flag doc = ifDOptM flag $ liftIO (printForUser stderr alwaysQualify doc) traceOptTcRn :: DynFlag -> SDoc -> TcRn () -traceOptTcRn flag doc = ifOptM flag $ do - { ctxt <- getErrCtxt - ; loc <- getSrcSpanM - ; env0 <- tcInitTidyEnv - ; ctxt_msgs <- do_ctxt env0 ctxt - ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs)) +-- Output the message, with current location if opt_PprStyle_Debug +traceOptTcRn flag doc = ifDOptM flag $ do + { loc <- getSrcSpanM + ; let real_doc + | opt_PprStyle_Debug = mkLocMessage loc doc + | otherwise = doc -- The full location is + -- usually way too much ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () -dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } +dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv + ; dflags <- getDOpts + ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () debugDumpTcRn doc | opt_NoDebugOutput = return () | otherwise = dumpTcRn doc dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) +dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc) \end{code} @@ -389,6 +453,9 @@ getModule = do { env <- getGblEnv; return (tcg_mod env) } setModule :: Module -> TcRn a -> TcRn a setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -412,11 +479,6 @@ extendFixityEnv 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} @@ -456,6 +518,7 @@ wrapLocSndM fn (L loc a) = return (b, L loc c) \end{code} +Reporting errors \begin{code} getErrsVar :: TcRn (TcRef Messages) @@ -464,50 +527,31 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: Message -> TcRn () +addErr :: Message -> TcRn () -- Ignores the context stack addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } -addLocErr :: Located e -> (e -> Message) -> TcRn () -addLocErr (L loc e) fn = addErrAt loc (fn e) +failWith :: Message -> TcRn a +failWith msg = addErr msg >> failM addErrAt :: SrcSpan -> Message -> TcRn () -addErrAt loc msg = addLongErrAt loc msg empty - -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns, errs `snocBag` err) } +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- tcInitTidyEnv + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } addErrs :: [(SrcSpan,Message)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addReport :: Message -> TcRn () -addReport msg = do loc <- getSrcSpanM; addReportAt loc msg - -addReportAt :: SrcSpan -> Message -> TcRn () -addReportAt loc msg - = do { errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns `snocBag` warn, errs) } - addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) +addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) - -addLocWarn :: Located e -> (e -> Message) -> TcRn () -addLocWarn (L loc e) fn = addReportAt loc (fn e) +addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False @@ -520,8 +564,8 @@ warnIf False _ = return () addMessages :: Messages -> TcRn () addMessages (m_warns, m_errs) = do { errs_var <- getErrsVar ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns `unionBags` m_warns, + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `unionBags` m_warns, errs `unionBags` m_errs) } discardWarnings :: TcRn a -> TcRn a @@ -532,28 +576,64 @@ discardWarnings :: TcRn a -> TcRn a discardWarnings thing_inside | opt_PprStyle_Debug = thing_inside | otherwise - = do { errs_var <- newMutVar emptyMessages + = do { errs_var <- newTcRef emptyMessages ; result <- setErrsVar errs_var thing_inside - ; (_warns, errs) <- readMutVar errs_var + ; (_warns, errs) <- readTcRef errs_var ; addMessages (emptyBag, errs) ; return result } \end{code} +%************************************************************************ +%* * + Shared error message stuff: renamer and typechecker +%* * +%************************************************************************ + +\begin{code} +addReport :: Message -> Message -> TcRn () +addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info + +addReportAt :: SrcSpan -> Message -> Message -> TcRn () +addReportAt loc msg extra_info + = do { errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `snocBag` warn, errs) } + +addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () +addLongErrAt loc msg extra + = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ; + errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns, errs `snocBag` err) } + +dumpDerivingInfo :: SDoc -> TcM () +dumpDerivingInfo doc + = do { dflags <- getDOpts + ; when (dopt Opt_D_dump_deriv dflags) $ do + { rdr_env <- getGlobalRdrEnv + ; let unqual = mkPrintUnqualified dflags rdr_env + ; liftIO (putMsgWith dflags unqual doc) } } +\end{code} + + \begin{code} -#if __GLASGOW_HASKELL__ < 609 -try_m :: TcRn r -> TcRn (Either Exception r) -#else -try_m :: TcRn r -> TcRn (Either ErrorCall r) -#endif +try_m :: TcRn r -> TcRn (Either IOEnvFailure r) -- Does try_m, with a debug-trace on failure try_m thing = do { mb_r <- tryM thing ; case mb_r of - Left exn -> do { traceTc (exn_msg exn); return mb_r } + Left exn -> do { traceTc "tryTc/recoverM recovering from" $ + text (showException exn) + ; return mb_r } Right _ -> return mb_r } - where - exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) ----------------------- recoverM :: TcRn r -- Recovery action; do this if the main one fails @@ -572,7 +652,7 @@ 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 _ [] = return [] -mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) +mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) ; rs <- mapAndRecoverM f xs ; return (case mb_r of Left _ -> rs @@ -587,9 +667,9 @@ tryTc :: TcRn a -> TcRn (Messages, Maybe a) -- It also returns all the errors and warnings accumulated by m -- It always succeeds (never raises an exception) tryTc m - = do { errs_var <- newMutVar emptyMessages ; + = do { errs_var <- newTcRef emptyMessages ; res <- try_m (setErrsVar errs_var m) ; - msgs <- readMutVar errs_var ; + msgs <- readTcRef errs_var ; return (msgs, case res of Left _ -> Nothing Right val -> Just val) @@ -620,10 +700,10 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a) -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ; + = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ; ; case mb_res of Nothing -> return (msgs, Nothing) - Just val -> do { extendLIEs lie; return (msgs, Just val) } + Just val -> do { emitConstraints lie; return (msgs, Just val) } } ----------------------- @@ -661,7 +741,7 @@ ifErrsM :: TcRn r -> TcRn r -> TcRn r -- otherwise does 'main' ifErrsM bale_out normal = do { errs_var <- getErrsVar ; - msgs <- readMutVar errs_var ; + msgs <- readTcRef errs_var ; dflags <- getDOpts ; if errorsFound dflags msgs then bale_out @@ -676,49 +756,50 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ %* * - Context management and error message generation - for the type checker + Context management for the type checker %* * %************************************************************************ \begin{code} -getErrCtxt :: TcM ErrCtxt +getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } -setErrCtxt :: ErrCtxt -> TcM a -> TcM a +setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) addErrCtxt :: Message -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a -addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) +addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) + +addLandmarkErrCtxt :: Message -> TcM a -> TcM a +addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts) -- Helper function for the above -updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a +updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) -getInstLoc :: InstOrigin -> TcM InstLoc -getInstLoc origin +getCtLoc :: orig -> TcM (CtLoc orig) +getCtLoc origin = do { loc <- getSrcSpanM ; env <- getLclEnv ; - return (InstLoc origin loc (tcl_ctxt env)) } + return (CtLoc origin loc (tcl_ctxt env)) } -addInstCtxt :: InstLoc -> TcM a -> TcM a --- Add the SrcSpan and context from the first Inst in the list --- (they all have similar locations) -addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = setSrcSpan src_loc (updCtxt (\_ -> ctxt) thing_inside) +setCtLoc :: CtLoc orig -> TcM a -> TcM a +setCtLoc (CtLoc _ src_loc ctxt) thing_inside + = setSrcSpan src_loc (setErrCtxt ctxt thing_inside) \end{code} +%************************************************************************ +%* * + Error message generation (type checker) +%* * +%************************************************************************ + The addErrTc functions add an error message, but do not cause failure. The 'M' variants pass a TidyEnv that has already been used to tidy up the message; we then use it to tidy the context messages @@ -764,8 +845,8 @@ addWarnTc msg = do { env0 <- tcInitTidyEnv addWarnTcM :: (TidyEnv, Message) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; - ctxt_msgs <- do_ctxt env0 ctxt ; - addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) } + err_info <- mkErrInfo env0 ctxt ; + addReport (ptext (sLit "Warning:") <+> msg) err_info } warnTc :: Bool -> Message -> TcM () warnTc warn_if_true warn_msg @@ -802,23 +883,33 @@ tcInitTidyEnv \begin{code} add_err_tcm :: TidyEnv -> Message -> SrcSpan - -> [TidyEnv -> TcM (TidyEnv, SDoc)] + -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt - = do { ctxt_msgs <- do_ctxt tidy_env ctxt ; - addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) } - -do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc] -do_ctxt _ [] - = return [] -do_ctxt tidy_env (c:cs) - = do { (tidy_env', m) <- c tidy_env ; - ms <- do_ctxt tidy_env' cs ; - return (m:ms) } - -ctxt_to_use :: [SDoc] -> [SDoc] -ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt - | otherwise = take 3 ctxt + = do { err_info <- mkErrInfo tidy_env ctxt ; + addLongErrAt loc err_msg err_info } + +mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc +-- Tidy the error info, trimming excessive contexts +mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise + = go 0 env ctxts + where + go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc + go _ _ [] = return empty + go n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug + = do { (env', msg) <- ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go n' env' ctxts + ; return (msg $$ rest) } + | otherwise + = go n env ctxts + +mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts +mAX_CONTEXTS = 3 \end{code} debugTc is useful for monadic debugging code @@ -830,51 +921,96 @@ debugTc thing | otherwise = return () \end{code} - %************************************************************************ +%************************************************************************ %* * - Type constraints (the so-called LIE) + Type constraints %* * %************************************************************************ \begin{code} -nextDFunIndex :: TcM Int -- Get the next dfun index -nextDFunIndex = do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; n <- readMutVar dfun_n_var - ; writeMutVar dfun_n_var (n+1) - ; return n } - -getLIEVar :: TcM (TcRef LIE) -getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } - -setLIEVar :: TcRef LIE -> TcM a -> TcM a -setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) - -getLIE :: TcM a -> TcM (a, [Inst]) --- (getLIE m) runs m, and returns the type constraints it generates -getLIE thing_inside - = do { lie_var <- newMutVar emptyLIE ; +newTcEvBinds :: TcM EvBindsVar +newTcEvBinds = do { ref <- newTcRef emptyEvBindMap + ; uniq <- newUnique + ; return (EvBindsVar ref uniq) } + +extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds +extendTcEvBinds binds@(TcEvBinds binds_var) var rhs + = do { addTcEvBind binds_var var rhs + ; return binds } +extendTcEvBinds (EvBinds bnds) var rhs + = return (EvBinds (bnds `snocBag` EvBind var rhs)) + +addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM () +-- Add a binding to the TcEvBinds by side effect +addTcEvBind (EvBindsVar ev_ref _) var rhs + = do { bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (extendEvBinds bnds var rhs) } + +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readTcRef dfun_n_var + ; let occ = fn set + ; writeTcRef dfun_n_var (extendOccSet set occ) + ; return occ } + +getConstraintVar :: TcM (TcRef WantedConstraints) +getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } + +setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a +setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) + +emitConstraints :: WantedConstraints -> TcM () +emitConstraints ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`andWC` ct) } + +emitFlat :: WantedEvVar -> TcM () +emitFlat ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addFlats` unitBag ct) } + +emitFlats :: Bag WantedEvVar -> TcM () +emitFlats ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addFlats` ct) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } + +emitImplications :: Bag Implication -> TcM () +emitImplications ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` ct) } + +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +captureConstraints thing_inside + = do { lie_var <- newTcRef emptyWC ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) thing_inside ; - lie <- readMutVar lie_var ; - return (res, lieToList lie) } - -extendLIE :: Inst -> TcM () -extendLIE inst - = do { lie_var <- getLIEVar ; - lie <- readMutVar lie_var ; - writeMutVar lie_var (inst `consLIE` lie) } - -extendLIEs :: [Inst] -> TcM () -extendLIEs [] - = return () -extendLIEs insts - = do { lie_var <- getLIEVar ; - lie <- readMutVar lie_var ; - writeMutVar lie_var (mkLIE insts `plusLIE` lie) } -\end{code} + lie <- readTcRef lie_var ; + return (res, lie) } + +captureUntouchables :: TcM a -> TcM (a, Untouchables) +captureUntouchables thing_inside + = do { env <- getLclEnv + ; low_meta <- readTcRef (tcl_meta env) + ; res <- setLclEnv (env { tcl_untch = low_meta }) + thing_inside + ; high_meta <- readTcRef (tcl_meta env) + ; return (res, TouchableRange low_meta high_meta) } + +isUntouchable :: TcTyVar -> TcM Bool +isUntouchable tv = do { env <- getLclEnv + ; return (varUnique tv < tcl_untch env) } + +getLclTypeEnv :: TcM (NameEnv TcTyThing) +getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } -\begin{code} setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a -- Set the local type envt, but do *not* disturb other fields, -- notably the lie_var @@ -894,17 +1030,17 @@ setLclTypeEnv lcl_env thing_inside \begin{code} recordThUse :: TcM () -recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } +recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } 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) } + ; updTcRef (tcg_keep env) (`addOneToNameSet` idName id) } | otherwise = return () keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set keepAliveSetTc ns = do { env <- getGblEnv; - ; updMutVar (tcg_keep env) (`unionNameSets` ns) } + ; updTcRef (tcg_keep env) (`unionNameSets` ns) } getStage :: TcM ThStage getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } @@ -947,7 +1083,7 @@ initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) } - ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } + ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } initIfaceExtCore :: IfL a -> TcRn a @@ -966,7 +1102,7 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a -- Initialise the environment with no useful info at all initIfaceCheck hsc_env do_this = do let rec_types = case hsc_type_env_var hsc_env of - Just (mod,var) -> Just (mod, readMutVar var) + Just (mod,var) -> Just (mod, readTcRef var) Nothing -> Nothing gbl_env = IfGblEnv { if_rec_types = rec_types } initTcRnIf 'i' hsc_env gbl_env () do_this @@ -976,8 +1112,8 @@ initIfaceTc :: ModIface -- Used when type-checking checking an up-to-date interface file -- No type envt from the current module, but we do know the module dependencies initIfaceTc iface do_this - = do { tc_env_var <- newMutVar emptyTypeEnv - ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; + = do { tc_env_var <- newTcRef emptyTypeEnv + ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ; ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) @@ -1014,7 +1150,7 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@ -1041,15 +1177,15 @@ forkM_maybe doc thing_inside -- Bleat about errors in the forked thread, if -ddump-if-trace is on -- Otherwise we silently discard errors. Errors can legitimately -- happen when compiling interface signatures (see tcInterfaceSigs) - ifOptM Opt_D_dump_if_trace + ifDOptM Opt_D_dump_if_trace (print_errs (hang (text "forkM failed:" <+> doc) - 4 (text (show exn)))) + 2 (text (show exn)))) ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside