1{- 2(c) The University of Glasgow 2006 3 4 5Functions for working with the typechecker environment (setters, getters...). 6-} 7 8{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} 9{-# LANGUAGE RecordWildCards #-} 10{-# OPTIONS_GHC -fno-warn-orphans #-} 11{-# LANGUAGE ViewPatterns #-} 12 13 14module TcRnMonad( 15 -- * Initalisation 16 initTc, initTcWithGbl, initTcInteractive, initTcRnIf, 17 18 -- * Simple accessors 19 discardResult, 20 getTopEnv, updTopEnv, getGblEnv, updGblEnv, 21 setGblEnv, getLclEnv, updLclEnv, setLclEnv, 22 getEnvs, setEnvs, 23 xoptM, doptM, goptM, woptM, 24 setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, 25 whenDOptM, whenGOptM, whenWOptM, 26 whenXOptM, unlessXOptM, 27 getGhcMode, 28 withDoDynamicToo, 29 getEpsVar, 30 getEps, 31 updateEps, updateEps_, 32 getHpt, getEpsAndHpt, 33 34 -- * Arrow scopes 35 newArrowScope, escapeArrowScope, 36 37 -- * Unique supply 38 newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, 39 newSysName, newSysLocalId, newSysLocalIds, 40 41 -- * Accessing input/output 42 newTcRef, readTcRef, writeTcRef, updTcRef, 43 44 -- * Debugging 45 traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser, 46 traceTcRnWithStyle, 47 getPrintUnqualified, 48 printForUserTcRn, 49 traceIf, traceHiDiffs, traceOptIf, 50 debugTc, 51 52 -- * Typechecker global environment 53 getIsGHCi, getGHCiMonad, getInteractivePrintName, 54 tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, 55 getRdrEnvs, getImports, 56 getFixityEnv, extendFixityEnv, getRecFieldEnv, 57 getDeclaredDefaultTys, 58 addDependentFiles, 59 60 -- * Error management 61 getSrcSpanM, setSrcSpan, addLocM, 62 wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, 63 getErrsVar, setErrsVar, 64 addErr, 65 failWith, failAt, 66 addErrAt, addErrs, 67 checkErr, 68 addMessages, 69 discardWarnings, 70 71 -- * Shared error message stuff: renamer and typechecker 72 mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, 73 reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, 74 attemptM, tryTc, 75 askNoErrs, discardErrs, tryTcDiscardingErrs, 76 checkNoErrs, whenNoErrs, 77 ifErrsM, failIfErrsM, 78 79 -- * Context management for the type checker 80 getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, 81 addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, 82 83 -- * Error message generation (type checker) 84 addErrTc, addErrsTc, 85 addErrTcM, mkErrTcM, mkErrTc, 86 failWithTc, failWithTcM, 87 checkTc, checkTcM, 88 failIfTc, failIfTcM, 89 warnIfFlag, warnIf, warnTc, warnTcM, 90 addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, 91 mkErrInfo, 92 93 -- * Type constraints 94 newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, 95 addTcEvBind, addTopEvBinds, 96 getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, 97 chooseUniqueOccTc, 98 getConstraintVar, setConstraintVar, 99 emitConstraints, emitStaticConstraints, emitSimple, emitSimples, 100 emitImplication, emitImplications, emitInsoluble, 101 discardConstraints, captureConstraints, tryCaptureConstraints, 102 pushLevelAndCaptureConstraints, 103 pushTcLevelM_, pushTcLevelM, pushTcLevelsM, 104 getTcLevel, setTcLevel, isTouchableTcM, 105 getLclTypeEnv, setLclTypeEnv, 106 traceTcConstraints, 107 emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, 108 109 -- * Template Haskell context 110 recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, 111 getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage, 112 addModFinalizersWithLclEnv, 113 114 -- * Safe Haskell context 115 recordUnsafeInfer, finalSafeMode, fixSafeInstances, 116 117 -- * Stuff for the renamer's local env 118 getLocalRdrEnv, setLocalRdrEnv, 119 120 -- * Stuff for interface decls 121 mkIfLclEnv, 122 initIfaceTcRn, 123 initIfaceCheck, 124 initIfaceLcl, 125 initIfaceLclWithSubst, 126 initIfaceLoad, 127 getIfModule, 128 failIfM, 129 forkM_maybe, 130 forkM, 131 setImplicitEnvM, 132 133 withException, 134 135 -- * Stuff for cost centres. 136 ContainsCostCentreState(..), getCCIndexM, 137 138 -- * Types etc. 139 module TcRnTypes, 140 module IOEnv 141 ) where 142 143#include "HsVersions.h" 144 145import GhcPrelude 146 147import TcRnTypes -- Re-export all 148import IOEnv -- Re-export all 149import Constraint 150import TcEvidence 151import TcOrigin 152 153import GHC.Hs hiding (LIE) 154import HscTypes 155import Module 156import RdrName 157import Name 158import Type 159 160import TcType 161import InstEnv 162import FamInstEnv 163import PrelNames 164 165import Id 166import VarSet 167import VarEnv 168import ErrUtils 169import SrcLoc 170import NameEnv 171import NameSet 172import Bag 173import Outputable 174import UniqSupply 175import DynFlags 176import FastString 177import Panic 178import Util 179import Annotations 180import BasicTypes( TopLevelFlag, TypeOrKind(..) ) 181import Maybes 182import CostCentreState 183 184import qualified GHC.LanguageExtensions as LangExt 185 186import Data.IORef 187import Control.Monad 188import Data.Set ( Set ) 189import qualified Data.Set as Set 190 191import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) 192 193import qualified Data.Map as Map 194 195{- 196************************************************************************ 197* * 198 initTc 199* * 200************************************************************************ 201-} 202 203-- | Setup the initial typechecking environment 204initTc :: HscEnv 205 -> HscSource 206 -> Bool -- True <=> retain renamed syntax trees 207 -> Module 208 -> RealSrcSpan 209 -> TcM r 210 -> IO (Messages, Maybe r) 211 -- Nothing => error thrown by the thing inside 212 -- (error messages should have been printed already) 213 214initTc hsc_env hsc_src keep_rn_syntax mod loc do_this 215 = do { keep_var <- newIORef emptyNameSet ; 216 used_gre_var <- newIORef [] ; 217 th_var <- newIORef False ; 218 th_splice_var<- newIORef False ; 219 th_locs_var <- newIORef Set.empty ; 220 infer_var <- newIORef (True, emptyBag) ; 221 dfun_n_var <- newIORef emptyOccSet ; 222 type_env_var <- case hsc_type_env_var hsc_env of { 223 Just (_mod, te_var) -> return te_var ; 224 Nothing -> newIORef emptyNameEnv } ; 225 226 dependent_files_var <- newIORef [] ; 227 static_wc_var <- newIORef emptyWC ; 228 cc_st_var <- newIORef newCostCentreState ; 229 th_topdecls_var <- newIORef [] ; 230 th_foreign_files_var <- newIORef [] ; 231 th_topnames_var <- newIORef emptyNameSet ; 232 th_modfinalizers_var <- newIORef [] ; 233 th_coreplugins_var <- newIORef [] ; 234 th_state_var <- newIORef Map.empty ; 235 th_remote_state_var <- newIORef Nothing ; 236 let { 237 dflags = hsc_dflags hsc_env ; 238 239 maybe_rn_syntax :: forall a. a -> Maybe a ; 240 maybe_rn_syntax empty_val 241 | dopt Opt_D_dump_rn_ast dflags = Just empty_val 242 243 | gopt Opt_WriteHie dflags = Just empty_val 244 245 -- We want to serialize the documentation in the .hi-files, 246 -- and need to extract it from the renamed syntax first. 247 -- See 'ExtractDocs.extractDocs'. 248 | gopt Opt_Haddock dflags = Just empty_val 249 250 | keep_rn_syntax = Just empty_val 251 | otherwise = Nothing ; 252 253 gbl_env = TcGblEnv { 254 tcg_th_topdecls = th_topdecls_var, 255 tcg_th_foreign_files = th_foreign_files_var, 256 tcg_th_topnames = th_topnames_var, 257 tcg_th_modfinalizers = th_modfinalizers_var, 258 tcg_th_coreplugins = th_coreplugins_var, 259 tcg_th_state = th_state_var, 260 tcg_th_remote_state = th_remote_state_var, 261 262 tcg_mod = mod, 263 tcg_semantic_mod = 264 canonicalizeModuleIfHome dflags mod, 265 tcg_src = hsc_src, 266 tcg_rdr_env = emptyGlobalRdrEnv, 267 tcg_fix_env = emptyNameEnv, 268 tcg_field_env = emptyNameEnv, 269 tcg_default = if moduleUnitId mod == primUnitId 270 then Just [] -- See Note [Default types] 271 else Nothing, 272 tcg_type_env = emptyNameEnv, 273 tcg_type_env_var = type_env_var, 274 tcg_inst_env = emptyInstEnv, 275 tcg_fam_inst_env = emptyFamInstEnv, 276 tcg_ann_env = emptyAnnEnv, 277 tcg_th_used = th_var, 278 tcg_th_splice_used = th_splice_var, 279 tcg_th_top_level_locs 280 = th_locs_var, 281 tcg_exports = [], 282 tcg_imports = emptyImportAvails, 283 tcg_used_gres = used_gre_var, 284 tcg_dus = emptyDUs, 285 286 tcg_rn_imports = [], 287 tcg_rn_exports = 288 if hsc_src == HsigFile 289 -- Always retain renamed syntax, so that we can give 290 -- better errors. (TODO: how?) 291 then Just [] 292 else maybe_rn_syntax [], 293 tcg_rn_decls = maybe_rn_syntax emptyRnGroup, 294 tcg_tr_module = Nothing, 295 tcg_binds = emptyLHsBinds, 296 tcg_imp_specs = [], 297 tcg_sigs = emptyNameSet, 298 tcg_ev_binds = emptyBag, 299 tcg_warns = NoWarnings, 300 tcg_anns = [], 301 tcg_tcs = [], 302 tcg_insts = [], 303 tcg_fam_insts = [], 304 tcg_rules = [], 305 tcg_fords = [], 306 tcg_patsyns = [], 307 tcg_merged = [], 308 tcg_dfun_n = dfun_n_var, 309 tcg_keep = keep_var, 310 tcg_doc_hdr = Nothing, 311 tcg_hpc = False, 312 tcg_main = Nothing, 313 tcg_self_boot = NoSelfBoot, 314 tcg_safeInfer = infer_var, 315 tcg_dependent_files = dependent_files_var, 316 tcg_tc_plugins = [], 317 tcg_hf_plugins = [], 318 tcg_top_loc = loc, 319 tcg_static_wc = static_wc_var, 320 tcg_complete_matches = [], 321 tcg_cc_st = cc_st_var 322 } ; 323 } ; 324 325 -- OK, here's the business end! 326 initTcWithGbl hsc_env gbl_env loc do_this 327 } 328 329-- | Run a 'TcM' action in the context of an existing 'GblEnv'. 330initTcWithGbl :: HscEnv 331 -> TcGblEnv 332 -> RealSrcSpan 333 -> TcM r 334 -> IO (Messages, Maybe r) 335initTcWithGbl hsc_env gbl_env loc do_this 336 = do { lie_var <- newIORef emptyWC 337 ; errs_var <- newIORef (emptyBag, emptyBag) 338 ; let lcl_env = TcLclEnv { 339 tcl_errs = errs_var, 340 tcl_loc = loc, -- Should be over-ridden very soon! 341 tcl_ctxt = [], 342 tcl_rdr = emptyLocalRdrEnv, 343 tcl_th_ctxt = topStage, 344 tcl_th_bndrs = emptyNameEnv, 345 tcl_arrow_ctxt = NoArrowCtxt, 346 tcl_env = emptyNameEnv, 347 tcl_bndrs = [], 348 tcl_lie = lie_var, 349 tcl_tclvl = topTcLevel 350 } 351 352 ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ 353 do { r <- tryM do_this 354 ; case r of 355 Right res -> return (Just res) 356 Left _ -> return Nothing } 357 358 -- Check for unsolved constraints 359 -- If we succeed (maybe_res = Just r), there should be 360 -- no unsolved constraints. But if we exit via an 361 -- exception (maybe_res = Nothing), we may have skipped 362 -- solving, so don't panic then (#13466) 363 ; lie <- readIORef (tcl_lie lcl_env) 364 ; when (isJust maybe_res && not (isEmptyWC lie)) $ 365 pprPanic "initTc: unsolved constraints" (ppr lie) 366 367 -- Collect any error messages 368 ; msgs <- readIORef (tcl_errs lcl_env) 369 370 ; let { final_res | errorsFound dflags msgs = Nothing 371 | otherwise = maybe_res } 372 373 ; return (msgs, final_res) 374 } 375 where dflags = hsc_dflags hsc_env 376 377initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) 378-- Initialise the type checker monad for use in GHCi 379initTcInteractive hsc_env thing_inside 380 = initTc hsc_env HsSrcFile False 381 (icInteractiveModule (hsc_IC hsc_env)) 382 (realSrcLocSpan interactive_src_loc) 383 thing_inside 384 where 385 interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 386 387{- Note [Default types] 388~~~~~~~~~~~~~~~~~~~~~~~ 389The Integer type is simply not available in package ghc-prim (it is 390declared in integer-gmp). So we set the defaulting types to (Just 391[]), meaning there are no default types, rather then Nothing, which 392means "use the default default types of Integer, Double". 393 394If you don't do this, attempted defaulting in package ghc-prim causes 395an actual crash (attempting to look up the Integer type). 396 397 398************************************************************************ 399* * 400 Initialisation 401* * 402************************************************************************ 403-} 404 405initTcRnIf :: Char -- ^ Mask for unique supply 406 -> HscEnv 407 -> gbl -> lcl 408 -> TcRnIf gbl lcl a 409 -> IO a 410initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside 411 = do { let { env = Env { env_top = hsc_env, 412 env_um = uniq_mask, 413 env_gbl = gbl_env, 414 env_lcl = lcl_env} } 415 416 ; runIOEnv env thing_inside 417 } 418 419{- 420************************************************************************ 421* * 422 Simple accessors 423* * 424************************************************************************ 425-} 426 427discardResult :: TcM a -> TcM () 428discardResult a = a >> return () 429 430getTopEnv :: TcRnIf gbl lcl HscEnv 431getTopEnv = do { env <- getEnv; return (env_top env) } 432 433updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 434updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> 435 env { env_top = upd top }) 436 437getGblEnv :: TcRnIf gbl lcl gbl 438getGblEnv = do { Env{..} <- getEnv; return env_gbl } 439 440updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 441updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 442 env { env_gbl = upd gbl }) 443 444setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 445setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) 446 447getLclEnv :: TcRnIf gbl lcl lcl 448getLclEnv = do { Env{..} <- getEnv; return env_lcl } 449 450updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 451updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 452 env { env_lcl = upd lcl }) 453 454setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a 455setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) 456 457getEnvs :: TcRnIf gbl lcl (gbl, lcl) 458getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } 459 460setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a 461setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) 462 463-- Command-line flags 464 465xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool 466xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } 467 468doptM :: DumpFlag -> TcRnIf gbl lcl Bool 469doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } 470 471goptM :: GeneralFlag -> TcRnIf gbl lcl Bool 472goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } 473 474woptM :: WarningFlag -> TcRnIf gbl lcl Bool 475woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } 476 477setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 478setXOptM flag = 479 updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) 480 481unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 482unsetXOptM flag = 483 updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) 484 485unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 486unsetGOptM flag = 487 updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) 488 489unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a 490unsetWOptM flag = 491 updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) 492 493-- | Do it flag is true 494whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () 495whenDOptM flag thing_inside = do b <- doptM flag 496 when b thing_inside 497 498whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () 499whenGOptM flag thing_inside = do b <- goptM flag 500 when b thing_inside 501 502whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () 503whenWOptM flag thing_inside = do b <- woptM flag 504 when b thing_inside 505 506whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () 507whenXOptM flag thing_inside = do b <- xoptM flag 508 when b thing_inside 509 510unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () 511unlessXOptM flag thing_inside = do b <- xoptM flag 512 unless b thing_inside 513 514getGhcMode :: TcRnIf gbl lcl GhcMode 515getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } 516 517withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a 518withDoDynamicToo = 519 updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> 520 top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) 521 522getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) 523getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } 524 525getEps :: TcRnIf gbl lcl ExternalPackageState 526getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } 527 528-- | Update the external package state. Returns the second result of the 529-- modifier function. 530-- 531-- This is an atomic operation and forces evaluation of the modified EPS in 532-- order to avoid space leaks. 533updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) 534 -> TcRnIf gbl lcl a 535updateEps upd_fn = do 536 traceIf (text "updating EPS") 537 eps_var <- getEpsVar 538 atomicUpdMutVar' eps_var upd_fn 539 540-- | Update the external package state. 541-- 542-- This is an atomic operation and forces evaluation of the modified EPS in 543-- order to avoid space leaks. 544updateEps_ :: (ExternalPackageState -> ExternalPackageState) 545 -> TcRnIf gbl lcl () 546updateEps_ upd_fn = do 547 traceIf (text "updating EPS_") 548 eps_var <- getEpsVar 549 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) 550 551getHpt :: TcRnIf gbl lcl HomePackageTable 552getHpt = do { env <- getTopEnv; return (hsc_HPT env) } 553 554getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) 555getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) 556 ; return (eps, hsc_HPT env) } 557 558-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing 559-- an exception if it is an error. 560withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a 561withException do_this = do 562 r <- do_this 563 dflags <- getDynFlags 564 case r of 565 Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) 566 Succeeded result -> return result 567 568{- 569************************************************************************ 570* * 571 Arrow scopes 572* * 573************************************************************************ 574-} 575 576newArrowScope :: TcM a -> TcM a 577newArrowScope 578 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } 579 580-- Return to the stored environment (from the enclosing proc) 581escapeArrowScope :: TcM a -> TcM a 582escapeArrowScope 583 = updLclEnv $ \ env -> 584 case tcl_arrow_ctxt env of 585 NoArrowCtxt -> env 586 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt 587 , tcl_lie = lie 588 , tcl_rdr = rdr_env } 589 590{- 591************************************************************************ 592* * 593 Unique supply 594* * 595************************************************************************ 596-} 597 598newUnique :: TcRnIf gbl lcl Unique 599newUnique 600 = do { env <- getEnv 601 ; let mask = env_um env 602 ; liftIO $! uniqFromMask mask } 603 604newUniqueSupply :: TcRnIf gbl lcl UniqSupply 605newUniqueSupply 606 = do { env <- getEnv 607 ; let mask = env_um env 608 ; liftIO $! mkSplitUniqSupply mask } 609 610cloneLocalName :: Name -> TcM Name 611-- Make a fresh Internal name with the same OccName and SrcSpan 612cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) 613 614newName :: OccName -> TcM Name 615newName occ = do { loc <- getSrcSpanM 616 ; newNameAt occ loc } 617 618newNameAt :: OccName -> SrcSpan -> TcM Name 619newNameAt occ span 620 = do { uniq <- newUnique 621 ; return (mkInternalName uniq occ span) } 622 623newSysName :: OccName -> TcRnIf gbl lcl Name 624newSysName occ 625 = do { uniq <- newUnique 626 ; return (mkSystemName uniq occ) } 627 628newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId 629newSysLocalId fs ty 630 = do { u <- newUnique 631 ; return (mkSysLocalOrCoVar fs u ty) } 632 633newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] 634newSysLocalIds fs tys 635 = do { us <- newUniqueSupply 636 ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) } 637 638instance MonadUnique (IOEnv (Env gbl lcl)) where 639 getUniqueM = newUnique 640 getUniqueSupplyM = newUniqueSupply 641 642{- 643************************************************************************ 644* * 645 Accessing input/output 646* * 647************************************************************************ 648-} 649 650newTcRef :: a -> TcRnIf gbl lcl (TcRef a) 651newTcRef = newMutVar 652 653readTcRef :: TcRef a -> TcRnIf gbl lcl a 654readTcRef = readMutVar 655 656writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () 657writeTcRef = writeMutVar 658 659updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () 660-- Returns () 661updTcRef ref fn = liftIO $ do { old <- readIORef ref 662 ; writeIORef ref (fn old) } 663 664{- 665************************************************************************ 666* * 667 Debugging 668* * 669************************************************************************ 670-} 671 672 673-- Typechecker trace 674traceTc :: String -> SDoc -> TcRn () 675traceTc = 676 labelledTraceOptTcRn Opt_D_dump_tc_trace 677 678-- Renamer Trace 679traceRn :: String -> SDoc -> TcRn () 680traceRn = 681 labelledTraceOptTcRn Opt_D_dump_rn_trace 682 683-- | Trace when a certain flag is enabled. This is like `traceOptTcRn` 684-- but accepts a string as a label and formats the trace message uniformly. 685labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () 686labelledTraceOptTcRn flag herald doc = do 687 traceOptTcRn flag (formatTraceMsg herald doc) 688 689formatTraceMsg :: String -> SDoc -> SDoc 690formatTraceMsg herald doc = hang (text herald) 2 doc 691 692-- | Output a doc if the given 'DumpFlag' is set. 693-- 694-- By default this logs to stdout 695-- However, if the `-ddump-to-file` flag is set, 696-- then this will dump output to a file 697-- 698-- Just a wrapper for 'dumpSDoc' 699traceOptTcRn :: DumpFlag -> SDoc -> TcRn () 700traceOptTcRn flag doc 701 = do { dflags <- getDynFlags 702 ; when (dopt flag dflags) 703 (traceTcRn flag doc) 704 } 705 706-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the 707-- output generated by `-ddump-types` to be in 'PprUser' style. However, 708-- generally we want all other debugging output to use 'PprDump' 709-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this. 710 711-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style. 712traceTcRn :: DumpFlag -> SDoc -> TcRn () 713traceTcRn flag doc 714 = do { dflags <- getDynFlags 715 ; printer <- getPrintUnqualified dflags 716 ; let dump_style = mkDumpStyle dflags printer 717 ; traceTcRnWithStyle dump_style dflags flag doc } 718 719-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style. 720traceTcRnForUser :: DumpFlag -> SDoc -> TcRn () 721-- Used by 'TcRnDriver.tcDump'. 722traceTcRnForUser flag doc 723 = do { dflags <- getDynFlags 724 ; printer <- getPrintUnqualified dflags 725 ; let user_style = mkUserStyle dflags printer AllTheWay 726 ; traceTcRnWithStyle user_style dflags flag doc } 727 728traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn () 729-- ^ Unconditionally dump some trace output 730-- 731-- The DumpFlag is used only to set the output filename 732-- for --dump-to-file, not to decide whether or not to output 733-- That part is done by the caller 734traceTcRnWithStyle sty dflags flag doc 735 = do { real_doc <- prettyDoc dflags doc 736 ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc } 737 where 738 -- Add current location if -dppr-debug 739 prettyDoc :: DynFlags -> SDoc -> TcRn SDoc 740 prettyDoc dflags doc = if hasPprDebug dflags 741 then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } 742 else return doc -- The full location is usually way too much 743 744 745getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified 746getPrintUnqualified dflags 747 = do { rdr_env <- getGlobalRdrEnv 748 ; return $ mkPrintUnqualified dflags rdr_env } 749 750-- | Like logInfoTcRn, but for user consumption 751printForUserTcRn :: SDoc -> TcRn () 752printForUserTcRn doc 753 = do { dflags <- getDynFlags 754 ; printer <- getPrintUnqualified dflags 755 ; liftIO (printOutputForUser dflags printer doc) } 756 757{- 758traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is 759available. Alas, they behave inconsistently with the other stuff; 760e.g. are unaffected by -dump-to-file. 761-} 762 763traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () 764traceIf = traceOptIf Opt_D_dump_if_trace 765traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs 766 767 768traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () 769traceOptIf flag doc 770 = whenDOptM flag $ -- No RdrEnv available, so qualify everything 771 do { dflags <- getDynFlags 772 ; liftIO (putMsg dflags doc) } 773 774{- 775************************************************************************ 776* * 777 Typechecker global environment 778* * 779************************************************************************ 780-} 781 782getIsGHCi :: TcRn Bool 783getIsGHCi = do { mod <- getModule 784 ; return (isInteractiveModule mod) } 785 786getGHCiMonad :: TcRn Name 787getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } 788 789getInteractivePrintName :: TcRn Name 790getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } 791 792tcIsHsBootOrSig :: TcRn Bool 793tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } 794 795tcIsHsig :: TcRn Bool 796tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } 797 798tcSelfBootInfo :: TcRn SelfBootInfo 799tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } 800 801getGlobalRdrEnv :: TcRn GlobalRdrEnv 802getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } 803 804getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) 805getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } 806 807getImports :: TcRn ImportAvails 808getImports = do { env <- getGblEnv; return (tcg_imports env) } 809 810getFixityEnv :: TcRn FixityEnv 811getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } 812 813extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a 814extendFixityEnv new_bit 815 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 816 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) 817 818getRecFieldEnv :: TcRn RecFieldEnv 819getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } 820 821getDeclaredDefaultTys :: TcRn (Maybe [Type]) 822getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } 823 824addDependentFiles :: [FilePath] -> TcRn () 825addDependentFiles fs = do 826 ref <- fmap tcg_dependent_files getGblEnv 827 dep_files <- readTcRef ref 828 writeTcRef ref (fs ++ dep_files) 829 830{- 831************************************************************************ 832* * 833 Error management 834* * 835************************************************************************ 836-} 837 838getSrcSpanM :: TcRn SrcSpan 839 -- Avoid clash with Name.getSrcLoc 840getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } 841 842setSrcSpan :: SrcSpan -> TcRn a -> TcRn a 843setSrcSpan (RealSrcSpan real_loc) thing_inside 844 = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside 845-- Don't overwrite useful info with useless: 846setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside 847 848addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b 849addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a 850 851wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => 852 (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b 853-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) 854wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a 855 ; return (cL loc b) } 856wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => 857 (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) 858wrapLocFstM fn (dL->L loc a) = 859 setSrcSpan loc $ do 860 (b,c) <- fn a 861 return (cL loc b, c) 862 863wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => 864 (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) 865wrapLocSndM fn (dL->L loc a) = 866 setSrcSpan loc $ do 867 (b,c) <- fn a 868 return (b, cL loc c) 869 870wrapLocM_ :: HasSrcSpan a => 871 (SrcSpanLess a -> TcM ()) -> a -> TcM () 872wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) 873 874-- Reporting errors 875 876getErrsVar :: TcRn (TcRef Messages) 877getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } 878 879setErrsVar :: TcRef Messages -> TcRn a -> TcRn a 880setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) 881 882addErr :: MsgDoc -> TcRn () 883addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } 884 885failWith :: MsgDoc -> TcRn a 886failWith msg = addErr msg >> failM 887 888failAt :: SrcSpan -> MsgDoc -> TcRn a 889failAt loc msg = addErrAt loc msg >> failM 890 891addErrAt :: SrcSpan -> MsgDoc -> TcRn () 892-- addErrAt is mainly (exclusively?) used by the renamer, where 893-- tidying is not an issue, but it's all lazy so the extra 894-- work doesn't matter 895addErrAt loc msg = do { ctxt <- getErrCtxt 896 ; tidy_env <- tcInitTidyEnv 897 ; err_info <- mkErrInfo tidy_env ctxt 898 ; addLongErrAt loc msg err_info } 899 900addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () 901addErrs msgs = mapM_ add msgs 902 where 903 add (loc,msg) = addErrAt loc msg 904 905checkErr :: Bool -> MsgDoc -> TcRn () 906-- Add the error if the bool is False 907checkErr ok msg = unless ok (addErr msg) 908 909addMessages :: Messages -> TcRn () 910addMessages msgs1 911 = do { errs_var <- getErrsVar ; 912 msgs0 <- readTcRef errs_var ; 913 writeTcRef errs_var (unionMessages msgs0 msgs1) } 914 915discardWarnings :: TcRn a -> TcRn a 916-- Ignore warnings inside the thing inside; 917-- used to ignore-unused-variable warnings inside derived code 918discardWarnings thing_inside 919 = do { errs_var <- getErrsVar 920 ; (old_warns, _) <- readTcRef errs_var 921 922 ; result <- thing_inside 923 924 -- Revert warnings to old_warns 925 ; (_new_warns, new_errs) <- readTcRef errs_var 926 ; writeTcRef errs_var (old_warns, new_errs) 927 928 ; return result } 929 930{- 931************************************************************************ 932* * 933 Shared error message stuff: renamer and typechecker 934* * 935************************************************************************ 936-} 937 938mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg 939mkLongErrAt loc msg extra 940 = do { dflags <- getDynFlags ; 941 printer <- getPrintUnqualified dflags ; 942 return $ mkLongErrMsg dflags loc printer msg extra } 943 944mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg 945mkErrDocAt loc errDoc 946 = do { dflags <- getDynFlags ; 947 printer <- getPrintUnqualified dflags ; 948 return $ mkErrDoc dflags loc printer errDoc } 949 950addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () 951addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError 952 953reportErrors :: [ErrMsg] -> TcM () 954reportErrors = mapM_ reportError 955 956reportError :: ErrMsg -> TcRn () 957reportError err 958 = do { traceTc "Adding error:" (pprLocErrMsg err) ; 959 errs_var <- getErrsVar ; 960 (warns, errs) <- readTcRef errs_var ; 961 writeTcRef errs_var (warns, errs `snocBag` err) } 962 963reportWarning :: WarnReason -> ErrMsg -> TcRn () 964reportWarning reason err 965 = do { let warn = makeIntoWarning reason err 966 -- 'err' was built by mkLongErrMsg or something like that, 967 -- so it's of error severity. For a warning we downgrade 968 -- its severity to SevWarning 969 970 ; traceTc "Adding warning:" (pprLocErrMsg warn) 971 ; errs_var <- getErrsVar 972 ; (warns, errs) <- readTcRef errs_var 973 ; writeTcRef errs_var (warns `snocBag` warn, errs) } 974 975 976----------------------- 977checkNoErrs :: TcM r -> TcM r 978-- (checkNoErrs m) succeeds iff m succeeds and generates no errors 979-- If m fails then (checkNoErrsTc m) fails. 980-- If m succeeds, it checks whether m generated any errors messages 981-- (it might have recovered internally) 982-- If so, it fails too. 983-- Regardless, any errors generated by m are propagated to the enclosing context. 984checkNoErrs main 985 = do { (res, no_errs) <- askNoErrs main 986 ; unless no_errs failM 987 ; return res } 988 989----------------------- 990whenNoErrs :: TcM () -> TcM () 991whenNoErrs thing = ifErrsM (return ()) thing 992 993ifErrsM :: TcRn r -> TcRn r -> TcRn r 994-- ifErrsM bale_out normal 995-- does 'bale_out' if there are errors in errors collection 996-- otherwise does 'normal' 997ifErrsM bale_out normal 998 = do { errs_var <- getErrsVar ; 999 msgs <- readTcRef errs_var ; 1000 dflags <- getDynFlags ; 1001 if errorsFound dflags msgs then 1002 bale_out 1003 else 1004 normal } 1005 1006failIfErrsM :: TcRn () 1007-- Useful to avoid error cascades 1008failIfErrsM = ifErrsM failM (return ()) 1009 1010{- ********************************************************************* 1011* * 1012 Context management for the type checker 1013* * 1014************************************************************************ 1015-} 1016 1017getErrCtxt :: TcM [ErrCtxt] 1018getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } 1019 1020setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a 1021setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) 1022 1023-- | Add a fixed message to the error context. This message should not 1024-- do any tidying. 1025addErrCtxt :: MsgDoc -> TcM a -> TcM a 1026addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) 1027 1028-- | Add a message to the error context. This message may do tidying. 1029addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a 1030addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) 1031 1032-- | Add a fixed landmark message to the error context. A landmark 1033-- message is always sure to be reported, even if there is a lot of 1034-- context. It also doesn't count toward the maximum number of contexts 1035-- reported. 1036addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a 1037addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) 1038 1039-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations 1040-- and tidying. 1041addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a 1042addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) 1043 1044-- Helper function for the above 1045updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a 1046updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 1047 env { tcl_ctxt = upd ctxt }) 1048 1049popErrCtxt :: TcM a -> TcM a 1050popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) 1051 1052getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc 1053getCtLocM origin t_or_k 1054 = do { env <- getLclEnv 1055 ; return (CtLoc { ctl_origin = origin 1056 , ctl_env = env 1057 , ctl_t_or_k = t_or_k 1058 , ctl_depth = initialSubGoalDepth }) } 1059 1060setCtLocM :: CtLoc -> TcM a -> TcM a 1061-- Set the SrcSpan and error context from the CtLoc 1062setCtLocM (CtLoc { ctl_env = lcl }) thing_inside 1063 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl 1064 , tcl_bndrs = tcl_bndrs lcl 1065 , tcl_ctxt = tcl_ctxt lcl }) 1066 thing_inside 1067 1068 1069{- ********************************************************************* 1070* * 1071 Error recovery and exceptions 1072* * 1073********************************************************************* -} 1074 1075tcTryM :: TcRn r -> TcRn (Maybe r) 1076-- The most basic function: catch the exception 1077-- Nothing => an exception happened 1078-- Just r => no exception, result R 1079-- Errors and constraints are propagated in both cases 1080-- Never throws an exception 1081tcTryM thing_inside 1082 = do { either_res <- tryM thing_inside 1083 ; return (case either_res of 1084 Left _ -> Nothing 1085 Right r -> Just r) } 1086 -- In the Left case the exception is always the IOEnv 1087 -- built-in in exception; see IOEnv.failM 1088 1089----------------------- 1090capture_constraints :: TcM r -> TcM (r, WantedConstraints) 1091-- capture_constraints simply captures and returns the 1092-- constraints generated by thing_inside 1093-- Precondition: thing_inside must not throw an exception! 1094-- Reason for precondition: an exception would blow past the place 1095-- where we read the lie_var, and we'd lose the constraints altogether 1096capture_constraints thing_inside 1097 = do { lie_var <- newTcRef emptyWC 1098 ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ 1099 thing_inside 1100 ; lie <- readTcRef lie_var 1101 ; return (res, lie) } 1102 1103capture_messages :: TcM r -> TcM (r, Messages) 1104-- capture_messages simply captures and returns the 1105-- errors arnd warnings generated by thing_inside 1106-- Precondition: thing_inside must not throw an exception! 1107-- Reason for precondition: an exception would blow past the place 1108-- where we read the msg_var, and we'd lose the constraints altogether 1109capture_messages thing_inside 1110 = do { msg_var <- newTcRef emptyMessages 1111 ; res <- setErrsVar msg_var thing_inside 1112 ; msgs <- readTcRef msg_var 1113 ; return (res, msgs) } 1114 1115----------------------- 1116-- (askNoErrs m) runs m 1117-- If m fails, 1118-- then (askNoErrs m) fails, propagating only 1119-- insoluble constraints 1120-- 1121-- If m succeeds with result r, 1122-- then (askNoErrs m) succeeds with result (r, b), 1123-- where b is True iff m generated no errors 1124-- 1125-- Regardless of success or failure, 1126-- propagate any errors/warnings generated by m 1127askNoErrs :: TcRn a -> TcRn (a, Bool) 1128askNoErrs thing_inside 1129 = do { ((mb_res, lie), msgs) <- capture_messages $ 1130 capture_constraints $ 1131 tcTryM thing_inside 1132 ; addMessages msgs 1133 1134 ; case mb_res of 1135 Nothing -> do { emitConstraints (insolublesOnly lie) 1136 ; failM } 1137 1138 Just res -> do { emitConstraints lie 1139 ; dflags <- getDynFlags 1140 ; let errs_found = errorsFound dflags msgs 1141 || insolubleWC lie 1142 ; return (res, not errs_found) } } 1143 1144----------------------- 1145tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) 1146-- (tryCaptureConstraints_maybe m) runs m, 1147-- and returns the type constraints it generates 1148-- It never throws an exception; instead if thing_inside fails, 1149-- it returns Nothing and the /insoluble/ constraints 1150-- Error messages are propagated 1151tryCaptureConstraints thing_inside 1152 = do { (mb_res, lie) <- capture_constraints $ 1153 tcTryM thing_inside 1154 1155 -- See Note [Constraints and errors] 1156 ; let lie_to_keep = case mb_res of 1157 Nothing -> insolublesOnly lie 1158 Just {} -> lie 1159 1160 ; return (mb_res, lie_to_keep) } 1161 1162captureConstraints :: TcM a -> TcM (a, WantedConstraints) 1163-- (captureConstraints m) runs m, and returns the type constraints it generates 1164-- If thing_inside fails (throwing an exception), 1165-- then (captureConstraints thing_inside) fails too 1166-- propagating the insoluble constraints only 1167-- Error messages are propagated in either case 1168captureConstraints thing_inside 1169 = do { (mb_res, lie) <- tryCaptureConstraints thing_inside 1170 1171 -- See Note [Constraints and errors] 1172 -- If the thing_inside threw an exception, emit the insoluble 1173 -- constraints only (returned by tryCaptureConstraints) 1174 -- so that they are not lost 1175 ; case mb_res of 1176 Nothing -> do { emitConstraints lie; failM } 1177 Just res -> return (res, lie) } 1178 1179----------------------- 1180attemptM :: TcRn r -> TcRn (Maybe r) 1181-- (attemptM thing_inside) runs thing_inside 1182-- If thing_inside succeeds, returning r, 1183-- we return (Just r), and propagate all constraints and errors 1184-- If thing_inside fail, throwing an exception, 1185-- we return Nothing, propagating insoluble constraints, 1186-- and all errors 1187-- attemptM never throws an exception 1188attemptM thing_inside 1189 = do { (mb_r, lie) <- tryCaptureConstraints thing_inside 1190 ; emitConstraints lie 1191 1192 -- Debug trace 1193 ; when (isNothing mb_r) $ 1194 traceTc "attemptM recovering with insoluble constraints" $ 1195 (ppr lie) 1196 1197 ; return mb_r } 1198 1199----------------------- 1200recoverM :: TcRn r -- Recovery action; do this if the main one fails 1201 -> TcRn r -- Main action: do this first; 1202 -- if it generates errors, propagate them all 1203 -> TcRn r 1204-- (recoverM recover thing_inside) runs thing_inside 1205-- If thing_inside fails, propagate its errors and insoluble constraints 1206-- and run 'recover' 1207-- If thing_inside succeeds, propagate all its errors and constraints 1208-- 1209-- Can fail, if 'recover' fails 1210recoverM recover thing 1211 = do { mb_res <- attemptM thing ; 1212 case mb_res of 1213 Nothing -> recover 1214 Just res -> return res } 1215 1216----------------------- 1217 1218-- | Drop elements of the input that fail, so the result 1219-- list can be shorter than the argument list 1220mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] 1221mapAndRecoverM f xs 1222 = do { mb_rs <- mapM (attemptM . f) xs 1223 ; return [r | Just r <- mb_rs] } 1224 1225-- | Apply the function to all elements on the input list 1226-- If all succeed, return the list of results 1227-- Othewise fail, propagating all errors 1228mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] 1229mapAndReportM f xs 1230 = do { mb_rs <- mapM (attemptM . f) xs 1231 ; when (any isNothing mb_rs) failM 1232 ; return [r | Just r <- mb_rs] } 1233 1234-- | The accumulator is not updated if the action fails 1235foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b 1236foldAndRecoverM _ acc [] = return acc 1237foldAndRecoverM f acc (x:xs) = 1238 do { mb_r <- attemptM (f acc x) 1239 ; case mb_r of 1240 Nothing -> foldAndRecoverM f acc xs 1241 Just acc' -> foldAndRecoverM f acc' xs } 1242 1243----------------------- 1244tryTc :: TcRn a -> TcRn (Maybe a, Messages) 1245-- (tryTc m) executes m, and returns 1246-- Just r, if m succeeds (returning r) 1247-- Nothing, if m fails 1248-- It also returns all the errors and warnings accumulated by m 1249-- It always succeeds (never raises an exception) 1250tryTc thing_inside 1251 = capture_messages (attemptM thing_inside) 1252 1253----------------------- 1254discardErrs :: TcRn a -> TcRn a 1255-- (discardErrs m) runs m, 1256-- discarding all error messages and warnings generated by m 1257-- If m fails, discardErrs fails, and vice versa 1258discardErrs m 1259 = do { errs_var <- newTcRef emptyMessages 1260 ; setErrsVar errs_var m } 1261 1262----------------------- 1263tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r 1264-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; 1265-- if 'main' succeeds with no error messages, it's the answer 1266-- otherwise discard everything from 'main', including errors, 1267-- and try 'recover' instead. 1268tryTcDiscardingErrs recover thing_inside 1269 = do { ((mb_res, lie), msgs) <- capture_messages $ 1270 capture_constraints $ 1271 tcTryM thing_inside 1272 ; dflags <- getDynFlags 1273 ; case mb_res of 1274 Just res | not (errorsFound dflags msgs) 1275 , not (insolubleWC lie) 1276 -> -- 'main' succeeed with no errors 1277 do { addMessages msgs -- msgs might still have warnings 1278 ; emitConstraints lie 1279 ; return res } 1280 1281 _ -> -- 'main' failed, or produced an error message 1282 recover -- Discard all errors and warnings 1283 -- and unsolved constraints entirely 1284 } 1285 1286{- 1287************************************************************************ 1288* * 1289 Error message generation (type checker) 1290* * 1291************************************************************************ 1292 1293 The addErrTc functions add an error message, but do not cause failure. 1294 The 'M' variants pass a TidyEnv that has already been used to 1295 tidy up the message; we then use it to tidy the context messages 1296-} 1297 1298addErrTc :: MsgDoc -> TcM () 1299addErrTc err_msg = do { env0 <- tcInitTidyEnv 1300 ; addErrTcM (env0, err_msg) } 1301 1302addErrsTc :: [MsgDoc] -> TcM () 1303addErrsTc err_msgs = mapM_ addErrTc err_msgs 1304 1305addErrTcM :: (TidyEnv, MsgDoc) -> TcM () 1306addErrTcM (tidy_env, err_msg) 1307 = do { ctxt <- getErrCtxt ; 1308 loc <- getSrcSpanM ; 1309 add_err_tcm tidy_env err_msg loc ctxt } 1310 1311-- Return the error message, instead of reporting it straight away 1312mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg 1313mkErrTcM (tidy_env, err_msg) 1314 = do { ctxt <- getErrCtxt ; 1315 loc <- getSrcSpanM ; 1316 err_info <- mkErrInfo tidy_env ctxt ; 1317 mkLongErrAt loc err_msg err_info } 1318 1319mkErrTc :: MsgDoc -> TcM ErrMsg 1320mkErrTc msg = do { env0 <- tcInitTidyEnv 1321 ; mkErrTcM (env0, msg) } 1322 1323-- The failWith functions add an error message and cause failure 1324 1325failWithTc :: MsgDoc -> TcM a -- Add an error message and fail 1326failWithTc err_msg 1327 = addErrTc err_msg >> failM 1328 1329failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail 1330failWithTcM local_and_msg 1331 = addErrTcM local_and_msg >> failM 1332 1333checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true 1334checkTc True _ = return () 1335checkTc False err = failWithTc err 1336 1337checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () 1338checkTcM True _ = return () 1339checkTcM False err = failWithTcM err 1340 1341failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false 1342failIfTc False _ = return () 1343failIfTc True err = failWithTc err 1344 1345failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () 1346 -- Check that the boolean is false 1347failIfTcM False _ = return () 1348failIfTcM True err = failWithTcM err 1349 1350 1351-- Warnings have no 'M' variant, nor failure 1352 1353-- | Display a warning if a condition is met, 1354-- and the warning is enabled 1355warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () 1356warnIfFlag warn_flag is_bad msg 1357 = do { warn_on <- woptM warn_flag 1358 ; when (warn_on && is_bad) $ 1359 addWarn (Reason warn_flag) msg } 1360 1361-- | Display a warning if a condition is met. 1362warnIf :: Bool -> MsgDoc -> TcRn () 1363warnIf is_bad msg 1364 = when is_bad (addWarn NoReason msg) 1365 1366-- | Display a warning if a condition is met. 1367warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () 1368warnTc reason warn_if_true warn_msg 1369 | warn_if_true = addWarnTc reason warn_msg 1370 | otherwise = return () 1371 1372-- | Display a warning if a condition is met. 1373warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () 1374warnTcM reason warn_if_true warn_msg 1375 | warn_if_true = addWarnTcM reason warn_msg 1376 | otherwise = return () 1377 1378-- | Display a warning in the current context. 1379addWarnTc :: WarnReason -> MsgDoc -> TcM () 1380addWarnTc reason msg 1381 = do { env0 <- tcInitTidyEnv ; 1382 addWarnTcM reason (env0, msg) } 1383 1384-- | Display a warning in a given context. 1385addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () 1386addWarnTcM reason (env0, msg) 1387 = do { ctxt <- getErrCtxt ; 1388 err_info <- mkErrInfo env0 ctxt ; 1389 add_warn reason msg err_info } 1390 1391-- | Display a warning for the current source location. 1392addWarn :: WarnReason -> MsgDoc -> TcRn () 1393addWarn reason msg = add_warn reason msg Outputable.empty 1394 1395-- | Display a warning for a given source location. 1396addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () 1397addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty 1398 1399-- | Display a warning, with an optional flag, for the current source 1400-- location. 1401add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () 1402add_warn reason msg extra_info 1403 = do { loc <- getSrcSpanM 1404 ; add_warn_at reason loc msg extra_info } 1405 1406-- | Display a warning, with an optional flag, for a given location. 1407add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () 1408add_warn_at reason loc msg extra_info 1409 = do { dflags <- getDynFlags ; 1410 printer <- getPrintUnqualified dflags ; 1411 let { warn = mkLongWarnMsg dflags loc printer 1412 msg extra_info } ; 1413 reportWarning reason warn } 1414 1415 1416{- 1417----------------------------------- 1418 Other helper functions 1419-} 1420 1421add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan 1422 -> [ErrCtxt] 1423 -> TcM () 1424add_err_tcm tidy_env err_msg loc ctxt 1425 = do { err_info <- mkErrInfo tidy_env ctxt ; 1426 addLongErrAt loc err_msg err_info } 1427 1428mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc 1429-- Tidy the error info, trimming excessive contexts 1430mkErrInfo env ctxts 1431-- = do 1432-- dbg <- hasPprDebug <$> getDynFlags 1433-- if dbg -- In -dppr-debug style the output 1434-- then return empty -- just becomes too voluminous 1435-- else go dbg 0 env ctxts 1436 = go False 0 env ctxts 1437 where 1438 go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc 1439 go _ _ _ [] = return empty 1440 go dbg n env ((is_landmark, ctxt) : ctxts) 1441 | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg 1442 = do { (env', msg) <- ctxt env 1443 ; let n' = if is_landmark then n else n+1 1444 ; rest <- go dbg n' env' ctxts 1445 ; return (msg $$ rest) } 1446 | otherwise 1447 = go dbg n env ctxts 1448 1449mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts 1450mAX_CONTEXTS = 3 1451 1452-- debugTc is useful for monadic debugging code 1453 1454debugTc :: TcM () -> TcM () 1455debugTc thing 1456 | debugIsOn = thing 1457 | otherwise = return () 1458 1459{- 1460************************************************************************ 1461* * 1462 Type constraints 1463* * 1464************************************************************************ 1465-} 1466 1467addTopEvBinds :: Bag EvBind -> TcM a -> TcM a 1468addTopEvBinds new_ev_binds thing_inside 1469 =updGblEnv upd_env thing_inside 1470 where 1471 upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env 1472 `unionBags` new_ev_binds } 1473 1474newTcEvBinds :: TcM EvBindsVar 1475newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap 1476 ; tcvs_ref <- newTcRef emptyVarSet 1477 ; uniq <- newUnique 1478 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) 1479 ; return (EvBindsVar { ebv_binds = binds_ref 1480 , ebv_tcvs = tcvs_ref 1481 , ebv_uniq = uniq }) } 1482 1483-- | Creates an EvBindsVar incapable of holding any bindings. It still 1484-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus 1485-- must be made monadically 1486newNoTcEvBinds :: TcM EvBindsVar 1487newNoTcEvBinds 1488 = do { tcvs_ref <- newTcRef emptyVarSet 1489 ; uniq <- newUnique 1490 ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) 1491 ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref 1492 , ebv_uniq = uniq }) } 1493 1494cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar 1495-- Clone the refs, so that any binding created when 1496-- solving don't pollute the original 1497cloneEvBindsVar ebv@(EvBindsVar {}) 1498 = do { binds_ref <- newTcRef emptyEvBindMap 1499 ; tcvs_ref <- newTcRef emptyVarSet 1500 ; return (ebv { ebv_binds = binds_ref 1501 , ebv_tcvs = tcvs_ref }) } 1502cloneEvBindsVar ebv@(CoEvBindsVar {}) 1503 = do { tcvs_ref <- newTcRef emptyVarSet 1504 ; return (ebv { ebv_tcvs = tcvs_ref }) } 1505 1506getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet 1507getTcEvTyCoVars ev_binds_var 1508 = readTcRef (ebv_tcvs ev_binds_var) 1509 1510getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap 1511getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) 1512 = readTcRef ev_ref 1513getTcEvBindsMap (CoEvBindsVar {}) 1514 = return emptyEvBindMap 1515 1516setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () 1517setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds 1518 = writeTcRef ev_ref binds 1519setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds 1520 | isEmptyEvBindMap ev_binds 1521 = return () 1522 | otherwise 1523 = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) 1524 1525addTcEvBind :: EvBindsVar -> EvBind -> TcM () 1526-- Add a binding to the TcEvBinds by side effect 1527addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind 1528 = do { traceTc "addTcEvBind" $ ppr u $$ 1529 ppr ev_bind 1530 ; bnds <- readTcRef ev_ref 1531 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } 1532addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind 1533 = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) 1534 1535chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName 1536chooseUniqueOccTc fn = 1537 do { env <- getGblEnv 1538 ; let dfun_n_var = tcg_dfun_n env 1539 ; set <- readTcRef dfun_n_var 1540 ; let occ = fn set 1541 ; writeTcRef dfun_n_var (extendOccSet set occ) 1542 ; return occ } 1543 1544getConstraintVar :: TcM (TcRef WantedConstraints) 1545getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } 1546 1547setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a 1548setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) 1549 1550emitStaticConstraints :: WantedConstraints -> TcM () 1551emitStaticConstraints static_lie 1552 = do { gbl_env <- getGblEnv 1553 ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } 1554 1555emitConstraints :: WantedConstraints -> TcM () 1556emitConstraints ct 1557 | isEmptyWC ct 1558 = return () 1559 | otherwise 1560 = do { lie_var <- getConstraintVar ; 1561 updTcRef lie_var (`andWC` ct) } 1562 1563emitSimple :: Ct -> TcM () 1564emitSimple ct 1565 = do { lie_var <- getConstraintVar ; 1566 updTcRef lie_var (`addSimples` unitBag ct) } 1567 1568emitSimples :: Cts -> TcM () 1569emitSimples cts 1570 = do { lie_var <- getConstraintVar ; 1571 updTcRef lie_var (`addSimples` cts) } 1572 1573emitImplication :: Implication -> TcM () 1574emitImplication ct 1575 = do { lie_var <- getConstraintVar ; 1576 updTcRef lie_var (`addImplics` unitBag ct) } 1577 1578emitImplications :: Bag Implication -> TcM () 1579emitImplications ct 1580 = unless (isEmptyBag ct) $ 1581 do { lie_var <- getConstraintVar ; 1582 updTcRef lie_var (`addImplics` ct) } 1583 1584emitInsoluble :: Ct -> TcM () 1585emitInsoluble ct 1586 = do { traceTc "emitInsoluble" (ppr ct) 1587 ; lie_var <- getConstraintVar 1588 ; updTcRef lie_var (`addInsols` unitBag ct) } 1589 1590emitInsolubles :: Cts -> TcM () 1591emitInsolubles cts 1592 | isEmptyBag cts = return () 1593 | otherwise = do { traceTc "emitInsolubles" (ppr cts) 1594 ; lie_var <- getConstraintVar 1595 ; updTcRef lie_var (`addInsols` cts) } 1596 1597-- | Throw out any constraints emitted by the thing_inside 1598discardConstraints :: TcM a -> TcM a 1599discardConstraints thing_inside = fst <$> captureConstraints thing_inside 1600 1601-- | The name says it all. The returned TcLevel is the *inner* TcLevel. 1602pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) 1603pushLevelAndCaptureConstraints thing_inside 1604 = do { env <- getLclEnv 1605 ; let tclvl' = pushTcLevel (tcl_tclvl env) 1606 ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') 1607 ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ 1608 captureConstraints thing_inside 1609 ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') 1610 ; return (tclvl', lie, res) } 1611 1612pushTcLevelM_ :: TcM a -> TcM a 1613pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x 1614 1615pushTcLevelM :: TcM a -> TcM (TcLevel, a) 1616-- See Note [TcLevel assignment] in TcType 1617pushTcLevelM thing_inside 1618 = do { env <- getLclEnv 1619 ; let tclvl' = pushTcLevel (tcl_tclvl env) 1620 ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) 1621 thing_inside 1622 ; return (tclvl', res) } 1623 1624-- Returns pushed TcLevel 1625pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) 1626pushTcLevelsM num_levels thing_inside 1627 = do { env <- getLclEnv 1628 ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) 1629 ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ 1630 thing_inside 1631 ; return (res, tclvl') } 1632 1633getTcLevel :: TcM TcLevel 1634getTcLevel = do { env <- getLclEnv 1635 ; return (tcl_tclvl env) } 1636 1637setTcLevel :: TcLevel -> TcM a -> TcM a 1638setTcLevel tclvl thing_inside 1639 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside 1640 1641isTouchableTcM :: TcTyVar -> TcM Bool 1642isTouchableTcM tv 1643 = do { lvl <- getTcLevel 1644 ; return (isTouchableMetaTyVar lvl tv) } 1645 1646getLclTypeEnv :: TcM TcTypeEnv 1647getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } 1648 1649setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a 1650-- Set the local type envt, but do *not* disturb other fields, 1651-- notably the lie_var 1652setLclTypeEnv lcl_env thing_inside 1653 = updLclEnv upd thing_inside 1654 where 1655 upd env = env { tcl_env = tcl_env lcl_env } 1656 1657traceTcConstraints :: String -> TcM () 1658traceTcConstraints msg 1659 = do { lie_var <- getConstraintVar 1660 ; lie <- readTcRef lie_var 1661 ; traceOptTcRn Opt_D_dump_tc_trace $ 1662 hang (text (msg ++ ": LIE:")) 2 (ppr lie) 1663 } 1664 1665emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () 1666emitAnonWildCardHoleConstraint tv 1667 = do { ct_loc <- getCtLocM HoleOrigin Nothing 1668 ; emitInsolubles $ unitBag $ 1669 CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv 1670 , ctev_loc = ct_loc } 1671 , cc_hole = TypeHole (mkTyVarOcc "_") } } 1672 1673emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () 1674emitNamedWildCardHoleConstraints wcs 1675 = do { ct_loc <- getCtLocM HoleOrigin Nothing 1676 ; emitInsolubles $ listToBag $ 1677 map (do_one ct_loc) wcs } 1678 where 1679 do_one :: CtLoc -> (Name, TcTyVar) -> Ct 1680 do_one ct_loc (name, tv) 1681 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv 1682 , ctev_loc = ct_loc' } 1683 , cc_hole = TypeHole (occName name) } 1684 where 1685 real_span = case nameSrcSpan name of 1686 RealSrcSpan span -> span 1687 UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" 1688 (ppr name <+> quotes (ftext str)) 1689 -- Wildcards are defined locally, and so have RealSrcSpans 1690 ct_loc' = setCtLocSpan ct_loc real_span 1691 1692{- Note [Constraints and errors] 1693~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1694Consider this (#12124): 1695 1696 foo :: Maybe Int 1697 foo = return (case Left 3 of 1698 Left -> 1 -- Hard error here! 1699 _ -> 0) 1700 1701The call to 'return' will generate a (Monad m) wanted constraint; but 1702then there'll be "hard error" (i.e. an exception in the TcM monad), from 1703the unsaturated Left constructor pattern. 1704 1705We'll recover in tcPolyBinds, using recoverM. But then the final 1706tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly 1707un-filled-in, and will emit a misleading error message. 1708 1709The underlying problem is that an exception interrupts the constraint 1710gathering process. Bottom line: if we have an exception, it's best 1711simply to discard any gathered constraints. Hence in 'attemptM' we 1712capture the constraints in a fresh variable, and only emit them into 1713the surrounding context if we exit normally. If an exception is 1714raised, simply discard the collected constraints... we have a hard 1715error to report. So this capture-the-emit dance isn't as stupid as it 1716looks :-). 1717 1718However suppose we throw an exception inside an invocation of 1719captureConstraints, and discard all the constraints. Some of those 1720constraints might be "variable out of scope" Hole constraints, and that 1721might have been the actual original cause of the exception! For 1722example (#12529): 1723 f = p @ Int 1724Here 'p' is out of scope, so we get an insolube Hole constraint. But 1725the visible type application fails in the monad (thows an exception). 1726We must not discard the out-of-scope error. 1727 1728So we /retain the insoluble constraints/ if there is an exception. 1729Hence: 1730 - insolublesOnly in tryCaptureConstraints 1731 - emitConstraints in the Left case of captureConstraints 1732 1733However note that freshly-generated constraints like (Int ~ Bool), or 1734((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as 1735insoluble. The constraint solver does that. So they'll be discarded. 1736That's probably ok; but see th/5358 as a not-so-good example: 1737 t1 :: Int 1738 t1 x = x -- Manifestly wrong 1739 1740 foo = $(...raises exception...) 1741We report the exception, but not the bug in t1. Oh well. Possible 1742solution: make TcUnify.uType spot manifestly-insoluble constraints. 1743 1744 1745************************************************************************ 1746* * 1747 Template Haskell context 1748* * 1749************************************************************************ 1750-} 1751 1752recordThUse :: TcM () 1753recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } 1754 1755recordThSpliceUse :: TcM () 1756recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } 1757 1758-- | When generating an out-of-scope error message for a variable matching a 1759-- binding in a later inter-splice group, the typechecker uses the splice 1760-- locations to provide details in the message about the scope of that binding. 1761recordTopLevelSpliceLoc :: SrcSpan -> TcM () 1762recordTopLevelSpliceLoc (RealSrcSpan real_loc) 1763 = do { env <- getGblEnv 1764 ; let locs_var = tcg_th_top_level_locs env 1765 ; locs0 <- readTcRef locs_var 1766 ; writeTcRef locs_var (Set.insert real_loc locs0) } 1767recordTopLevelSpliceLoc (UnhelpfulSpan _) = return () 1768 1769getTopLevelSpliceLocs :: TcM (Set RealSrcSpan) 1770getTopLevelSpliceLocs 1771 = do { env <- getGblEnv 1772 ; readTcRef (tcg_th_top_level_locs env) } 1773 1774keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set 1775keepAlive name 1776 = do { env <- getGblEnv 1777 ; traceRn "keep alive" (ppr name) 1778 ; updTcRef (tcg_keep env) (`extendNameSet` name) } 1779 1780getStage :: TcM ThStage 1781getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } 1782 1783getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) 1784getStageAndBindLevel name 1785 = do { env <- getLclEnv; 1786 ; case lookupNameEnv (tcl_th_bndrs env) name of 1787 Nothing -> return Nothing 1788 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } 1789 1790setStage :: ThStage -> TcM a -> TcRn a 1791setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) 1792 1793-- | Adds the given modFinalizers to the global environment and set them to use 1794-- the current local environment. 1795addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () 1796addModFinalizersWithLclEnv mod_finalizers 1797 = do lcl_env <- getLclEnv 1798 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv 1799 updTcRef th_modfinalizers_var $ \fins -> 1800 (lcl_env, mod_finalizers) : fins 1801 1802{- 1803************************************************************************ 1804* * 1805 Safe Haskell context 1806* * 1807************************************************************************ 1808-} 1809 1810-- | Mark that safe inference has failed 1811-- See Note [Safe Haskell Overlapping Instances Implementation] 1812-- although this is used for more than just that failure case. 1813recordUnsafeInfer :: WarningMessages -> TcM () 1814recordUnsafeInfer warns = 1815 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) 1816 1817-- | Figure out the final correct safe haskell mode 1818finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode 1819finalSafeMode dflags tcg_env = do 1820 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) 1821 return $ case safeHaskell dflags of 1822 Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred 1823 | otherwise -> Sf_None 1824 s -> s 1825 1826-- | Switch instances to safe instances if we're in Safe mode. 1827fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] 1828fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id 1829fixSafeInstances _ = map fixSafe 1830 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } 1831 in inst { is_flag = new_flag } 1832 1833{- 1834************************************************************************ 1835* * 1836 Stuff for the renamer's local env 1837* * 1838************************************************************************ 1839-} 1840 1841getLocalRdrEnv :: RnM LocalRdrEnv 1842getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } 1843 1844setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a 1845setLocalRdrEnv rdr_env thing_inside 1846 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside 1847 1848{- 1849************************************************************************ 1850* * 1851 Stuff for interface decls 1852* * 1853************************************************************************ 1854-} 1855 1856mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv 1857mkIfLclEnv mod loc boot 1858 = IfLclEnv { if_mod = mod, 1859 if_loc = loc, 1860 if_boot = boot, 1861 if_nsubst = Nothing, 1862 if_implicits_env = Nothing, 1863 if_tv_env = emptyFsEnv, 1864 if_id_env = emptyFsEnv } 1865 1866-- | Run an 'IfG' (top-level interface monad) computation inside an existing 1867-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' 1868-- based on 'TcGblEnv'. 1869initIfaceTcRn :: IfG a -> TcRn a 1870initIfaceTcRn thing_inside 1871 = do { tcg_env <- getGblEnv 1872 ; dflags <- getDynFlags 1873 ; let !mod = tcg_semantic_mod tcg_env 1874 -- When we are instantiating a signature, we DEFINITELY 1875 -- do not want to knot tie. 1876 is_instantiate = unitIdIsDefinite (thisPackage dflags) && 1877 not (null (thisUnitIdInsts dflags)) 1878 ; let { if_env = IfGblEnv { 1879 if_doc = text "initIfaceTcRn", 1880 if_rec_types = 1881 if is_instantiate 1882 then Nothing 1883 else Just (mod, get_type_env) 1884 } 1885 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } 1886 ; setEnvs (if_env, ()) thing_inside } 1887 1888-- Used when sucking in a ModIface into a ModDetails to put in 1889-- the HPT. Notably, unlike initIfaceCheck, this does NOT use 1890-- hsc_type_env_var (since we're not actually going to typecheck, 1891-- so this variable will never get updated!) 1892initIfaceLoad :: HscEnv -> IfG a -> IO a 1893initIfaceLoad hsc_env do_this 1894 = do let gbl_env = IfGblEnv { 1895 if_doc = text "initIfaceLoad", 1896 if_rec_types = Nothing 1897 } 1898 initTcRnIf 'i' hsc_env gbl_env () do_this 1899 1900initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a 1901-- Used when checking the up-to-date-ness of the old Iface 1902-- Initialise the environment with no useful info at all 1903initIfaceCheck doc hsc_env do_this 1904 = do let rec_types = case hsc_type_env_var hsc_env of 1905 Just (mod,var) -> Just (mod, readTcRef var) 1906 Nothing -> Nothing 1907 gbl_env = IfGblEnv { 1908 if_doc = text "initIfaceCheck" <+> doc, 1909 if_rec_types = rec_types 1910 } 1911 initTcRnIf 'i' hsc_env gbl_env () do_this 1912 1913initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a 1914initIfaceLcl mod loc_doc hi_boot_file thing_inside 1915 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside 1916 1917-- | Initialize interface typechecking, but with a 'NameShape' 1918-- to apply when typechecking top-level 'OccName's (see 1919-- 'lookupIfaceTop') 1920initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a 1921initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside 1922 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside 1923 1924getIfModule :: IfL Module 1925getIfModule = do { env <- getLclEnv; return (if_mod env) } 1926 1927-------------------- 1928failIfM :: MsgDoc -> IfL a 1929-- The Iface monad doesn't have a place to accumulate errors, so we 1930-- just fall over fast if one happens; it "shouldn't happen". 1931-- We use IfL here so that we can get context info out of the local env 1932failIfM msg 1933 = do { env <- getLclEnv 1934 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg 1935 ; dflags <- getDynFlags 1936 ; liftIO (putLogMsg dflags NoReason SevFatal 1937 noSrcSpan (defaultErrStyle dflags) full_msg) 1938 ; failM } 1939 1940-------------------- 1941forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) 1942-- Run thing_inside in an interleaved thread. 1943-- It shares everything with the parent thread, so this is DANGEROUS. 1944-- 1945-- It returns Nothing if the computation fails 1946-- 1947-- It's used for lazily type-checking interface 1948-- signatures, which is pretty benign 1949 1950forkM_maybe doc thing_inside 1951 = do { -- see Note [Masking exceptions in forkM_maybe] 1952 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ 1953 do { traceIf (text "Starting fork {" <+> doc) 1954 ; mb_res <- tryM $ 1955 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 1956 thing_inside 1957 ; case mb_res of 1958 Right r -> do { traceIf (text "} ending fork" <+> doc) 1959 ; return (Just r) } 1960 Left exn -> do { 1961 1962 -- Bleat about errors in the forked thread, if -ddump-if-trace is on 1963 -- Otherwise we silently discard errors. Errors can legitimately 1964 -- happen when compiling interface signatures (see tcInterfaceSigs) 1965 whenDOptM Opt_D_dump_if_trace $ do 1966 dflags <- getDynFlags 1967 let msg = hang (text "forkM failed:" <+> doc) 1968 2 (text (show exn)) 1969 liftIO $ putLogMsg dflags 1970 NoReason 1971 SevFatal 1972 noSrcSpan 1973 (defaultErrStyle dflags) 1974 msg 1975 1976 ; traceIf (text "} ending fork (badly)" <+> doc) 1977 ; return Nothing } 1978 }} 1979 1980forkM :: SDoc -> IfL a -> IfL a 1981forkM doc thing_inside 1982 = do { mb_res <- forkM_maybe doc thing_inside 1983 ; return (case mb_res of 1984 Nothing -> pgmError "Cannot continue after interface file error" 1985 -- pprPanic "forkM" doc 1986 Just r -> r) } 1987 1988setImplicitEnvM :: TypeEnv -> IfL a -> IfL a 1989setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl 1990 { if_implicits_env = Just tenv }) m 1991 1992{- 1993Note [Masking exceptions in forkM_maybe] 1994~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1995 1996When using GHC-as-API it must be possible to interrupt snippets of code 1997executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible 1998by throwing an asynchronous interrupt to the GHC thread. However, there is a 1999subtle problem: runStmt first typechecks the code before running it, and the 2000exception might interrupt the type checker rather than the code. Moreover, the 2001typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and 2002more importantly might be inside an exception handler inside that 2003unsafeInterleaveIO. If that is the case, the exception handler will rethrow the 2004asynchronous exception as a synchronous exception, and the exception will end 2005up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed 2006discussion). We don't currently know a general solution to this problem, but 2007we can use uninterruptibleMask_ to avoid the situation. 2008-} 2009 2010-- | Environments which track 'CostCentreState' 2011class ContainsCostCentreState e where 2012 extractCostCentreState :: e -> TcRef CostCentreState 2013 2014instance ContainsCostCentreState TcGblEnv where 2015 extractCostCentreState = tcg_cc_st 2016 2017instance ContainsCostCentreState DsGblEnv where 2018 extractCostCentreState = ds_cc_st 2019 2020-- | Get the next cost centre index associated with a given name. 2021getCCIndexM :: (ContainsCostCentreState gbl) 2022 => FastString -> TcRnIf gbl lcl CostCentreIndex 2023getCCIndexM nm = do 2024 env <- getGblEnv 2025 let cc_st_ref = extractCostCentreState env 2026 cc_st <- readTcRef cc_st_ref 2027 let (idx, cc_st') = getCCIndex nm cc_st 2028 writeTcRef cc_st_ref cc_st' 2029 return idx 2030