{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcRnMonad(
- module TcRnMonad,
- module TcRnTypes,
- module IOEnv
+ -- * Initalisation
+ initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
+
+ -- * Simple accessors
+ discardResult,
+ getTopEnv, updTopEnv, getGblEnv, updGblEnv,
+ setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+ getEnvs, setEnvs,
+ xoptM, doptM, goptM, woptM,
+ setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
+ whenDOptM, whenGOptM, whenWOptM,
+ whenXOptM, unlessXOptM,
+ getGhcMode,
+ withDoDynamicToo,
+ getEpsVar,
+ getEps,
+ updateEps, updateEps_,
+ getHpt, getEpsAndHpt,
+
+ -- * Arrow scopes
+ newArrowScope, escapeArrowScope,
+
+ -- * Unique supply
+ newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
+ newSysName, newSysLocalId, newSysLocalIds,
+
+ -- * Accessing input/output
+ newTcRef, readTcRef, writeTcRef, updTcRef,
+
+ -- * Debugging
+ traceTc, traceRn, traceOptTcRn, traceTcRn,
+ getPrintUnqualified,
+ printForUserTcRn,
+ traceIf, traceHiDiffs, traceOptIf,
+ debugTc,
+
+ -- * Typechecker global environment
+ getIsGHCi, getGHCiMonad, getInteractivePrintName,
+ tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
+ getRdrEnvs, getImports,
+ getFixityEnv, extendFixityEnv, getRecFieldEnv,
+ getDeclaredDefaultTys,
+ addDependentFiles,
+
+ -- * Error management
+ getSrcSpanM, setSrcSpan, addLocM,
+ wrapLocM, wrapLocFstM, wrapLocSndM,
+ getErrsVar, setErrsVar,
+ addErr,
+ failWith, failAt,
+ addErrAt, addErrs,
+ checkErr,
+ addMessages,
+ discardWarnings,
+
+ -- * Shared error message stuff: renamer and typechecker
+ mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+ reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
+ tryTc,
+ askNoErrs, discardErrs, tryTcDiscardingErrs,
+ checkNoErrs, whenNoErrs,
+ ifErrsM, failIfErrsM,
+ checkTH, failTH,
+
+ -- * Context management for the type checker
+ getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+ addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+
+ -- * Error message generation (type checker)
+ addErrTc, addErrsTc,
+ addErrTcM, mkErrTcM, mkErrTc,
+ failWithTc, failWithTcM,
+ checkTc, checkTcM,
+ failIfTc, failIfTcM,
+ warnIfFlag, warnIf, warnTc, warnTcM,
+ addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
+ mkErrInfo,
+
+ -- * Type constraints
+ newTcEvBinds, newNoTcEvBinds,
+ addTcEvBind, addTopEvBinds,
+ getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+ chooseUniqueOccTc,
+ getConstraintVar, setConstraintVar,
+ emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
+ emitImplication, emitImplications, emitInsoluble,
+ discardConstraints, captureConstraints, tryCaptureConstraints,
+ pushLevelAndCaptureConstraints,
+ pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+ getTcLevel, setTcLevel, isTouchableTcM,
+ getLclTypeEnv, setLclTypeEnv,
+ traceTcConstraints, emitWildCardHoleConstraints,
+
+ -- * Template Haskell context
+ recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
+ getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
+ addModFinalizersWithLclEnv,
+
+ -- * Safe Haskell context
+ recordUnsafeInfer, finalSafeMode, fixSafeInstances,
+
+ -- * Stuff for the renamer's local env
+ getLocalRdrEnv, setLocalRdrEnv,
+
+ -- * Stuff for interface decls
+ mkIfLclEnv,
+ initIfaceTcRn,
+ initIfaceCheck,
+ initIfaceLcl,
+ initIfaceLclWithSubst,
+ initIfaceLoad,
+ getIfModule,
+ failIfM,
+ forkM_maybe,
+ forkM,
+ setImplicitEnvM,
+
+ withException,
+
+ -- * Stuff for cost centres.
+ ContainsCostCentreState(..), getCCIndexM,
+
+ -- * Types etc.
+ module TcRnTypes,
+ module IOEnv
) where
#include "HsVersions.h"
+import GhcPrelude
+
import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
import TcEvidence
import Bag
import Outputable
import UniqSupply
-import UniqFM
import DynFlags
-import StaticFlags
import FastString
import Panic
import Util
import Annotations
import BasicTypes( TopLevelFlag )
+import Maybes
+import CostCentreState
import qualified GHC.LanguageExtensions as LangExt
-import Control.Exception
import Data.IORef
import Control.Monad
+import Data.Set ( Set )
+import qualified Data.Set as Set
+
+import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
+import {-# SOURCE #-} TcEnv ( tcInitTidyEnv )
-#ifdef GHCI
import qualified Data.Map as Map
-#endif
{-
************************************************************************
-- (error messages should have been printed already)
initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
- = do { errs_var <- newIORef (emptyBag, emptyBag) ;
- tvs_var <- newIORef emptyVarSet ;
- keep_var <- newIORef emptyNameSet ;
+ = do { keep_var <- newIORef emptyNameSet ;
used_gre_var <- newIORef [] ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
+ th_locs_var <- newIORef Set.empty ;
infer_var <- newIORef (True, emptyBag) ;
- 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 ;
dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
-#ifdef GHCI
+ cc_st_var <- newIORef newCostCentreState ;
th_topdecls_var <- newIORef [] ;
+ th_foreign_files_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
+ th_coreplugins_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
-#endif /* GHCI */
+ th_remote_state_var <- newIORef Nothing ;
let {
dflags = hsc_dflags hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
- | keep_rn_syntax = Just empty_val
- | otherwise = Nothing ;
+ | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+ -- We want to serialize the documentation in the .hi-files,
+ -- and need to extract it from the renamed syntax first.
+ -- See 'ExtractDocs.extractDocs'.
+ | gopt Opt_Haddock dflags = Just empty_val
+
+ | keep_rn_syntax = Just empty_val
+ | otherwise = Nothing ;
gbl_env = TcGblEnv {
-#ifdef GHCI
tcg_th_topdecls = th_topdecls_var,
+ tcg_th_foreign_files = th_foreign_files_var,
tcg_th_topnames = th_topnames_var,
tcg_th_modfinalizers = th_modfinalizers_var,
+ tcg_th_coreplugins = th_coreplugins_var,
tcg_th_state = th_state_var,
-#endif /* GHCI */
+ tcg_th_remote_state = th_remote_state_var,
tcg_mod = mod,
+ tcg_semantic_mod =
+ canonicalizeModuleIfHome dflags mod,
tcg_src = hsc_src,
- tcg_sig_of = getSigOf dflags (moduleName mod),
- tcg_impl_rdr_env = Nothing,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = emptyNameEnv,
tcg_ann_env = emptyAnnEnv,
tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var,
+ tcg_th_top_level_locs
+ = th_locs_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_gres = used_gre_var,
tcg_dus = emptyDUs,
tcg_rn_imports = [],
- tcg_rn_exports = maybe_rn_syntax [],
+ tcg_rn_exports =
+ if hsc_src == HsigFile
+ -- Always retain renamed syntax, so that we can give
+ -- better errors. (TODO: how?)
+ then Just []
+ else maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_tr_module = Nothing,
tcg_binds = emptyLHsBinds,
tcg_fam_insts = [],
tcg_rules = [],
tcg_fords = [],
- tcg_vects = [],
tcg_patsyns = [],
+ tcg_merged = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc_hdr = Nothing,
tcg_safeInfer = infer_var,
tcg_dependent_files = dependent_files_var,
tcg_tc_plugins = [],
- tcg_static_wc = static_wc_var
+ tcg_top_loc = loc,
+ tcg_static_wc = static_wc_var,
+ tcg_complete_matches = [],
+ tcg_cc_st = cc_st_var
} ;
- lcl_env = TcLclEnv {
+ } ;
+
+ -- OK, here's the business end!
+ initTcWithGbl hsc_env gbl_env loc do_this
+ }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+ -> TcGblEnv
+ -> RealSrcSpan
+ -> TcM r
+ -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { tvs_var <- newIORef emptyVarSet
+ ; lie_var <- newIORef emptyWC
+ ; errs_var <- newIORef (emptyBag, emptyBag)
+ ; let lcl_env = TcLclEnv {
tcl_errs = errs_var,
tcl_loc = loc, -- Should be over-ridden very soon!
tcl_ctxt = [],
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_bndrs = [],
- tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_tclvl = topTcLevel
- } ;
- } ;
+ }
- -- OK, here's the business end!
- maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+ ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
do { r <- tryM do_this
; case r of
Right res -> return (Just res)
- Left _ -> return Nothing } ;
+ Left _ -> return Nothing }
- -- Check for unsolved constraints
- lie <- readIORef lie_var ;
- if isEmptyWC lie
- then return ()
- else pprPanic "initTc: unsolved constraints" (ppr lie) ;
+ -- Check for unsolved constraints
+ -- If we succeed (maybe_res = Just r), there should be
+ -- no unsolved constraints. But if we exit via an
+ -- exception (maybe_res = Nothing), we may have skipped
+ -- solving, so don't panic then (Trac #13466)
+ ; lie <- readIORef (tcl_lie lcl_env)
+ ; when (isJust maybe_res && not (isEmptyWC lie)) $
+ pprPanic "initTc: unsolved constraints" (ppr lie)
-- Collect any error messages
- msgs <- readIORef errs_var ;
-
- let { final_res | errorsFound dflags msgs = Nothing
- | otherwise = maybe_res } ;
+ ; msgs <- readIORef (tcl_errs lcl_env)
- return (msgs, final_res)
- }
+ ; let { final_res | errorsFound dflags msgs = Nothing
+ | otherwise = maybe_res }
+ ; return (msgs, final_res)
+ }
+ where dflags = hsc_dflags hsc_env
initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
-- Initialise the type checker monad for use in GHCi
where
interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-initTcForLookup :: HscEnv -> TcM a -> IO a
--- The thing_inside is just going to look up something
--- in the environment, so we don't need much setup
-initTcForLookup hsc_env thing_inside
- = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
- ; case m of
- Nothing -> throwIO $ mkSrcErr $ snd msgs
- Just x -> return x }
-
{- Note [Default types]
~~~~~~~~~~~~~~~~~~~~~~~
The Integer type is simply not available in package ghc-prim (it is
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { env <- getEnv; return (env_top env) }
+updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
+ env { env_top = upd top })
+
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { env <- getEnv; return (env_gbl env) }
woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
+setXOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
+
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
+unsetGOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )
+unsetWOptM flag =
+ updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
-- | Do it flag is true
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
when b thing_inside
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+ unless b thing_inside
+
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-withDoDynamicToo m = do env <- getEnv
- let dflags = extractDynFlags env
- dflags' = dynamicTooMkDynamicDynFlags dflags
- env' = replaceDynFlags env dflags'
- setEnv env' m
+withDoDynamicToo =
+ updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+ top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
; return (eps, hsc_HPT env) }
+-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
+-- an exception if it is an error.
+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
+withException do_this = do
+ r <- do_this
+ dflags <- getDynFlags
+ case r of
+ Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+ Succeeded result -> return result
+
{-
************************************************************************
* *
writeMutVar u_var us1 ;
return us2 }}}
-newLocalName :: Name -> TcM Name
-newLocalName name = newName (nameOccName name)
+cloneLocalName :: Name -> TcM Name
+-- Make a fresh Internal name with the same OccName and SrcSpan
+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
newName :: OccName -> TcM Name
-newName occ
+newName occ = do { loc <- getSrcSpanM
+ ; newNameAt occ loc }
+
+newNameAt :: OccName -> SrcSpan -> TcM Name
+newNameAt occ span
= do { uniq <- newUnique
- ; loc <- getSrcSpanM
- ; return (mkInternalName uniq occ loc) }
+ ; return (mkInternalName uniq occ span) }
newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName occ
updTcRef ref fn = liftIO $ do { old <- readIORef ref
; writeIORef ref (fn old) }
-updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
--- Returns previous value
-updTcRefX ref fn = liftIO $ do { old <- readIORef ref
- ; writeIORef ref (fn old)
- ; return old }
-
{-
************************************************************************
* *
************************************************************************
-}
+
+-- Typechecker trace
traceTc :: String -> SDoc -> TcRn ()
-traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
+traceTc =
+ labelledTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+ labelledTraceOptTcRn Opt_D_dump_rn_trace
--- | Typechecker trace
-traceTcN :: Int -> SDoc -> TcRn ()
-traceTcN level doc
- = do dflags <- getDynFlags
- when (level <= traceLevel dflags && not opt_NoDebugOutput) $
- traceOptTcRn Opt_D_dump_tc_trace doc
+-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
+-- but accepts a string as a label and formats the trace message uniformly.
+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+labelledTraceOptTcRn flag herald doc = do
+ traceOptTcRn flag (formatTraceMsg herald doc)
-traceRn :: SDoc -> TcRn ()
-traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
-- | Output a doc if the given 'DumpFlag' is set.
--
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc
= do { dflags <- getDynFlags
- ; when (dopt flag dflags) (traceTcRn flag doc)
- }
+ ; when (dopt flag dflags)
+ (traceTcRn flag doc)
+ }
+
traceTcRn :: DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
-- for --dump-to-file, not to decide whether or not to output
-- That part is done by the caller
traceTcRn flag doc
- = do { real_doc <- prettyDoc doc
- ; dflags <- getDynFlags
+ = do { dflags <- getDynFlags
+ ; real_doc <- prettyDoc dflags doc
; printer <- getPrintUnqualified dflags
; liftIO $ dumpSDoc dflags printer flag "" real_doc }
where
- -- Add current location if opt_PprStyle_Debug
- prettyDoc :: SDoc -> TcRn SDoc
- prettyDoc doc = if opt_PprStyle_Debug
+ -- Add current location if -dppr-debug
+ prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
+ prettyDoc dflags doc = if hasPprDebug dflags
then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
else return doc -- The full location is usually way too much
; printer <- getPrintUnqualified dflags
; liftIO (printOutputForUser dflags printer doc) }
--- | Typechecker debug
-debugDumpTcRn :: SDoc -> TcRn ()
-debugDumpTcRn doc = unless opt_NoDebugOutput $
- traceOptTcRn Opt_D_dump_tc doc
-
{-
traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
available. Alas, they behave inconsistently with the other stuff;
************************************************************************
-}
-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 (isInteractiveModule mod) }
-- Add the error if the bool is False
checkErr ok msg = unless ok (addErr msg)
-warnIf :: Bool -> MsgDoc -> TcRn ()
-warnIf True msg = addWarn msg
-warnIf False _ = return ()
-
addMessages :: Messages -> TcRn ()
-addMessages (m_warns, m_errs)
+addMessages msgs1
= do { errs_var <- getErrsVar ;
- (warns, errs) <- readTcRef errs_var ;
- writeTcRef errs_var (warns `unionBags` m_warns,
- errs `unionBags` m_errs) }
+ msgs0 <- readTcRef errs_var ;
+ writeTcRef errs_var (unionMessages msgs0 msgs1) }
discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
= do { errs_var <- getErrsVar
- ; (old_warns, _) <- readTcRef errs_var ;
+ ; (old_warns, _) <- readTcRef errs_var
; result <- thing_inside
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns, errs `snocBag` err) }
-reportWarning :: ErrMsg -> TcRn ()
-reportWarning err
- = do { let warn = makeIntoWarning err
+reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning reason err
+ = do { let warn = makeIntoWarning reason err
-- 'err' was built by mkLongErrMsg or something like that,
-- so it's of error severity. For a warning we downgrade
-- its severity to SevWarning
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
-- Does tryM, with a debug-trace on failure
try_m thing
- = do { mb_r <- tryM thing ;
- case mb_r of
- Left exn -> do { traceTc "tryTc/recoverM recovering from" $
- text (showException exn)
- ; return mb_r }
- Right _ -> return mb_r }
+ = do { (mb_r, lie) <- tryCaptureConstraints thing
+ ; emitConstraints lie
+
+ -- Debug trace
+ ; case mb_r of
+ Left exn -> traceTc "tryTc/recoverM recovering from" $
+ text (showException exn)
+ Right {} -> return ()
+
+ ; return mb_r }
-----------------------
recoverM :: TcRn r -- Recovery action; do this if the main one fails
- -> TcRn r -- Main action: do this first
+ -> TcRn r -- Main action: do this first;
+ -- if it generates errors, propagate them all
-> TcRn r
-- Errors in 'thing' are retained
recoverM recover thing
-----------------------
-mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
--- Drop elements of the input that fail, so the result
+
+-- | 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 <- try_m (f x)
- ; rs <- mapAndRecoverM f xs
- ; return (case mb_r of
- Left _ -> rs
- Right r -> r:rs) }
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc [] = return acc
+foldAndRecoverM f acc (x:xs) =
+ do { mb_r <- try_m (f acc x)
+ ; case mb_r of
+ Left _ -> foldAndRecoverM f acc xs
+ Right acc' -> foldAndRecoverM f acc' xs }
-- | Succeeds if applying the argument to all members of the lists succeeds,
-- but nevertheless runs it on all arguments, to collect all errors.
-- Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
-tryTc m
+tryTc thing_inside
= do { errs_var <- newTcRef emptyMessages ;
- res <- try_m (setErrsVar errs_var m) ;
+
+ res <- try_m $ -- Be sure to catch exceptions, so that
+ -- we guaranteed to read the messages out
+ -- of that brand-new errs_var!
+ setErrsVar errs_var $
+ thing_inside ;
+
msgs <- readTcRef errs_var ;
+
return (msgs, case res of
- Left _ -> Nothing
- Right val -> Just val)
+ Left _ -> Nothing
+ Right val -> Just val)
-- The exception is always the IOEnv built-in
-- in exception; see IOEnv.failM
}
--- (askNoErrs m) runs m
--- If m fails, (askNoErrs m) fails
--- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
--- where b is True iff m generated no errors
--- Regardless of success or failure, any errors generated by m are propagated
-askNoErrs :: TcRn a -> TcRn (a, Bool)
-askNoErrs m
- = do { errs_var <- newTcRef emptyMessages
- ; res <- setErrsVar errs_var m
- ; (warns, errs) <- readTcRef errs_var
- ; addMessages (warns, errs)
- ; return (res, isEmptyBag errs) }
-
+-----------------------
discardErrs :: TcRn a -> TcRn a
-- (discardErrs m) runs m,
-- discarding all error messages and warnings generated by m
; setErrsVar errs_var m }
-----------------------
-tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
--- Run the thing, returning
--- Just r, if m succceeds with no error messages
--- Nothing, if m fails, or if it succeeds but has error messages
--- Either way, the messages are returned;
--- even in the Just case there might be warnings
-tryTcErrs thing
- = do { (msgs, res) <- tryTc thing
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover main) tries 'main';
+-- if 'main' succeeds with no error messages, it's the answer
+-- otherwise discard everything from 'main', including errors,
+-- and try 'recover' instead.
+tryTcDiscardingErrs recover main
+ = do { (msgs, mb_res) <- tryTc main
; dflags <- getDynFlags
- ; let errs_found = errorsFound dflags msgs
- ; return (msgs, case res of
- Nothing -> Nothing
- Just val | errs_found -> Nothing
- | otherwise -> Just val)
- }
-
------------------------
-tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
--- Just like tryTcErrs, except that it ensures that the LIE
--- 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) <- captureConstraints (tryTcErrs thing_inside) ;
; case mb_res of
- Nothing -> return (msgs, Nothing)
- Just val -> do { emitConstraints lie; return (msgs, Just val) }
- }
+ Just res | not (errorsFound dflags msgs)
+ -> -- 'main' succeeed with no error messages
+ do { addMessages msgs -- msgs might still have warnings
+ ; return res }
------------------------
-tryTcLIE_ :: TcM r -> TcM r -> TcM r
--- (tryTcLIE_ r m) tries m;
--- if m succeeds with no error messages, it's the answer
--- otherwise tryTcLIE_ drops everything from m and tries r instead.
-tryTcLIE_ recover main
- = do { (msgs, mb_res) <- tryTcLIE main
- ; case mb_res of
- Just val -> do { addMessages msgs -- There might be warnings
- ; return val }
- Nothing -> recover -- Discard all msgs
+ _ -> -- 'main' failed, or produced an error message
+ recover -- Discard all errors and warnings entirely
}
-----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+-- then (askNoErrs m) fails
+-- If m succeeds with result r,
+-- then (askNoErrs m) succeeds with result (r, b),
+-- where b is True iff m generated no errors
+-- Regardless of success or failure,
+-- propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs m
+ = do { (msgs, mb_res) <- tryTc m
+ ; addMessages msgs -- Always propagate errors
+ ; case mb_res of
+ Nothing -> failM
+ Just res -> do { dflags <- getDynFlags
+ ; let errs_found = errorsFound dflags msgs
+ ; return (res, not errs_found) } }
+-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
- = do { (msgs, mb_res) <- tryTcLIE main
- ; addMessages msgs
- ; case mb_res of
- Nothing -> failM
- Just val -> return val
- }
+ = do { (res, no_errs) <- askNoErrs main
+ ; unless no_errs failM
+ ; return res }
+-----------------------
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
-#ifdef GHCI
checkTH :: a -> String -> TcRn ()
checkTH _ _ = return () -- OK
-#else
-checkTH :: Outputable a => a -> String -> TcRn ()
-checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
-#endif
failTH :: Outputable a => a -> String -> TcRn x
failTH e what -- Raise an error in a stage-1 compiler
= failWithTc (vcat [ hang (char 'A' <+> text what
- <+> ptext (sLit "requires GHC with interpreter support:"))
+ <+> text "requires GHC with interpreter support:")
2 (ppr e)
- , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
+ , text "Perhaps you are using a stage-1 compiler?" ])
-{-
-************************************************************************
+
+{- *********************************************************************
* *
Context management for the type checker
* *
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
+-- | Add a fixed message to the error context. This message should not
+-- do any tidying.
addErrCtxt :: MsgDoc -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+-- | Add a fixed landmark message to the error context. A landmark
+-- message is always sure to be reported, even if there is a lot of
+-- context. It also doesn't count toward the maximum number of contexts
+-- reported.
addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
-addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
+
+-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
+-- and tidying.
+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
-- Helper function for the above
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
err_info <- mkErrInfo tidy_env ctxt ;
mkLongErrAt loc err_msg err_info }
+mkErrTc :: MsgDoc -> TcM ErrMsg
+mkErrTc msg = do { env0 <- tcInitTidyEnv
+ ; mkErrTcM (env0, msg) }
+
-- The failWith functions add an error message and cause failure
failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
-- Warnings have no 'M' variant, nor failure
-warnTc :: Bool -> MsgDoc -> TcM ()
-warnTc warn_if_true warn_msg
- | warn_if_true = addWarnTc warn_msg
+-- | Display a warning if a condition is met,
+-- and the warning is enabled
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+ = do { warn_on <- woptM warn_flag
+ ; when (warn_on && is_bad) $
+ addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+ = when is_bad (addWarn NoReason msg)
+
+-- | Display a warning if a condition is met.
+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
+warnTc reason warn_if_true warn_msg
+ | warn_if_true = addWarnTc reason warn_msg
| otherwise = return ()
-warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
-warnTcM warn_if_true warn_msg
- | warn_if_true = addWarnTcM warn_msg
+-- | Display a warning if a condition is met.
+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM reason warn_if_true warn_msg
+ | warn_if_true = addWarnTcM reason warn_msg
| otherwise = return ()
-addWarnTc :: MsgDoc -> TcM ()
-addWarnTc msg = do { env0 <- tcInitTidyEnv
- ; addWarnTcM (env0, msg) }
+-- | Display a warning in the current context.
+addWarnTc :: WarnReason -> MsgDoc -> TcM ()
+addWarnTc reason msg
+ = do { env0 <- tcInitTidyEnv ;
+ addWarnTcM reason (env0, msg) }
-addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
-addWarnTcM (env0, msg)
+-- | Display a warning in a given context.
+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM reason (env0, msg)
= do { ctxt <- getErrCtxt ;
err_info <- mkErrInfo env0 ctxt ;
- add_warn msg err_info }
+ add_warn reason msg err_info }
-addWarn :: MsgDoc -> TcRn ()
-addWarn msg = add_warn msg Outputable.empty
+-- | Display a warning for the current source location.
+addWarn :: WarnReason -> MsgDoc -> TcRn ()
+addWarn reason msg = add_warn reason msg Outputable.empty
-addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
-addWarnAt loc msg = add_warn_at loc msg Outputable.empty
+-- | Display a warning for a given source location.
+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
-add_warn :: MsgDoc -> MsgDoc -> TcRn ()
-add_warn msg extra_info
+-- | Display a warning, with an optional flag, for the current source
+-- location.
+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn reason msg extra_info
= do { loc <- getSrcSpanM
- ; add_warn_at loc msg extra_info }
+ ; add_warn_at reason loc msg extra_info }
-add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
-add_warn_at loc msg extra_info
+-- | Display a warning, with an optional flag, for a given location.
+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at reason loc msg extra_info
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
let { warn = mkLongWarnMsg dflags loc printer
msg extra_info } ;
- reportWarning warn }
-
-tcInitTidyEnv :: TcM TidyEnv
-tcInitTidyEnv
- = do { lcl_env <- getLclEnv
- ; return (tcl_tidy lcl_env) }
-
--- | Get a 'TidyEnv' that includes mappings for all vars free in the given
--- type. Useful when tidying open types.
-tcInitOpenTidyEnv :: TyCoVarSet -> TcM TidyEnv
-tcInitOpenTidyEnv tvs
- = do { env1 <- tcInitTidyEnv
- ; let env2 = tidyFreeTyCoVars env1 tvs
- ; return env2 }
+ reportWarning reason warn }
{-
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
+-- = do
+-- dbg <- hasPprDebug <$> getDynFlags
+-- if dbg -- In -dppr-debug style the output
+-- then return empty -- just becomes too voluminous
+-- else go dbg 0 env ctxts
+ = go False 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
+ go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+ go _ _ _ [] = return empty
+ go dbg n env ((is_landmark, ctxt) : ctxts)
+ | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
= do { (env', msg) <- ctxt env
; let n' = if is_landmark then n else n+1
- ; rest <- go n' env' ctxts
+ ; rest <- go dbg n' env' ctxts
; return (msg $$ rest) }
| otherwise
- = go n env ctxts
+ = go dbg n env ctxts
mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
mAX_CONTEXTS = 3
************************************************************************
-}
+addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
+addTopEvBinds new_ev_binds thing_inside
+ =updGblEnv upd_env thing_inside
+ where
+ upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
+ `unionBags` new_ev_binds }
+
newTcEvBinds :: TcM EvBindsVar
-newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
+ ; tcvs_ref <- newTcRef emptyVarSet
; uniq <- newUnique
; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
- ; return (EvBindsVar ref uniq) }
+ ; return (EvBindsVar { ebv_binds = binds_ref
+ , ebv_tcvs = tcvs_ref
+ , ebv_uniq = uniq }) }
+
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+ = do { tcvs_ref <- newTcRef emptyVarSet
+ ; uniq <- newUnique
+ ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+ ; return (NoEvBindsVar { ebv_tcvs = tcvs_ref
+ , ebv_uniq = uniq }) }
+
+getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+ = readTcRef (ebv_tcvs ev_binds_var)
+
+getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
+ = readTcRef ev_ref
+getTcEvBindsMap (NoEvBindsVar {})
+ = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+ = writeTcRef ev_ref binds
+setTcEvBindsMap v@(NoEvBindsVar {}) ev_binds
+ | isEmptyEvBindMap ev_binds
+ = return ()
+ | otherwise
+ = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
-- Add a binding to the TcEvBinds by side effect
-addTcEvBind (EvBindsVar ev_ref u) ev_bind
+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
= do { traceTc "addTcEvBind" $ ppr u $$
ppr ev_bind
; bnds <- readTcRef ev_ref
; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
-
-getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
-getTcEvBinds (EvBindsVar ev_ref _)
- = do { bnds <- readTcRef ev_ref
- ; return (evBindMapBinds bnds) }
-
-getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
-getTcEvBindsMap (EvBindsVar ev_ref _)
- = readTcRef ev_ref
+addTcEvBind (NoEvBindsVar { ebv_uniq = u }) ev_bind
+ = pprPanic "addTcEvBind NoEvBindsVar" (ppr ev_bind $$ ppr u)
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+emitStaticConstraints :: WantedConstraints -> TcM ()
+emitStaticConstraints static_lie
+ = do { gbl_env <- getGblEnv
+ ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
+
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
+ | isEmptyWC ct
+ = return ()
+ | otherwise
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`andWC` ct) }
emitInsoluble :: Ct -> TcM ()
emitInsoluble ct
- = do { lie_var <- getConstraintVar ;
- updTcRef lie_var (`addInsols` unitBag ct) ;
- v <- readTcRef lie_var ;
- traceTc "emitInsoluble" (ppr v) }
+ = do { traceTc "emitInsoluble" (ppr ct)
+ ; lie_var <- getConstraintVar
+ ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+ | isEmptyBag cts = return ()
+ | otherwise = do { traceTc "emitInsolubles" (ppr cts)
+ ; lie_var <- getConstraintVar
+ ; updTcRef lie_var (`addInsols` cts) }
-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
discardConstraints thing_inside = fst <$> captureConstraints thing_inside
+tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
+-- (captureConstraints_maybe m) runs m,
+-- and returns the type constraints it generates
+-- It never throws an exception; instead if thing_inside fails,
+-- it returns Left exn and the insoluble constraints
+tryCaptureConstraints thing_inside
+ = do { lie_var <- newTcRef emptyWC
+ ; mb_res <- tryM $
+ updLclEnv (\ env -> env { tcl_lie = lie_var }) $
+ thing_inside
+ ; lie <- readTcRef lie_var
+
+ -- See Note [Constraints and errors]
+ ; let lie_to_keep = case mb_res of
+ Left {} -> insolublesOnly lie
+ Right {} -> lie
+
+ ; return (mb_res, lie_to_keep) }
+
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 <- readTcRef lie_var ;
- return (res, lie) }
+ = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
+ -- See Note [Constraints and errors]
+ -- If the thing_inside threw an exception, emit the insoluble
+ -- constraints only (returned by tryCaptureConstraints)
+ -- so that they are not lost
+ ; case mb_res of
+ Left _ -> do { emitConstraints lie; failM }
+ Right res -> return (res, lie) }
+
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
= do { env <- getLclEnv
- ; lie_var <- newTcRef emptyWC ;
; let tclvl' = pushTcLevel (tcl_tclvl env)
- ; res <- setLclEnv (env { tcl_tclvl = tclvl'
- , tcl_lie = lie_var })
- thing_inside
- ; lie <- readTcRef lie_var
+ ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+ captureConstraints thing_inside
; return (tclvl', lie, res) }
pushTcLevelM_ :: TcM a -> TcM a
-pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
pushTcLevelM :: TcM a -> TcM (a, TcLevel)
+-- See Note [TcLevel assignment] in TcType
pushTcLevelM thing_inside
= do { env <- getLclEnv
; let tclvl' = pushTcLevel (tcl_tclvl env)
thing_inside
; return (res, tclvl') }
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+ = do { env <- getLclEnv
+ ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+ ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+ thing_inside
+ ; return (res, tclvl') }
+
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
; return (tcl_tclvl env) }
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
- = do { env <- getLclEnv
- ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
+ = do { lvl <- getTcLevel
+ ; return (isTouchableMetaTyVar lvl tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
traceTcConstraints msg
= do { lie_var <- getConstraintVar
; lie <- readTcRef lie_var
- ; traceTc (msg ++ ": LIE:") (ppr lie)
+ ; traceOptTcRn Opt_D_dump_tc_trace $
+ hang (text (msg ++ ": LIE:")) 2 (ppr lie)
}
emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
emitWildCardHoleConstraints wcs
- = do { ctLoc <- getCtLocM HoleOrigin Nothing
- ; forM_ wcs $ \(name, tv) -> do {
- ; let real_span = case nameSrcSpan name of
+ = do { ct_loc <- getCtLocM HoleOrigin Nothing
+ ; emitInsolubles $ listToBag $
+ map (do_one ct_loc) wcs }
+ where
+ do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+ do_one ct_loc (name, tv)
+ = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+ , ctev_loc = ct_loc' }
+ , cc_hole = TypeHole (occName name) }
+ where
+ real_span = case nameSrcSpan name of
RealSrcSpan span -> span
UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
(ppr name <+> quotes (ftext str))
-- Wildcards are defined locally, and so have RealSrcSpans
- ctLoc' = setCtLocSpan ctLoc real_span
- ty = mkTyVarTy tv
- can = CHoleCan { cc_ev = CtDerived { ctev_pred = ty
- , ctev_loc = ctLoc' }
- , cc_occ = occName name
- , cc_hole = TypeHole }
- ; emitInsoluble can } }
+ ct_loc' = setCtLocSpan ct_loc real_span
+
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12124):
+
+ foo :: Maybe Int
+ foo = return (case Left 3 of
+ Left -> 1 -- Hard error here!
+ _ -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad), from
+the unsaturated Left constructor pattern.
+
+We'll recover in tcPolyBinds, using recoverM. But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the constraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints. Hence in 'try_m' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally. If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report. So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
+However suppose we throw an exception inside an invocation of
+captureConstraints, and discard all the constraints. Some of those
+constraints might be "variable out of scope" Hole constraints, and that
+might have been the actual original cause of the exception! For
+example (Trac #12529):
+ f = p @ Int
+Here 'p' is out of scope, so we get an insolube Hole constraint. But
+the visible type application fails in the monad (thows an exception).
+We must not discard the out-of-scope error.
+
+So we /retain the insoluble constraints/ if there is an exception.
+Hence:
+ - insolublesOnly in tryCaptureConstraints
+ - emitConstraints in the Left case of captureConstraints
+
+Hover note that fresly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble. The constraint solver does that. So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+ t1 :: Int
+ t1 x = x -- Manifestly wrong
+
+ foo = $(...raises exception...)
+We report the exception, but not the bug in t1. Oh well. Possible
+solution: make TcUnify.uType spot manifestly-insoluble constraints.
+
-{-
************************************************************************
* *
Template Haskell context
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
+-- | When generating an out-of-scope error message for a variable matching a
+-- binding in a later inter-splice group, the typechecker uses the splice
+-- locations to provide details in the message about the scope of that binding.
+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
+recordTopLevelSpliceLoc (RealSrcSpan real_loc)
+ = do { env <- getGblEnv
+ ; let locs_var = tcg_th_top_level_locs env
+ ; locs0 <- readTcRef locs_var
+ ; writeTcRef locs_var (Set.insert real_loc locs0) }
+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
+
+getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
+getTopLevelSpliceLocs
+ = do { env <- getGblEnv
+ ; readTcRef (tcg_th_top_level_locs env) }
+
keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
keepAlive name
= do { env <- getGblEnv
- ; traceRn (ptext (sLit "keep alive") <+> ppr name)
+ ; traceRn "keep alive" (ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
getStage :: TcM ThStage
setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+ = do lcl_env <- getLclEnv
+ th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+ updTcRef th_modfinalizers_var $ \fins ->
+ setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
+ : fins
+
{-
************************************************************************
* *
************************************************************************
-}
-mkIfLclEnv :: Module -> SDoc -> IfLclEnv
-mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
+mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv mod loc boot
+ = IfLclEnv { if_mod = mod,
if_loc = loc,
- if_tv_env = emptyUFM,
- if_id_env = emptyUFM }
+ if_boot = boot,
+ if_nsubst = Nothing,
+ if_implicits_env = Nothing,
+ if_tv_env = emptyFsEnv,
+ if_id_env = emptyFsEnv }
-- | Run an 'IfG' (top-level interface monad) computation inside an existing
-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
+ ; dflags <- getDynFlags
+ ; let mod = tcg_semantic_mod tcg_env
+ -- When we are instantiating a signature, we DEFINITELY
+ -- do not want to knot tie.
+ is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
+ not (null (thisUnitIdInsts dflags))
; let { if_env = IfGblEnv {
- if_rec_types = Just (tcg_mod tcg_env, get_type_env)
+ if_doc = text "initIfaceTcRn",
+ if_rec_types =
+ if is_instantiate
+ then Nothing
+ else Just (mod, get_type_env)
}
; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
; setEnvs (if_env, ()) thing_inside }
-initIfaceCheck :: HscEnv -> IfG a -> IO a
+-- Used when sucking in a ModIface into a ModDetails to put in
+-- the HPT. Notably, unlike initIfaceCheck, this does NOT use
+-- hsc_type_env_var (since we're not actually going to typecheck,
+-- so this variable will never get updated!)
+initIfaceLoad :: HscEnv -> IfG a -> IO a
+initIfaceLoad hsc_env do_this
+ = do let gbl_env = IfGblEnv {
+ if_doc = text "initIfaceLoad",
+ if_rec_types = Nothing
+ }
+ initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
-initIfaceCheck hsc_env do_this
+initIfaceCheck doc hsc_env do_this
= do let rec_types = case hsc_type_env_var hsc_env of
Just (mod,var) -> Just (mod, readTcRef var)
Nothing -> Nothing
- gbl_env = IfGblEnv { if_rec_types = rec_types }
+ gbl_env = IfGblEnv {
+ if_doc = text "initIfaceCheck" <+> doc,
+ if_rec_types = rec_types
+ }
initTcRnIf 'i' hsc_env gbl_env () do_this
-initIfaceTc :: ModIface
- -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
--- 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 <- 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)
- }
- where
- mod = mi_module iface
- doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
+initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc hi_boot_file thing_inside
+ = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
-initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
-initIfaceLcl mod loc_doc thing_inside
- = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
+-- | Initialize interface typechecking, but with a 'NameShape'
+-- to apply when typechecking top-level 'OccName's (see
+-- 'lookupIfaceTop')
+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
+ = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }
--------------------
failIfM :: MsgDoc -> IfL a
-- The Iface monad doesn't have a place to accumulate errors, so we
--- just fall over fast if one happens; it "shouldnt happen".
+-- just fall over fast if one happens; it "shouldn't happen".
-- We use IfL here so that we can get context info out of the local env
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
- ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
+ ; liftIO (putLogMsg dflags NoReason SevFatal
+ noSrcSpan (defaultErrStyle dflags) full_msg)
; failM }
--------------------
dflags <- getDynFlags
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
- liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
+ liftIO $ putLogMsg dflags
+ NoReason
+ SevFatal
+ noSrcSpan
+ (defaultErrStyle dflags)
+ msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
-- pprPanic "forkM" doc
Just r -> r) }
+setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m
+
{-
Note [Masking exceptions in forkM_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
discussion). We don't currently know a general solution to this problem, but
we can use uninterruptibleMask_ to avoid the situation.
-}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+ extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+ extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+ extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+ => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+ env <- getGblEnv
+ let cc_st_ref = extractCostCentreState env
+ cc_st <- readTcRef cc_st_ref
+ let (idx, cc_st') = getCCIndex nm cc_st
+ writeTcRef cc_st_ref cc_st'
+ return idx
git.haskell.org / ghc.git / blobdiff