compiler/typecheck/TcRnMonad.hs

   1 {-
   2 (c) The University of Glasgow 2006
   3
   4
   5 Functions for working with the typechecker environment (setters, getters...).
   6 -}
   7
   8 {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10
  11 module TcRnMonad(
  12         module TcRnMonad,
  13         module TcRnTypes,
  14         module IOEnv
  15   ) where
  16
  17 #include "HsVersions.h"
  18
  19 import TcRnTypes        -- Re-export all
  20 import IOEnv            -- Re-export all
  21 import TcEvidence
  22
  23 import HsSyn hiding (LIE)
  24 import HscTypes
  25 import Module
  26 import RdrName
  27 import Name
  28 import Type
  29
  30 import TcType
  31 import InstEnv
  32 import FamInstEnv
  33 import PrelNames
  34
  35 import Id
  36 import VarSet
  37 import VarEnv
  38 import ErrUtils
  39 import SrcLoc
  40 import NameEnv
  41 import NameSet
  42 import Bag
  43 import Outputable
  44 import UniqSupply
  45 import DynFlags
  46 import StaticFlags
  47 import FastString
  48 import Panic
  49 import Util
  50 import Annotations
  51 import BasicTypes( TopLevelFlag )
  52
  53 import qualified GHC.LanguageExtensions as LangExt
  54
  55 import Control.Exception
  56 import Data.IORef
  57 import Control.Monad
  58 import Data.Set ( Set )
  59 import qualified Data.Set as Set
  60
  61 #ifdef GHCI
  62 import qualified Data.Map as Map
  63 #endif
  64
  65 {-
  66 ************************************************************************
  67 *                                                                      *
  68                         initTc
  69 *                                                                      *
  70 ************************************************************************
  71 -}
  72
  73 -- | Setup the initial typechecking environment
  74 initTc :: HscEnv
  75        -> HscSource
  76        -> Bool          -- True <=> retain renamed syntax trees
  77        -> Module
  78        -> RealSrcSpan
  79        -> TcM r
  80        -> IO (Messages, Maybe r)
  81                 -- Nothing => error thrown by the thing inside
  82                 -- (error messages should have been printed already)
  83
  84 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
  85  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
  86         tvs_var      <- newIORef emptyVarSet ;
  87         keep_var     <- newIORef emptyNameSet ;
  88         used_gre_var <- newIORef [] ;
  89         th_var       <- newIORef False ;
  90         th_splice_var<- newIORef False ;
  91         th_locs_var  <- newIORef Set.empty ;
  92         infer_var    <- newIORef (True, emptyBag) ;
  93         lie_var      <- newIORef emptyWC ;
  94         dfun_n_var   <- newIORef emptyOccSet ;
  95         type_env_var <- case hsc_type_env_var hsc_env of {
  96                            Just (_mod, te_var) -> return te_var ;
  97                            Nothing             -> newIORef emptyNameEnv } ;
  98
  99         dependent_files_var <- newIORef [] ;
 100         static_wc_var       <- newIORef emptyWC ;
 101 #ifdef GHCI
 102         th_topdecls_var      <- newIORef [] ;
 103         th_topnames_var      <- newIORef emptyNameSet ;
 104         th_modfinalizers_var <- newIORef [] ;
 105         th_state_var         <- newIORef Map.empty ;
 106         th_remote_state_var  <- newIORef Nothing ;
 107 #endif /* GHCI */
 108         let {
 109              dflags = hsc_dflags hsc_env ;
 110
 111              maybe_rn_syntax :: forall a. a -> Maybe a ;
 112              maybe_rn_syntax empty_val
 113                 | keep_rn_syntax = Just empty_val
 114                 | otherwise      = Nothing ;
 115
 116              gbl_env = TcGblEnv {
 117 #ifdef GHCI
 118                 tcg_th_topdecls      = th_topdecls_var,
 119                 tcg_th_topnames      = th_topnames_var,
 120                 tcg_th_modfinalizers = th_modfinalizers_var,
 121                 tcg_th_state         = th_state_var,
 122                 tcg_th_remote_state  = th_remote_state_var,
 123 #endif /* GHCI */
 124
 125                 tcg_mod            = mod,
 126                 tcg_src            = hsc_src,
 127                 tcg_sig_of         = getSigOf dflags (moduleName mod),
 128                 tcg_impl_rdr_env   = Nothing,
 129                 tcg_rdr_env        = emptyGlobalRdrEnv,
 130                 tcg_fix_env        = emptyNameEnv,
 131                 tcg_field_env      = emptyNameEnv,
 132                 tcg_default        = if moduleUnitId mod == primUnitId
 133                                      then Just []  -- See Note [Default types]
 134                                      else Nothing,
 135                 tcg_type_env       = emptyNameEnv,
 136                 tcg_type_env_var   = type_env_var,
 137                 tcg_inst_env       = emptyInstEnv,
 138                 tcg_fam_inst_env   = emptyFamInstEnv,
 139                 tcg_ann_env        = emptyAnnEnv,
 140                 tcg_th_used        = th_var,
 141                 tcg_th_splice_used = th_splice_var,
 142                 tcg_th_top_level_locs
 143                                    = th_locs_var,
 144                 tcg_exports        = [],
 145                 tcg_imports        = emptyImportAvails,
 146                 tcg_used_gres     = used_gre_var,
 147                 tcg_dus            = emptyDUs,
 148
 149                 tcg_rn_imports     = [],
 150                 tcg_rn_exports     = maybe_rn_syntax [],
 151                 tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
 152                 tcg_tr_module      = Nothing,
 153                 tcg_binds          = emptyLHsBinds,
 154                 tcg_imp_specs      = [],
 155                 tcg_sigs           = emptyNameSet,
 156                 tcg_ev_binds       = emptyBag,
 157                 tcg_warns          = NoWarnings,
 158                 tcg_anns           = [],
 159                 tcg_tcs            = [],
 160                 tcg_insts          = [],
 161                 tcg_fam_insts      = [],
 162                 tcg_rules          = [],
 163                 tcg_fords          = [],
 164                 tcg_vects          = [],
 165                 tcg_patsyns        = [],
 166                 tcg_dfun_n         = dfun_n_var,
 167                 tcg_keep           = keep_var,
 168                 tcg_doc_hdr        = Nothing,
 169                 tcg_hpc            = False,
 170                 tcg_main           = Nothing,
 171                 tcg_self_boot      = NoSelfBoot,
 172                 tcg_safeInfer      = infer_var,
 173                 tcg_dependent_files = dependent_files_var,
 174                 tcg_tc_plugins     = [],
 175                 tcg_static_wc      = static_wc_var
 176              } ;
 177              lcl_env = TcLclEnv {
 178                 tcl_errs       = errs_var,
 179                 tcl_loc        = loc,     -- Should be over-ridden very soon!
 180                 tcl_ctxt       = [],
 181                 tcl_rdr        = emptyLocalRdrEnv,
 182                 tcl_th_ctxt    = topStage,
 183                 tcl_th_bndrs   = emptyNameEnv,
 184                 tcl_arrow_ctxt = NoArrowCtxt,
 185                 tcl_env        = emptyNameEnv,
 186                 tcl_bndrs      = [],
 187                 tcl_tidy       = emptyTidyEnv,
 188                 tcl_tyvars     = tvs_var,
 189                 tcl_lie        = lie_var,
 190                 tcl_tclvl      = topTcLevel
 191              } ;
 192         } ;
 193
 194         -- OK, here's the business end!
 195         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
 196                      do { r <- tryM do_this
 197                         ; case r of
 198                           Right res -> return (Just res)
 199                           Left _    -> return Nothing } ;
 200
 201         -- Check for unsolved constraints
 202         lie <- readIORef lie_var ;
 203         if isEmptyWC lie
 204            then return ()
 205            else pprPanic "initTc: unsolved constraints" (ppr lie) ;
 206
 207         -- Collect any error messages
 208         msgs <- readIORef errs_var ;
 209
 210         let { final_res | errorsFound dflags msgs = Nothing
 211                         | otherwise               = maybe_res } ;
 212
 213         return (msgs, final_res)
 214     }
 215
 216
 217 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
 218 -- Initialise the type checker monad for use in GHCi
 219 initTcInteractive hsc_env thing_inside
 220   = initTc hsc_env HsSrcFile False
 221            (icInteractiveModule (hsc_IC hsc_env))
 222            (realSrcLocSpan interactive_src_loc)
 223            thing_inside
 224   where
 225     interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
 226
 227 initTcForLookup :: HscEnv -> TcM a -> IO a
 228 -- The thing_inside is just going to look up something
 229 -- in the environment, so we don't need much setup
 230 initTcForLookup hsc_env thing_inside
 231   = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
 232        ; case m of
 233              Nothing -> throwIO $ mkSrcErr $ snd msgs
 234              Just x -> return x }
 235
 236 {- Note [Default types]
 237 ~~~~~~~~~~~~~~~~~~~~~~~
 238 The Integer type is simply not available in package ghc-prim (it is
 239 declared in integer-gmp).  So we set the defaulting types to (Just
 240 []), meaning there are no default types, rather then Nothing, which
 241 means "use the default default types of Integer, Double".
 242
 243 If you don't do this, attempted defaulting in package ghc-prim causes
 244 an actual crash (attempting to look up the Integer type).
 245
 246
 247 ************************************************************************
 248 *                                                                      *
 249                 Initialisation
 250 *                                                                      *
 251 ************************************************************************
 252 -}
 253
 254 initTcRnIf :: Char              -- Tag for unique supply
 255            -> HscEnv
 256            -> gbl -> lcl
 257            -> TcRnIf gbl lcl a
 258            -> IO a
 259 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
 260    = do { us     <- mkSplitUniqSupply uniq_tag ;
 261         ; us_var <- newIORef us ;
 262
 263         ; let { env = Env { env_top = hsc_env,
 264                             env_us  = us_var,
 265                             env_gbl = gbl_env,
 266                             env_lcl = lcl_env} }
 267
 268         ; runIOEnv env thing_inside
 269         }
 270
 271 {-
 272 ************************************************************************
 273 *                                                                      *
 274                 Simple accessors
 275 *                                                                      *
 276 ************************************************************************
 277 -}
 278
 279 discardResult :: TcM a -> TcM ()
 280 discardResult a = a >> return ()
 281
 282 getTopEnv :: TcRnIf gbl lcl HscEnv
 283 getTopEnv = do { env <- getEnv; return (env_top env) }
 284
 285 updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 286 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
 287                           env { env_top = upd top })
 288
 289 getGblEnv :: TcRnIf gbl lcl gbl
 290 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 291
 292 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 293 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
 294                           env { env_gbl = upd gbl })
 295
 296 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 297 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 298
 299 getLclEnv :: TcRnIf gbl lcl lcl
 300 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 301
 302 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 303 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 304                           env { env_lcl = upd lcl })
 305
 306 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
 307 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 308
 309 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
 310 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
 311
 312 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
 313 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 314
 315 -- Command-line flags
 316
 317 xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
 318 xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
 319
 320 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
 321 doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
 322
 323 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
 324 goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
 325
 326 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
 327 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
 328
 329 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 330 setXOptM flag =
 331   updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
 332
 333 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 334 unsetGOptM flag =
 335   updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
 336
 337 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 338 unsetWOptM flag =
 339   updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
 340
 341 -- | Do it flag is true
 342 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 343 whenDOptM flag thing_inside = do b <- doptM flag
 344                                  when b thing_inside
 345
 346 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 347 whenGOptM flag thing_inside = do b <- goptM flag
 348                                  when b thing_inside
 349
 350 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 351 whenWOptM flag thing_inside = do b <- woptM flag
 352                                  when b thing_inside
 353
 354 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 355 whenXOptM flag thing_inside = do b <- xoptM flag
 356                                  when b thing_inside
 357
 358 getGhcMode :: TcRnIf gbl lcl GhcMode
 359 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 360
 361 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 362 withDoDynamicToo =
 363   updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
 364               top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
 365
 366 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 367 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 368
 369 getEps :: TcRnIf gbl lcl ExternalPackageState
 370 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 371
 372 -- | Update the external package state.  Returns the second result of the
 373 -- modifier function.
 374 --
 375 -- This is an atomic operation and forces evaluation of the modified EPS in
 376 -- order to avoid space leaks.
 377 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 378           -> TcRnIf gbl lcl a
 379 updateEps upd_fn = do
 380   traceIf (text "updating EPS")
 381   eps_var <- getEpsVar
 382   atomicUpdMutVar' eps_var upd_fn
 383
 384 -- | Update the external package state.
 385 --
 386 -- This is an atomic operation and forces evaluation of the modified EPS in
 387 -- order to avoid space leaks.
 388 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 389            -> TcRnIf gbl lcl ()
 390 updateEps_ upd_fn = do
 391   traceIf (text "updating EPS_")
 392   eps_var <- getEpsVar
 393   atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 394
 395 getHpt :: TcRnIf gbl lcl HomePackageTable
 396 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
 397
 398 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
 399 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 400                   ; return (eps, hsc_HPT env) }
 401
 402 {-
 403 ************************************************************************
 404 *                                                                      *
 405                 Arrow scopes
 406 *                                                                      *
 407 ************************************************************************
 408 -}
 409
 410 newArrowScope :: TcM a -> TcM a
 411 newArrowScope
 412   = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
 413
 414 -- Return to the stored environment (from the enclosing proc)
 415 escapeArrowScope :: TcM a -> TcM a
 416 escapeArrowScope
 417   = updLclEnv $ \ env ->
 418     case tcl_arrow_ctxt env of
 419       NoArrowCtxt       -> env
 420       ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
 421                                    , tcl_lie = lie
 422                                    , tcl_rdr = rdr_env }
 423
 424 {-
 425 ************************************************************************
 426 *                                                                      *
 427                 Unique supply
 428 *                                                                      *
 429 ************************************************************************
 430 -}
 431
 432 newUnique :: TcRnIf gbl lcl Unique
 433 newUnique
 434  = do { env <- getEnv ;
 435         let { u_var = env_us env } ;
 436         us <- readMutVar u_var ;
 437         case takeUniqFromSupply us of { (uniq, us') -> do {
 438         writeMutVar u_var us' ;
 439         return $! uniq }}}
 440    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
 441    -- a chain of unevaluated supplies behind.
 442    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
 443    -- throw away one half of the new split supply.  This is safe because this
 444    -- is the only place we use that unique.  Using the other half of the split
 445    -- supply is safer, but slower.
 446
 447 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 448 newUniqueSupply
 449  = do { env <- getEnv ;
 450         let { u_var = env_us env } ;
 451         us <- readMutVar u_var ;
 452         case splitUniqSupply us of { (us1,us2) -> do {
 453         writeMutVar u_var us1 ;
 454         return us2 }}}
 455
 456 newLocalName :: Name -> TcM Name
 457 newLocalName name = newName (nameOccName name)
 458
 459 newName :: OccName -> TcM Name
 460 newName occ
 461   = do { uniq <- newUnique
 462        ; loc  <- getSrcSpanM
 463        ; return (mkInternalName uniq occ loc) }
 464
 465 newSysName :: OccName -> TcRnIf gbl lcl Name
 466 newSysName occ
 467   = do { uniq <- newUnique
 468        ; return (mkSystemName uniq occ) }
 469
 470 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
 471 newSysLocalId fs ty
 472   = do  { u <- newUnique
 473         ; return (mkSysLocalOrCoVar fs u ty) }
 474
 475 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 476 newSysLocalIds fs tys
 477   = do  { us <- newUniqueSupply
 478         ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
 479
 480 instance MonadUnique (IOEnv (Env gbl lcl)) where
 481         getUniqueM = newUnique
 482         getUniqueSupplyM = newUniqueSupply
 483
 484 {-
 485 ************************************************************************
 486 *                                                                      *
 487                 Accessing input/output
 488 *                                                                      *
 489 ************************************************************************
 490 -}
 491
 492 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
 493 newTcRef = newMutVar
 494
 495 readTcRef :: TcRef a -> TcRnIf gbl lcl a
 496 readTcRef = readMutVar
 497
 498 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
 499 writeTcRef = writeMutVar
 500
 501 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
 502 -- Returns ()
 503 updTcRef ref fn = liftIO $ do { old <- readIORef ref
 504                               ; writeIORef ref (fn old) }
 505
 506 updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
 507 -- Returns previous value
 508 updTcRefX ref fn = liftIO $ do { old <- readIORef ref
 509                               ; writeIORef ref (fn old)
 510                               ; return old }
 511
 512 {-
 513 ************************************************************************
 514 *                                                                      *
 515                 Debugging
 516 *                                                                      *
 517 ************************************************************************
 518 -}
 519
 520 traceTc :: String -> SDoc -> TcRn ()
 521 traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
 522
 523 -- | Typechecker trace
 524 traceTcN :: Int -> SDoc -> TcRn ()
 525 traceTcN level doc
 526     = do dflags <- getDynFlags
 527          when (level <= traceLevel dflags && not opt_NoDebugOutput) $
 528              traceOptTcRn Opt_D_dump_tc_trace doc
 529
 530 traceRn :: SDoc -> TcRn ()
 531 traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
 532
 533 -- | Output a doc if the given 'DumpFlag' is set.
 534 --
 535 -- By default this logs to stdout
 536 -- However, if the `-ddump-to-file` flag is set,
 537 -- then this will dump output to a file
 538 --
 539 -- Just a wrapper for 'dumpSDoc'
 540 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 541 traceOptTcRn flag doc
 542   = do { dflags <- getDynFlags
 543        ; when (dopt flag dflags) (traceTcRn flag doc)
 544     }
 545
 546 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
 547 -- ^ Unconditionally dump some trace output
 548 --
 549 -- The DumpFlag is used only to set the output filename
 550 -- for --dump-to-file, not to decide whether or not to output
 551 -- That part is done by the caller
 552 traceTcRn flag doc
 553   = do { real_doc <- prettyDoc doc
 554        ; dflags   <- getDynFlags
 555        ; printer  <- getPrintUnqualified dflags
 556        ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }
 557   where
 558     -- Add current location if opt_PprStyle_Debug
 559     prettyDoc :: SDoc -> TcRn SDoc
 560     prettyDoc doc = if opt_PprStyle_Debug
 561        then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
 562        else return doc -- The full location is usually way too much
 563
 564
 565 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
 566 getPrintUnqualified dflags
 567   = do { rdr_env <- getGlobalRdrEnv
 568        ; return $ mkPrintUnqualified dflags rdr_env }
 569
 570 -- | Like logInfoTcRn, but for user consumption
 571 printForUserTcRn :: SDoc -> TcRn ()
 572 printForUserTcRn doc
 573   = do { dflags <- getDynFlags
 574        ; printer <- getPrintUnqualified dflags
 575        ; liftIO (printOutputForUser dflags printer doc) }
 576
 577 -- | Typechecker debug
 578 debugDumpTcRn :: SDoc -> TcRn ()
 579 debugDumpTcRn doc = unless opt_NoDebugOutput $
 580                     traceOptTcRn Opt_D_dump_tc doc
 581
 582 {-
 583 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
 584 available.  Alas, they behave inconsistently with the other stuff;
 585 e.g. are unaffected by -dump-to-file.
 586 -}
 587
 588 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 589 traceIf      = traceOptIf Opt_D_dump_if_trace
 590 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 591
 592
 593 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
 594 traceOptIf flag doc
 595   = whenDOptM flag $    -- No RdrEnv available, so qualify everything
 596     do { dflags <- getDynFlags
 597        ; liftIO (putMsg dflags doc) }
 598
 599 {-
 600 ************************************************************************
 601 *                                                                      *
 602                 Typechecker global environment
 603 *                                                                      *
 604 ************************************************************************
 605 -}
 606
 607 setModule :: Module -> TcRn a -> TcRn a
 608 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
 609
 610 getIsGHCi :: TcRn Bool
 611 getIsGHCi = do { mod <- getModule
 612                ; return (isInteractiveModule mod) }
 613
 614 getGHCiMonad :: TcRn Name
 615 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
 616
 617 getInteractivePrintName :: TcRn Name
 618 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
 619
 620 tcIsHsBootOrSig :: TcRn Bool
 621 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
 622
 623 tcSelfBootInfo :: TcRn SelfBootInfo
 624 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
 625
 626 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 627 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 628
 629 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
 630 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
 631
 632 getImports :: TcRn ImportAvails
 633 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 634
 635 getFixityEnv :: TcRn FixityEnv
 636 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 637
 638 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 639 extendFixityEnv new_bit
 640   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 641                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 642
 643 getRecFieldEnv :: TcRn RecFieldEnv
 644 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 645
 646 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 647 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 648
 649 addDependentFiles :: [FilePath] -> TcRn ()
 650 addDependentFiles fs = do
 651   ref <- fmap tcg_dependent_files getGblEnv
 652   dep_files <- readTcRef ref
 653   writeTcRef ref (fs ++ dep_files)
 654
 655 {-
 656 ************************************************************************
 657 *                                                                      *
 658                 Error management
 659 *                                                                      *
 660 ************************************************************************
 661 -}
 662
 663 getSrcSpanM :: TcRn SrcSpan
 664         -- Avoid clash with Name.getSrcLoc
 665 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
 666
 667 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
 668 setSrcSpan (RealSrcSpan real_loc) thing_inside
 669     = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
 670 -- Don't overwrite useful info with useless:
 671 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
 672
 673 addLocM :: (a -> TcM b) -> Located a -> TcM b
 674 addLocM fn (L loc a) = setSrcSpan loc $ fn a
 675
 676 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
 677 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
 678
 679 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
 680 wrapLocFstM fn (L loc a) =
 681   setSrcSpan loc $ do
 682     (b,c) <- fn a
 683     return (L loc b, c)
 684
 685 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
 686 wrapLocSndM fn (L loc a) =
 687   setSrcSpan loc $ do
 688     (b,c) <- fn a
 689     return (b, L loc c)
 690
 691 -- Reporting errors
 692
 693 getErrsVar :: TcRn (TcRef Messages)
 694 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 695
 696 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 697 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 698
 699 addErr :: MsgDoc -> TcRn ()
 700 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
 701
 702 failWith :: MsgDoc -> TcRn a
 703 failWith msg = addErr msg >> failM
 704
 705 failAt :: SrcSpan -> MsgDoc -> TcRn a
 706 failAt loc msg = addErrAt loc msg >> failM
 707
 708 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
 709 -- addErrAt is mainly (exclusively?) used by the renamer, where
 710 -- tidying is not an issue, but it's all lazy so the extra
 711 -- work doesn't matter
 712 addErrAt loc msg = do { ctxt <- getErrCtxt
 713                       ; tidy_env <- tcInitTidyEnv
 714                       ; err_info <- mkErrInfo tidy_env ctxt
 715                       ; addLongErrAt loc msg err_info }
 716
 717 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
 718 addErrs msgs = mapM_ add msgs
 719              where
 720                add (loc,msg) = addErrAt loc msg
 721
 722 checkErr :: Bool -> MsgDoc -> TcRn ()
 723 -- Add the error if the bool is False
 724 checkErr ok msg = unless ok (addErr msg)
 725
 726 addMessages :: Messages -> TcRn ()
 727 addMessages msgs1
 728   = do { errs_var <- getErrsVar ;
 729          msgs0 <- readTcRef errs_var ;
 730          writeTcRef errs_var (unionMessages msgs0 msgs1) }
 731
 732 discardWarnings :: TcRn a -> TcRn a
 733 -- Ignore warnings inside the thing inside;
 734 -- used to ignore-unused-variable warnings inside derived code
 735 discardWarnings thing_inside
 736   = do  { errs_var <- getErrsVar
 737         ; (old_warns, _) <- readTcRef errs_var
 738
 739         ; result <- thing_inside
 740
 741         -- Revert warnings to old_warns
 742         ; (_new_warns, new_errs) <- readTcRef errs_var
 743         ; writeTcRef errs_var (old_warns, new_errs)
 744
 745         ; return result }
 746
 747 {-
 748 ************************************************************************
 749 *                                                                      *
 750         Shared error message stuff: renamer and typechecker
 751 *                                                                      *
 752 ************************************************************************
 753 -}
 754
 755 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
 756 mkLongErrAt loc msg extra
 757   = do { dflags <- getDynFlags ;
 758          printer <- getPrintUnqualified dflags ;
 759          return $ mkLongErrMsg dflags loc printer msg extra }
 760
 761 mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
 762 mkErrDocAt loc errDoc
 763   = do { dflags <- getDynFlags ;
 764          printer <- getPrintUnqualified dflags ;
 765          return $ mkErrDoc dflags loc printer errDoc }
 766
 767 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 768 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
 769
 770 reportErrors :: [ErrMsg] -> TcM ()
 771 reportErrors = mapM_ reportError
 772
 773 reportError :: ErrMsg -> TcRn ()
 774 reportError err
 775   = do { traceTc "Adding error:" (pprLocErrMsg err) ;
 776          errs_var <- getErrsVar ;
 777          (warns, errs) <- readTcRef errs_var ;
 778          writeTcRef errs_var (warns, errs `snocBag` err) }
 779
 780 reportWarning :: WarnReason -> ErrMsg -> TcRn ()
 781 reportWarning reason err
 782   = do { let warn = makeIntoWarning reason err
 783                     -- 'err' was built by mkLongErrMsg or something like that,
 784                     -- so it's of error severity.  For a warning we downgrade
 785                     -- its severity to SevWarning
 786
 787        ; traceTc "Adding warning:" (pprLocErrMsg warn)
 788        ; errs_var <- getErrsVar
 789        ; (warns, errs) <- readTcRef errs_var
 790        ; writeTcRef errs_var (warns `snocBag` warn, errs) }
 791
 792 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 793 -- Does tryM, with a debug-trace on failure
 794 try_m thing
 795   = do { mb_r <- tryM thing ;
 796          case mb_r of
 797              Left exn -> do { traceTc "tryTc/recoverM recovering from" $
 798                                       text (showException exn)
 799                             ; return mb_r }
 800              Right _  -> return mb_r }
 801
 802 -----------------------
 803 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
 804          -> TcRn r      -- Main action: do this first
 805          -> TcRn r
 806 -- Errors in 'thing' are retained
 807 recoverM recover thing
 808   = do { mb_res <- try_m thing ;
 809          case mb_res of
 810            Left _    -> recover
 811            Right res -> return res }
 812
 813
 814 -----------------------
 815 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 816 -- Drop elements of the input that fail, so the result
 817 -- list can be shorter than the argument list
 818 mapAndRecoverM _ []     = return []
 819 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
 820                              ; rs <- mapAndRecoverM f xs
 821                              ; return (case mb_r of
 822                                           Left _  -> rs
 823                                           Right r -> r:rs) }
 824
 825 -- | Succeeds if applying the argument to all members of the lists succeeds,
 826 --   but nevertheless runs it on all arguments, to collect all errors.
 827 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
 828 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
 829
 830 -----------------------
 831 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 832 -- (tryTc m) executes m, and returns
 833 --      Just r,  if m succeeds (returning r)
 834 --      Nothing, if m fails
 835 -- It also returns all the errors and warnings accumulated by m
 836 -- It always succeeds (never raises an exception)
 837 tryTc m
 838  = do { errs_var <- newTcRef emptyMessages ;
 839         res  <- try_m (setErrsVar errs_var m) ;
 840         msgs <- readTcRef errs_var ;
 841         return (msgs, case res of
 842                             Left _  -> Nothing
 843                             Right val -> Just val)
 844         -- The exception is always the IOEnv built-in
 845         -- in exception; see IOEnv.failM
 846    }
 847
 848 -- (askNoErrs m) runs m
 849 -- If m fails, (askNoErrs m) fails
 850 -- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
 851 --  where b is True iff m generated no errors
 852 -- Regardless of success or failure, any errors generated by m are propagated
 853 askNoErrs :: TcRn a -> TcRn (a, Bool)
 854 askNoErrs m
 855  = do { errs_var <- newTcRef emptyMessages
 856       ; res  <- setErrsVar errs_var m
 857       ; (warns, errs) <- readTcRef errs_var
 858       ; addMessages (warns, errs)
 859       ; return (res, isEmptyBag errs) }
 860
 861 discardErrs :: TcRn a -> TcRn a
 862 -- (discardErrs m) runs m,
 863 --   discarding all error messages and warnings generated by m
 864 -- If m fails, discardErrs fails, and vice versa
 865 discardErrs m
 866  = do { errs_var <- newTcRef emptyMessages
 867       ; setErrsVar errs_var m }
 868
 869 -----------------------
 870 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
 871 -- Run the thing, returning
 872 --      Just r,  if m succceeds with no error messages
 873 --      Nothing, if m fails, or if it succeeds but has error messages
 874 -- Either way, the messages are returned;
 875 -- even in the Just case there might be warnings
 876 tryTcErrs thing
 877   = do  { (msgs, res) <- tryTc thing
 878         ; dflags <- getDynFlags
 879         ; let errs_found = errorsFound dflags msgs
 880         ; return (msgs, case res of
 881                           Nothing -> Nothing
 882                           Just val | errs_found -> Nothing
 883                                    | otherwise  -> Just val)
 884         }
 885
 886 -----------------------
 887 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 888 -- Just like tryTcErrs, except that it ensures that the LIE
 889 -- for the thing is propagated only if there are no errors
 890 -- Hence it's restricted to the type-check monad
 891 tryTcLIE thing_inside
 892   = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
 893         ; case mb_res of
 894             Nothing  -> return (msgs, Nothing)
 895             Just val -> do { emitConstraints lie; return (msgs, Just val) }
 896         }
 897
 898 -----------------------
 899 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 900 -- (tryTcLIE_ r m) tries m;
 901 --      if m succeeds with no error messages, it's the answer
 902 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
 903 tryTcLIE_ recover main
 904   = do  { (msgs, mb_res) <- tryTcLIE main
 905         ; case mb_res of
 906              Just val -> do { addMessages msgs  -- There might be warnings
 907                              ; return val }
 908              Nothing  -> recover                -- Discard all msgs
 909         }
 910
 911 -----------------------
 912 checkNoErrs :: TcM r -> TcM r
 913 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 914 -- If m fails then (checkNoErrsTc m) fails.
 915 -- If m succeeds, it checks whether m generated any errors messages
 916 --      (it might have recovered internally)
 917 --      If so, it fails too.
 918 -- Regardless, any errors generated by m are propagated to the enclosing context.
 919 checkNoErrs main
 920   = do  { (msgs, mb_res) <- tryTcLIE main
 921         ; addMessages msgs
 922         ; case mb_res of
 923             Nothing  -> failM
 924             Just val -> return val
 925         }
 926
 927 whenNoErrs :: TcM () -> TcM ()
 928 whenNoErrs thing = ifErrsM (return ()) thing
 929
 930 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 931 --      ifErrsM bale_out normal
 932 -- does 'bale_out' if there are errors in errors collection
 933 -- otherwise does 'normal'
 934 ifErrsM bale_out normal
 935  = do { errs_var <- getErrsVar ;
 936         msgs <- readTcRef errs_var ;
 937         dflags <- getDynFlags ;
 938         if errorsFound dflags msgs then
 939            bale_out
 940         else
 941            normal }
 942
 943 failIfErrsM :: TcRn ()
 944 -- Useful to avoid error cascades
 945 failIfErrsM = ifErrsM failM (return ())
 946
 947 #ifdef GHCI
 948 checkTH :: a -> String -> TcRn ()
 949 checkTH _ _ = return () -- OK
 950 #else
 951 checkTH :: Outputable a => a -> String -> TcRn ()
 952 checkTH e what = failTH e what  -- Raise an error in a stage-1 compiler
 953 #endif
 954
 955 failTH :: Outputable a => a -> String -> TcRn x
 956 failTH e what  -- Raise an error in a stage-1 compiler
 957   = failWithTc (vcat [ hang (char 'A' <+> text what
 958                              <+> text "requires GHC with interpreter support:")
 959                           2 (ppr e)
 960                      , text "Perhaps you are using a stage-1 compiler?" ])
 961
 962 {-
 963 ************************************************************************
 964 *                                                                      *
 965         Context management for the type checker
 966 *                                                                      *
 967 ************************************************************************
 968 -}
 969
 970 getErrCtxt :: TcM [ErrCtxt]
 971 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 972
 973 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
 974 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 975
 976 -- | Add a fixed message to the error context. This message should not
 977 -- do any tidying.
 978 addErrCtxt :: MsgDoc -> TcM a -> TcM a
 979 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 980
 981 -- | Add a message to the error context. This message may do tidying.
 982 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
 983 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
 984
 985 -- | Add a fixed landmark message to the error context. A landmark
 986 -- message is always sure to be reported, even if there is a lot of
 987 -- context. It also doesn't count toward the maximum number of contexts
 988 -- reported.
 989 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
 990 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
 991
 992 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
 993 -- and tidying.
 994 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
 995 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
 996
 997 -- Helper function for the above
 998 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 999 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1000                            env { tcl_ctxt = upd ctxt })
1001
1002 popErrCtxt :: TcM a -> TcM a
1003 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1004
1005 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1006 getCtLocM origin t_or_k
1007   = do { env <- getLclEnv
1008        ; return (CtLoc { ctl_origin = origin
1009                        , ctl_env    = env
1010                        , ctl_t_or_k = t_or_k
1011                        , ctl_depth  = initialSubGoalDepth }) }
1012
1013 setCtLocM :: CtLoc -> TcM a -> TcM a
1014 -- Set the SrcSpan and error context from the CtLoc
1015 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1016   = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
1017                            , tcl_bndrs = tcl_bndrs lcl
1018                            , tcl_ctxt  = tcl_ctxt lcl })
1019               thing_inside
1020
1021 {-
1022 ************************************************************************
1023 *                                                                      *
1024              Error message generation (type checker)
1025 *                                                                      *
1026 ************************************************************************
1027
1028     The addErrTc functions add an error message, but do not cause failure.
1029     The 'M' variants pass a TidyEnv that has already been used to
1030     tidy up the message; we then use it to tidy the context messages
1031 -}
1032
1033 addErrTc :: MsgDoc -> TcM ()
1034 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1035                       ; addErrTcM (env0, err_msg) }
1036
1037 addErrsTc :: [MsgDoc] -> TcM ()
1038 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1039
1040 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1041 addErrTcM (tidy_env, err_msg)
1042   = do { ctxt <- getErrCtxt ;
1043          loc  <- getSrcSpanM ;
1044          add_err_tcm tidy_env err_msg loc ctxt }
1045
1046 -- Return the error message, instead of reporting it straight away
1047 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1048 mkErrTcM (tidy_env, err_msg)
1049   = do { ctxt <- getErrCtxt ;
1050          loc  <- getSrcSpanM ;
1051          err_info <- mkErrInfo tidy_env ctxt ;
1052          mkLongErrAt loc err_msg err_info }
1053
1054 -- The failWith functions add an error message and cause failure
1055
1056 failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
1057 failWithTc err_msg
1058   = addErrTc err_msg >> failM
1059
1060 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
1061 failWithTcM local_and_msg
1062   = addErrTcM local_and_msg >> failM
1063
1064 checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
1065 checkTc True  _   = return ()
1066 checkTc False err = failWithTc err
1067
1068 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1069 checkTcM True  _   = return ()
1070 checkTcM False err = failWithTcM err
1071
1072 failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
1073 failIfTc False _   = return ()
1074 failIfTc True  err = failWithTc err
1075
1076 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1077    -- Check that the boolean is false
1078 failIfTcM False _   = return ()
1079 failIfTcM True  err = failWithTcM err
1080
1081
1082 --         Warnings have no 'M' variant, nor failure
1083
1084 -- | Display a warning if a condition is met.
1085 --   and the warning is enabled
1086 warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
1087 warnIf reason is_bad msg
1088   = do { warn_on <- case reason of
1089                        NoReason         -> return True
1090                        Reason warn_flag -> woptM warn_flag
1091        ; when (warn_on && is_bad) $
1092          addWarn reason msg }
1093
1094 -- | Display a warning if a condition is met.
1095 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1096 warnTc reason warn_if_true warn_msg
1097   | warn_if_true = addWarnTc reason warn_msg
1098   | otherwise    = return ()
1099
1100 -- | Display a warning if a condition is met.
1101 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1102 warnTcM reason warn_if_true warn_msg
1103   | warn_if_true = addWarnTcM reason warn_msg
1104   | otherwise    = return ()
1105
1106 -- | Display a warning in the current context.
1107 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1108 addWarnTc reason msg
1109  = do { env0 <- tcInitTidyEnv ;
1110       addWarnTcM reason (env0, msg) }
1111
1112 -- | Display a warning in a given context.
1113 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1114 addWarnTcM reason (env0, msg)
1115  = do { ctxt <- getErrCtxt ;
1116         err_info <- mkErrInfo env0 ctxt ;
1117         add_warn reason msg err_info }
1118
1119 -- | Display a warning for the current source location.
1120 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1121 addWarn reason msg = add_warn reason msg Outputable.empty
1122
1123 -- | Display a warning for a given source location.
1124 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1125 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1126
1127 -- | Display a warning, with an optional flag, for the current source
1128 -- location.
1129 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1130 add_warn reason msg extra_info
1131   = do { loc <- getSrcSpanM
1132        ; add_warn_at reason loc msg extra_info }
1133
1134 -- | Display a warning, with an optional flag, for a given location.
1135 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1136 add_warn_at reason loc msg extra_info
1137   = do { dflags <- getDynFlags ;
1138          printer <- getPrintUnqualified dflags ;
1139          let { warn = mkLongWarnMsg dflags loc printer
1140                                     msg extra_info } ;
1141          reportWarning reason warn }
1142
1143 tcInitTidyEnv :: TcM TidyEnv
1144 tcInitTidyEnv
1145   = do  { lcl_env <- getLclEnv
1146         ; return (tcl_tidy lcl_env) }
1147
1148 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1149 -- type. Useful when tidying open types.
1150 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1151 tcInitOpenTidyEnv tvs
1152   = do { env1 <- tcInitTidyEnv
1153        ; let env2 = tidyFreeTyCoVars env1 tvs
1154        ; return env2 }
1155
1156
1157 {-
1158 -----------------------------------
1159         Other helper functions
1160 -}
1161
1162 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1163             -> [ErrCtxt]
1164             -> TcM ()
1165 add_err_tcm tidy_env err_msg loc ctxt
1166  = do { err_info <- mkErrInfo tidy_env ctxt ;
1167         addLongErrAt loc err_msg err_info }
1168
1169 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1170 -- Tidy the error info, trimming excessive contexts
1171 mkErrInfo env ctxts
1172 --  | opt_PprStyle_Debug     -- In -dppr-debug style the output
1173 --  = return empty           -- just becomes too voluminous
1174  | otherwise
1175  = go 0 env ctxts
1176  where
1177    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1178    go _ _   [] = return empty
1179    go n env ((is_landmark, ctxt) : ctxts)
1180      | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1181      = do { (env', msg) <- ctxt env
1182           ; let n' = if is_landmark then n else n+1
1183           ; rest <- go n' env' ctxts
1184           ; return (msg $$ rest) }
1185      | otherwise
1186      = go n env ctxts
1187
1188 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
1189 mAX_CONTEXTS = 3
1190
1191 -- debugTc is useful for monadic debugging code
1192
1193 debugTc :: TcM () -> TcM ()
1194 debugTc thing
1195  | debugIsOn = thing
1196  | otherwise = return ()
1197
1198 {-
1199 ************************************************************************
1200 *                                                                      *
1201              Type constraints
1202 *                                                                      *
1203 ************************************************************************
1204 -}
1205
1206 newTcEvBinds :: TcM EvBindsVar
1207 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1208                   ; uniq <- newUnique
1209                   ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1210                   ; return (EvBindsVar ref uniq) }
1211
1212 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1213 -- Add a binding to the TcEvBinds by side effect
1214 addTcEvBind (EvBindsVar ev_ref u) ev_bind
1215   = do { traceTc "addTcEvBind" $ ppr u $$
1216                                  ppr ev_bind
1217        ; bnds <- readTcRef ev_ref
1218        ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1219
1220 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1221 getTcEvBinds (EvBindsVar ev_ref _)
1222   = do { bnds <- readTcRef ev_ref
1223        ; return (evBindMapBinds bnds) }
1224
1225 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1226 getTcEvBindsMap (EvBindsVar ev_ref _)
1227   = readTcRef ev_ref
1228
1229 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1230 chooseUniqueOccTc fn =
1231   do { env <- getGblEnv
1232      ; let dfun_n_var = tcg_dfun_n env
1233      ; set <- readTcRef dfun_n_var
1234      ; let occ = fn set
1235      ; writeTcRef dfun_n_var (extendOccSet set occ)
1236      ; return occ }
1237
1238 getConstraintVar :: TcM (TcRef WantedConstraints)
1239 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1240
1241 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1242 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1243
1244 emitConstraints :: WantedConstraints -> TcM ()
1245 emitConstraints ct
1246   = do { lie_var <- getConstraintVar ;
1247          updTcRef lie_var (`andWC` ct) }
1248
1249 emitSimple :: Ct -> TcM ()
1250 emitSimple ct
1251   = do { lie_var <- getConstraintVar ;
1252          updTcRef lie_var (`addSimples` unitBag ct) }
1253
1254 emitSimples :: Cts -> TcM ()
1255 emitSimples cts
1256   = do { lie_var <- getConstraintVar ;
1257          updTcRef lie_var (`addSimples` cts) }
1258
1259 emitImplication :: Implication -> TcM ()
1260 emitImplication ct
1261   = do { lie_var <- getConstraintVar ;
1262          updTcRef lie_var (`addImplics` unitBag ct) }
1263
1264 emitImplications :: Bag Implication -> TcM ()
1265 emitImplications ct
1266   = unless (isEmptyBag ct) $
1267     do { lie_var <- getConstraintVar ;
1268          updTcRef lie_var (`addImplics` ct) }
1269
1270 emitInsoluble :: Ct -> TcM ()
1271 emitInsoluble ct
1272   = do { lie_var <- getConstraintVar ;
1273          updTcRef lie_var (`addInsols` unitBag ct) ;
1274          v <- readTcRef lie_var ;
1275          traceTc "emitInsoluble" (ppr v) }
1276
1277 -- | Throw out any constraints emitted by the thing_inside
1278 discardConstraints :: TcM a -> TcM a
1279 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1280
1281 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1282 -- (captureConstraints m) runs m, and returns the type constraints it generates
1283 captureConstraints thing_inside
1284   = do { lie_var <- newTcRef emptyWC ;
1285          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1286                           thing_inside ;
1287          lie <- readTcRef lie_var ;
1288          return (res, lie) }
1289
1290 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1291 pushLevelAndCaptureConstraints thing_inside
1292   = do { env <- getLclEnv
1293        ; lie_var <- newTcRef emptyWC
1294        ; let tclvl' = pushTcLevel (tcl_tclvl env)
1295        ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1296                                , tcl_lie   = lie_var })
1297                 thing_inside
1298        ; lie <- readTcRef lie_var
1299        ; return (tclvl', lie, res) }
1300
1301 pushTcLevelM_ :: TcM a -> TcM a
1302 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1303
1304 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1305 -- See Note [TcLevel assignment]
1306 pushTcLevelM thing_inside
1307   = do { env <- getLclEnv
1308        ; let tclvl' = pushTcLevel (tcl_tclvl env)
1309        ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1310                           thing_inside
1311        ; return (res, tclvl') }
1312
1313 getTcLevel :: TcM TcLevel
1314 getTcLevel = do { env <- getLclEnv
1315                 ; return (tcl_tclvl env) }
1316
1317 setTcLevel :: TcLevel -> TcM a -> TcM a
1318 setTcLevel tclvl thing_inside
1319   = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1320
1321 isTouchableTcM :: TcTyVar -> TcM Bool
1322 isTouchableTcM tv
1323   = do { env <- getLclEnv
1324        ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1325
1326 getLclTypeEnv :: TcM TcTypeEnv
1327 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1328
1329 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1330 -- Set the local type envt, but do *not* disturb other fields,
1331 -- notably the lie_var
1332 setLclTypeEnv lcl_env thing_inside
1333   = updLclEnv upd thing_inside
1334   where
1335     upd env = env { tcl_env = tcl_env lcl_env,
1336                     tcl_tyvars = tcl_tyvars lcl_env }
1337
1338 traceTcConstraints :: String -> TcM ()
1339 traceTcConstraints msg
1340   = do { lie_var <- getConstraintVar
1341        ; lie     <- readTcRef lie_var
1342        ; traceTc (msg ++ ": LIE:") (ppr lie)
1343        }
1344
1345 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1346 emitWildCardHoleConstraints wcs
1347   = do { ctLoc <- getCtLocM HoleOrigin Nothing
1348        ; forM_ wcs $ \(name, tv) -> do {
1349        ; let real_span = case nameSrcSpan name of
1350                            RealSrcSpan span  -> span
1351                            UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1352                                                       (ppr name <+> quotes (ftext str))
1353                -- Wildcards are defined locally, and so have RealSrcSpans
1354              ctLoc' = setCtLocSpan ctLoc real_span
1355              ty     = mkTyVarTy tv
1356              can    = CHoleCan { cc_ev   = CtDerived { ctev_pred = ty
1357                                                      , ctev_loc  = ctLoc' }
1358                                , cc_hole = TypeHole (occName name) }
1359        ; emitInsoluble can } }
1360
1361 {-
1362 ************************************************************************
1363 *                                                                      *
1364              Template Haskell context
1365 *                                                                      *
1366 ************************************************************************
1367 -}
1368
1369 recordThUse :: TcM ()
1370 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1371
1372 recordThSpliceUse :: TcM ()
1373 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1374
1375 -- | When generating an out-of-scope error message for a variable matching a
1376 -- binding in a later inter-splice group, the typechecker uses the splice
1377 -- locations to provide details in the message about the scope of that binding.
1378 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1379 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1380   = do { env <- getGblEnv
1381        ; let locs_var = tcg_th_top_level_locs env
1382        ; locs0 <- readTcRef locs_var
1383        ; writeTcRef locs_var (Set.insert real_loc locs0) }
1384 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1385
1386 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1387 getTopLevelSpliceLocs
1388   = do { env <- getGblEnv
1389        ; readTcRef (tcg_th_top_level_locs env) }
1390
1391 keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
1392 keepAlive name
1393   = do { env <- getGblEnv
1394        ; traceRn (text "keep alive" <+> ppr name)
1395        ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1396
1397 getStage :: TcM ThStage
1398 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1399
1400 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1401 getStageAndBindLevel name
1402   = do { env <- getLclEnv;
1403        ; case lookupNameEnv (tcl_th_bndrs env) name of
1404            Nothing                  -> return Nothing
1405            Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1406
1407 setStage :: ThStage -> TcM a -> TcRn a
1408 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1409
1410 {-
1411 ************************************************************************
1412 *                                                                      *
1413              Safe Haskell context
1414 *                                                                      *
1415 ************************************************************************
1416 -}
1417
1418 -- | Mark that safe inference has failed
1419 -- See Note [Safe Haskell Overlapping Instances Implementation]
1420 -- although this is used for more than just that failure case.
1421 recordUnsafeInfer :: WarningMessages -> TcM ()
1422 recordUnsafeInfer warns =
1423     getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1424
1425 -- | Figure out the final correct safe haskell mode
1426 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1427 finalSafeMode dflags tcg_env = do
1428     safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1429     return $ case safeHaskell dflags of
1430         Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1431                 | otherwise                     -> Sf_None
1432         s -> s
1433
1434 -- | Switch instances to safe instances if we're in Safe mode.
1435 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1436 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1437 fixSafeInstances _ = map fixSafe
1438   where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1439                        in inst { is_flag = new_flag }
1440
1441 {-
1442 ************************************************************************
1443 *                                                                      *
1444              Stuff for the renamer's local env
1445 *                                                                      *
1446 ************************************************************************
1447 -}
1448
1449 getLocalRdrEnv :: RnM LocalRdrEnv
1450 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1451
1452 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1453 setLocalRdrEnv rdr_env thing_inside
1454   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1455
1456 {-
1457 ************************************************************************
1458 *                                                                      *
1459              Stuff for interface decls
1460 *                                                                      *
1461 ************************************************************************
1462 -}
1463
1464 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1465 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
1466                                 if_loc     = loc,
1467                                 if_tv_env  = emptyFsEnv,
1468                                 if_id_env  = emptyFsEnv }
1469
1470 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1471 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1472 -- based on 'TcGblEnv'.
1473 initIfaceTcRn :: IfG a -> TcRn a
1474 initIfaceTcRn thing_inside
1475   = do  { tcg_env <- getGblEnv
1476         ; let { if_env = IfGblEnv {
1477                             if_doc = text "initIfaceTcRn",
1478                             if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1479                          }
1480               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1481         ; setEnvs (if_env, ()) thing_inside }
1482
1483 initIfaceCheck :: HscEnv -> IfG a -> IO a
1484 -- Used when checking the up-to-date-ness of the old Iface
1485 -- Initialise the environment with no useful info at all
1486 initIfaceCheck hsc_env do_this
1487  = do let rec_types = case hsc_type_env_var hsc_env of
1488                          Just (mod,var) -> Just (mod, readTcRef var)
1489                          Nothing        -> Nothing
1490           gbl_env = IfGblEnv {
1491                         if_doc = text "initIfaceCheck",
1492                         if_rec_types = rec_types
1493                     }
1494       initTcRnIf 'i' hsc_env gbl_env () do_this
1495
1496 initIfaceTc :: ModIface
1497             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1498 -- Used when type-checking checking an up-to-date interface file
1499 -- No type envt from the current module, but we do know the module dependencies
1500 initIfaceTc iface do_this
1501  = do   { tc_env_var <- newTcRef emptyTypeEnv
1502         ; let { gbl_env = IfGblEnv {
1503                             if_doc = text "initIfaceTc",
1504                             if_rec_types = Just (mod, readTcRef tc_env_var)
1505                           } ;
1506               ; if_lenv = mkIfLclEnv mod doc
1507            }
1508         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1509     }
1510   where
1511     mod = mi_module iface
1512     doc = text "The interface for" <+> quotes (ppr mod)
1513
1514 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1515 initIfaceLcl mod loc_doc thing_inside
1516   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1517
1518 getIfModule :: IfL Module
1519 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1520
1521 --------------------
1522 failIfM :: MsgDoc -> IfL a
1523 -- The Iface monad doesn't have a place to accumulate errors, so we
1524 -- just fall over fast if one happens; it "shouldnt happen".
1525 -- We use IfL here so that we can get context info out of the local env
1526 failIfM msg
1527   = do  { env <- getLclEnv
1528         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1529         ; dflags <- getDynFlags
1530         ; liftIO (log_action dflags dflags NoReason SevFatal
1531                    noSrcSpan (defaultErrStyle dflags) full_msg)
1532         ; failM }
1533
1534 --------------------
1535 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1536 -- Run thing_inside in an interleaved thread.
1537 -- It shares everything with the parent thread, so this is DANGEROUS.
1538 --
1539 -- It returns Nothing if the computation fails
1540 --
1541 -- It's used for lazily type-checking interface
1542 -- signatures, which is pretty benign
1543
1544 forkM_maybe doc thing_inside
1545  -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1546  --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1547  = do { child_us <- newUniqueSupply
1548       ; child_env_us <- newMutVar child_us
1549         -- see Note [Masking exceptions in forkM_maybe]
1550       ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1551         do { traceIf (text "Starting fork {" <+> doc)
1552            ; mb_res <- tryM $
1553                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1554                        thing_inside
1555            ; case mb_res of
1556                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1557                                 ; return (Just r) }
1558                 Left exn -> do {
1559
1560                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1561                     -- Otherwise we silently discard errors. Errors can legitimately
1562                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1563                       whenDOptM Opt_D_dump_if_trace $ do
1564                           dflags <- getDynFlags
1565                           let msg = hang (text "forkM failed:" <+> doc)
1566                                        2 (text (show exn))
1567                           liftIO $ log_action dflags
1568                                               dflags
1569                                               NoReason
1570                                               SevFatal
1571                                               noSrcSpan
1572                                               (defaultErrStyle dflags)
1573                                               msg
1574
1575                     ; traceIf (text "} ending fork (badly)" <+> doc)
1576                     ; return Nothing }
1577         }}
1578
1579 forkM :: SDoc -> IfL a -> IfL a
1580 forkM doc thing_inside
1581  = do   { mb_res <- forkM_maybe doc thing_inside
1582         ; return (case mb_res of
1583                         Nothing -> pgmError "Cannot continue after interface file error"
1584                                    -- pprPanic "forkM" doc
1585                         Just r  -> r) }
1586
1587 {-
1588 Note [Masking exceptions in forkM_maybe]
1589 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1590
1591 When using GHC-as-API it must be possible to interrupt snippets of code
1592 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1593 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1594 subtle problem: runStmt first typechecks the code before running it, and the
1595 exception might interrupt the type checker rather than the code. Moreover, the
1596 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1597 more importantly might be inside an exception handler inside that
1598 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1599 asynchronous exception as a synchronous exception, and the exception will end
1600 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1601 discussion).  We don't currently know a general solution to this problem, but
1602 we can use uninterruptibleMask_ to avoid the situation.
1603 -}