TcRnMonad.hs 53.7 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The University of Glasgow 2006

Simon Marlow's avatar
Simon Marlow committed
4

5
Functions for working with the typechecker environment (setters, getters...).
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
9
{-# OPTIONS_GHC -fno-warn-orphans #-}
10

11
module TcRnMonad(
12 13 14
        module TcRnMonad,
        module TcRnTypes,
        module IOEnv
15 16
  ) where

17 18
#include "HsVersions.h"

19 20
import TcRnTypes        -- Re-export all
import IOEnv            -- Re-export all
21
import TcEvidence
22

Simon Marlow's avatar
Simon Marlow committed
23 24 25 26 27
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
batterseapower's avatar
batterseapower committed
28
import Type
29

Simon Marlow's avatar
Simon Marlow committed
30 31 32
import TcType
import InstEnv
import FamInstEnv
33
import PrelNames
34

Simon Marlow's avatar
Simon Marlow committed
35 36 37 38 39 40 41 42
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
43
import Outputable
Simon Marlow's avatar
Simon Marlow committed
44
import UniqSupply
45
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
46 47 48 49
import DynFlags
import StaticFlags
import FastString
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
50
import Util
51
import Annotations
52
import BasicTypes( TopLevelFlag )
53

54
import Control.Exception
Simon Marlow's avatar
Simon Marlow committed
55
import Data.IORef
56
import Control.Monad
57 58 59 60

#ifdef GHCI
import qualified Data.Map as Map
#endif
61

Austin Seipp's avatar
Austin Seipp committed
62 63 64
{-
************************************************************************
*                                                                      *
65
                        initTc
Austin Seipp's avatar
Austin Seipp committed
66 67 68
*                                                                      *
************************************************************************
-}
mnislaih's avatar
mnislaih committed
69

70
-- | Setup the initial typechecking environment
71
initTc :: HscEnv
72
       -> HscSource
73 74
       -> Bool          -- True <=> retain renamed syntax trees
       -> Module
75
       -> RealSrcSpan
76
       -> TcM r
77
       -> IO (Messages, Maybe r)
78 79
                -- Nothing => error thrown by the thing inside
                -- (error messages should have been printed already)
80

81
initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
82
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
83
        tvs_var      <- newIORef emptyVarSet ;
84
        keep_var     <- newIORef emptyNameSet ;
85
        used_gre_var <- newIORef [] ;
86 87
        th_var       <- newIORef False ;
        th_splice_var<- newIORef False ;
88
        infer_var    <- newIORef (True, emptyBag) ;
89
        lie_var      <- newIORef emptyWC ;
90 91
        dfun_n_var   <- newIORef emptyOccSet ;
        type_env_var <- case hsc_type_env_var hsc_env of {
92 93
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
GregWeber's avatar
GregWeber committed
94 95

        dependent_files_var <- newIORef [] ;
96
        static_wc_var       <- newIORef emptyWC ;
97
#ifdef GHCI
98 99 100
        th_topdecls_var      <- newIORef [] ;
        th_topnames_var      <- newIORef emptyNameSet ;
        th_modfinalizers_var <- newIORef [] ;
101
        th_state_var         <- newIORef Map.empty ;
102
#endif /* GHCI */
103
        let {
104 105
             dflags = hsc_dflags hsc_env ;

106 107
             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax empty_val
108 109 110 111
                | keep_rn_syntax = Just empty_val
                | otherwise      = Nothing ;

             gbl_env = TcGblEnv {
112
#ifdef GHCI
113 114 115
                tcg_th_topdecls      = th_topdecls_var,
                tcg_th_topnames      = th_topnames_var,
                tcg_th_modfinalizers = th_modfinalizers_var,
116
                tcg_th_state         = th_state_var,
117 118
#endif /* GHCI */

119 120
                tcg_mod            = mod,
                tcg_src            = hsc_src,
121 122
                tcg_sig_of         = getSigOf dflags (moduleName mod),
                tcg_impl_rdr_env   = Nothing,
123 124
                tcg_rdr_env        = emptyGlobalRdrEnv,
                tcg_fix_env        = emptyNameEnv,
125
                tcg_field_env      = emptyNameEnv,
126
                tcg_default        = if moduleUnitId mod == primUnitId
127 128
                                     then Just []  -- See Note [Default types]
                                     else Nothing,
129 130 131 132
                tcg_type_env       = emptyNameEnv,
                tcg_type_env_var   = type_env_var,
                tcg_inst_env       = emptyInstEnv,
                tcg_fam_inst_env   = emptyFamInstEnv,
133
                tcg_ann_env        = emptyAnnEnv,
134 135 136 137
                tcg_th_used        = th_var,
                tcg_th_splice_used = th_splice_var,
                tcg_exports        = [],
                tcg_imports        = emptyImportAvails,
138
                tcg_used_gres     = used_gre_var,
139 140 141 142 143
                tcg_dus            = emptyDUs,

                tcg_rn_imports     = [],
                tcg_rn_exports     = maybe_rn_syntax [],
                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
144
                tcg_tr_module      = Nothing,
145 146 147 148 149 150 151 152 153 154 155 156
                tcg_binds          = emptyLHsBinds,
                tcg_imp_specs      = [],
                tcg_sigs           = emptyNameSet,
                tcg_ev_binds       = emptyBag,
                tcg_warns          = NoWarnings,
                tcg_anns           = [],
                tcg_tcs            = [],
                tcg_insts          = [],
                tcg_fam_insts      = [],
                tcg_rules          = [],
                tcg_fords          = [],
                tcg_vects          = [],
cactus's avatar
cactus committed
157
                tcg_patsyns        = [],
158 159 160 161 162
                tcg_dfun_n         = dfun_n_var,
                tcg_keep           = keep_var,
                tcg_doc_hdr        = Nothing,
                tcg_hpc            = False,
                tcg_main           = Nothing,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
163
                tcg_self_boot      = NoSelfBoot,
GregWeber's avatar
GregWeber committed
164
                tcg_safeInfer      = infer_var,
Adam Gundry's avatar
Adam Gundry committed
165
                tcg_dependent_files = dependent_files_var,
166 167
                tcg_tc_plugins     = [],
                tcg_static_wc      = static_wc_var
168 169 170
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
171
                tcl_loc        = loc,     -- Should be over-ridden very soon!
172 173 174
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
175
                tcl_th_bndrs   = emptyNameEnv,
176 177
                tcl_arrow_ctxt = NoArrowCtxt,
                tcl_env        = emptyNameEnv,
178
                tcl_bndrs      = [],
179
                tcl_tidy       = emptyTidyEnv,
180 181
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
182
                tcl_tclvl      = topTcLevel
183 184 185 186 187 188 189 190 191
             } ;
        } ;

        -- OK, here's the business end!
        maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
                     do { r <- tryM do_this
                        ; case r of
                          Right res -> return (Just res)
                          Left _    -> return Nothing } ;
192

193
        -- Check for unsolved constraints
194
        lie <- readIORef lie_var ;
195
        if isEmptyWC lie
196
           then return ()
197
           else pprPanic "initTc: unsolved constraints" (ppr lie) ;
198

199 200
        -- Collect any error messages
        msgs <- readIORef errs_var ;
201

202
        let { final_res | errorsFound dflags msgs = Nothing
203
                        | otherwise               = maybe_res } ;
204

205
        return (msgs, final_res)
206
    }
207

208

209 210 211 212 213
initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive hsc_env thing_inside
  = initTc hsc_env HsSrcFile False
           (icInteractiveModule (hsc_IC hsc_env))
214
           (realSrcLocSpan interactive_src_loc)
215
           thing_inside
216 217
  where
    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
218 219

initTcForLookup :: HscEnv -> TcM a -> IO a
220 221 222
-- The thing_inside is just going to look up something
-- in the environment, so we don't need much setup
initTcForLookup hsc_env thing_inside
223 224
  = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
       ; case m of
225
             Nothing -> throwIO $ mkSrcErr $ snd msgs
226
             Just x -> return x }
227

228 229 230 231 232 233 234 235 236 237 238
{- Note [Default types]
~~~~~~~~~~~~~~~~~~~~~~~
The Integer type is simply not available in package ghc-prim (it is
declared in integer-gmp).  So we set the defaulting types to (Just
[]), meaning there are no default types, rather then Nothing, which
means "use the default default types of Integer, Double".

If you don't do this, attempted defaulting in package ghc-prim causes
an actual crash (attempting to look up the Integer type).


Austin Seipp's avatar
Austin Seipp committed
239 240
************************************************************************
*                                                                      *
241
                Initialisation
Austin Seipp's avatar
Austin Seipp committed
242 243 244
*                                                                      *
************************************************************************
-}
245

246 247 248 249 250
initTcRnIf :: Char              -- Tag for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
251
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
252 253
   = do { us     <- mkSplitUniqSupply uniq_tag ;
        ; us_var <- newIORef us ;
254

255 256 257 258
        ; let { env = Env { env_top = hsc_env,
                            env_us  = us_var,
                            env_gbl = gbl_env,
                            env_lcl = lcl_env} }
259

260 261
        ; runIOEnv env thing_inside
        }
262

Austin Seipp's avatar
Austin Seipp committed
263 264 265
{-
************************************************************************
*                                                                      *
266
                Simple accessors
Austin Seipp's avatar
Austin Seipp committed
267 268 269
*                                                                      *
************************************************************************
-}
270

271 272 273
discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()

274
getTopEnv :: TcRnIf gbl lcl HscEnv
275 276
getTopEnv = do { env <- getEnv; return (env_top env) }

277
getGblEnv :: TcRnIf gbl lcl gbl
278 279
getGblEnv = do { env <- getEnv; return (env_gbl env) }

280
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
281 282
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                          env { env_gbl = upd gbl })
283

284
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
285 286
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

287
getLclEnv :: TcRnIf gbl lcl lcl
288 289
getLclEnv = do { env <- getEnv; return (env_lcl env) }

290
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
291 292
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                          env { env_lcl = upd lcl })
293

294
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
295
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
296

297
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
298 299
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

300
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
301
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
302

Austin Seipp's avatar
Austin Seipp committed
303
-- Command-line flags
304

305
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
306
xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
307

308 309 310
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }

ian@well-typed.com's avatar
ian@well-typed.com committed
311 312
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
313

314
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
315
woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
316

317 318 319
setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                          env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
320

ian@well-typed.com's avatar
ian@well-typed.com committed
321 322 323
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                            env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
324

325 326 327 328
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                            env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )

329
-- | Do it flag is true
330 331 332 333
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
                                 when b thing_inside

ian@well-typed.com's avatar
ian@well-typed.com committed
334 335 336
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
                                 when b thing_inside
337

ian@well-typed.com's avatar
ian@well-typed.com committed
338 339 340
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag thing_inside = do b <- woptM flag
                                 when b thing_inside
341

ian@well-typed.com's avatar
ian@well-typed.com committed
342 343 344
whenXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
                                 when b thing_inside
345

346 347
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
348

349 350 351
withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDoDynamicToo m = do env <- getEnv
                        let dflags = extractDynFlags env
352
                            dflags' = dynamicTooMkDynamicDynFlags dflags
353 354 355
                            env' = replaceDynFlags env dflags'
                        setEnv env' m

356 357 358 359 360 361
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }

362 363 364 365 366
-- | Update the external package state.  Returns the second result of the
-- modifier function.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
367
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
368
          -> TcRnIf gbl lcl a
369 370 371 372 373 374 375 376 377
updateEps upd_fn = do
  traceIf (text "updating EPS")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var upd_fn

-- | Update the external package state.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
378
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
379
           -> TcRnIf gbl lcl ()
380 381 382 383
updateEps_ upd_fn = do
  traceIf (text "updating EPS_")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
384 385 386

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
387 388 389

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
390
                  ; return (eps, hsc_HPT env) }
391

392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413
{-
************************************************************************
*                                                                      *
                Arrow scopes
*                                                                      *
************************************************************************
-}

newArrowScope :: TcM a -> TcM a
newArrowScope
  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
  = updLclEnv $ \ env ->
    case tcl_arrow_ctxt env of
      NoArrowCtxt       -> env
      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
                                   , tcl_lie = lie
                                   , tcl_rdr = rdr_env }

Austin Seipp's avatar
Austin Seipp committed
414 415 416
{-
************************************************************************
*                                                                      *
417
                Unique supply
Austin Seipp's avatar
Austin Seipp committed
418 419 420
*                                                                      *
************************************************************************
-}
421 422

newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
423 424
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
425 426
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
427 428 429
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
430 431 432 433 434 435
   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
   -- a chain of unevaluated supplies behind.
   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
   -- throw away one half of the new split supply.  This is safe because this
   -- is the only place we use that unique.  Using the other half of the split
   -- supply is safer, but slower.
436 437 438 439

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
440 441
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
442
        case splitUniqSupply us of { (us1,us2) -> do {
Ian Lynagh's avatar
Ian Lynagh committed
443 444
        writeMutVar u_var us1 ;
        return us2 }}}
445

446 447
newLocalName :: Name -> TcM Name
newLocalName name = newName (nameOccName name)
batterseapower's avatar
batterseapower committed
448

batterseapower's avatar
batterseapower committed
449 450 451 452 453 454
newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

455 456 457 458 459
newSysName :: OccName -> TcM Name
newSysName occ
  = do { uniq <- newUnique
       ; return (mkSystemName uniq occ) }

460 461 462 463 464
newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs ty
  = do  { u <- newUnique
        ; return (mkSysLocal fs u ty) }

465 466 467 468 469
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
  = do  { us <- newUniqueSupply
        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }

batterseapower's avatar
batterseapower committed
470 471 472
instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
473

Austin Seipp's avatar
Austin Seipp committed
474 475 476
{-
************************************************************************
*                                                                      *
477
                Accessing input/output
Austin Seipp's avatar
Austin Seipp committed
478 479 480
*                                                                      *
************************************************************************
-}
481

482
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
483
newTcRef = newMutVar
484 485 486 487 488 489 490 491

readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = readMutVar

writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = writeMutVar

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
492 493 494 495 496 497 498 499 500
-- Returns ()
updTcRef ref fn = liftIO $ do { old <- readIORef ref
                              ; writeIORef ref (fn old) }

updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
-- Returns previous value
updTcRefX ref fn = liftIO $ do { old <- readIORef ref
                              ; writeIORef ref (fn old)
                              ; return old }
501

Austin Seipp's avatar
Austin Seipp committed
502 503 504
{-
************************************************************************
*                                                                      *
505
                Debugging
Austin Seipp's avatar
Austin Seipp committed
506 507 508
*                                                                      *
************************************************************************
-}
509

510
traceTc :: String -> SDoc -> TcRn ()
511
traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
512

513
-- | Typechecker trace
514 515
traceTcN :: Int -> SDoc -> TcRn ()
traceTcN level doc
516 517 518
    = do dflags <- getDynFlags
         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
             traceOptTcRn Opt_D_dump_tc_trace doc
519

520
traceRn :: SDoc -> TcRn ()
521
traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
522

523 524 525 526 527 528
-- | Output a doc if the given 'DumpFlag' is set.
--
-- By default this logs to stdout
-- However, if the `-ddump-to-file` flag is set,
-- then this will dump output to a file
--
529
-- Just a wrapper for 'dumpSDoc'
530
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
531
traceOptTcRn flag doc
532
  = do { dflags <- getDynFlags
533 534 535 536 537 538 539 540 541 542 543 544 545 546
       ; when (dopt flag dflags) (traceTcRn flag doc)
    }

traceTcRn :: DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
--
-- The DumpFlag is used only to set the output filename
-- for --dump-to-file, not to decide whether or not to output
-- That part is done by the caller
traceTcRn flag doc
  = do { real_doc <- prettyDoc doc
       ; dflags   <- getDynFlags
       ; printer  <- getPrintUnqualified dflags
       ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }
547
  where
548
    -- Add current location if opt_PprStyle_Debug
549 550 551 552 553 554 555 556 557 558 559 560
    prettyDoc :: SDoc -> TcRn SDoc
    prettyDoc doc = if opt_PprStyle_Debug
       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
       else return doc -- The full location is usually way too much


getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags
  = do { rdr_env <- getGlobalRdrEnv
       ; return $ mkPrintUnqualified dflags rdr_env }

-- | Like logInfoTcRn, but for user consumption
561 562 563
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn doc
  = do { dflags <- getDynFlags
564
       ; printer <- getPrintUnqualified dflags
565
       ; liftIO (printOutputForUser dflags printer doc) }
566

567
-- | Typechecker debug
568
debugDumpTcRn :: SDoc -> TcRn ()
569
debugDumpTcRn doc = unless opt_NoDebugOutput $
570
                    traceOptTcRn Opt_D_dump_tc doc
571

Austin Seipp's avatar
Austin Seipp committed
572
{-
573 574 575
traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
available.  Alas, they behave inconsistently with the other stuff;
e.g. are unaffected by -dump-to-file.
Austin Seipp's avatar
Austin Seipp committed
576
-}
577 578 579 580 581 582 583 584 585 586 587

traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs


traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
  = whenDOptM flag $    -- No RdrEnv available, so qualify everything
    do { dflags <- getDynFlags
       ; liftIO (putMsg dflags doc) }
588

Austin Seipp's avatar
Austin Seipp committed
589 590 591
{-
************************************************************************
*                                                                      *
592
                Typechecker global environment
Austin Seipp's avatar
Austin Seipp committed
593 594 595
*                                                                      *
************************************************************************
-}
596

597 598 599
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

600
getIsGHCi :: TcRn Bool
601 602
getIsGHCi = do { mod <- getModule
               ; return (isInteractiveModule mod) }
603

dterei's avatar
dterei committed
604 605 606
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }

607 608 609
getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }

610
tcIsHsBootOrSig :: TcRn Bool
611
tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
612

Simon Peyton Jones's avatar
Simon Peyton Jones committed
613 614 615
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }

616
getGlobalRdrEnv :: TcRn GlobalRdrEnv
617 618
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

619 620 621
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

622
getImports :: TcRn ImportAvails
623 624
getImports = do { env <- getGblEnv; return (tcg_imports env) }

625
getFixityEnv :: TcRn FixityEnv
626 627
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

628
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
629
extendFixityEnv new_bit
630 631
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
632

633 634 635
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

636 637
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
638 639 640 641 642 643

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
  ref <- fmap tcg_dependent_files getGblEnv
  dep_files <- readTcRef ref
  writeTcRef ref (fs ++ dep_files)
644

Austin Seipp's avatar
Austin Seipp committed
645 646 647
{-
************************************************************************
*                                                                      *
648
                Error management
Austin Seipp's avatar
Austin Seipp committed
649 650 651
*                                                                      *
************************************************************************
-}
652

653
getSrcSpanM :: TcRn SrcSpan
654
        -- Avoid clash with Name.getSrcLoc
655
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
656

657
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
658 659
setSrcSpan (RealSrcSpan real_loc) thing_inside
    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
660 661
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
662 663

addLocM :: (a -> TcM b) -> Located a -> TcM b
664
addLocM fn (L loc a) = setSrcSpan loc $ fn a
665 666

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
667
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
668 669 670

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
671
  setSrcSpan loc $ do
672 673 674 675 676
    (b,c) <- fn a
    return (L loc b, c)

wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
677
  setSrcSpan loc $ do
678 679
    (b,c) <- fn a
    return (b, L loc c)
680

Austin Seipp's avatar
Austin Seipp committed
681
-- Reporting errors
682

683 684 685 686 687 688
getErrsVar :: TcRn (TcRef Messages)
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }

setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })

689
addErr :: MsgDoc -> TcRn ()    -- Ignores the context stack
690
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
691

692
failWith :: MsgDoc -> TcRn a
693 694
failWith msg = addErr msg >> failM

thomasw's avatar
thomasw committed
695 696 697
failAt :: SrcSpan -> MsgDoc -> TcRn a
failAt loc msg = addErrAt loc msg >> failM

698
addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
699 700 701
-- addErrAt is mainly (exclusively?) used by the renamer, where
-- tidying is not an issue, but it's all lazy so the extra
-- work doesn't matter
702 703
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
704
                      ; err_info <- mkErrInfo tidy_env ctxt
705
                      ; addLongErrAt loc msg err_info }
706

707
addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
708
addErrs msgs = mapM_ add msgs
709 710
             where
               add (loc,msg) = addErrAt loc msg
711

712
checkErr :: Bool -> MsgDoc -> TcRn ()
713
-- Add the error if the bool is False
714
checkErr ok msg = unless ok (addErr msg)
715

716
warnIf :: Bool -> MsgDoc -> TcRn ()
717
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
718
warnIf False _   = return ()
719

720
addMessages :: Messages -> TcRn ()
721 722
addMessages (m_warns, m_errs)
  = do { errs_var <- getErrsVar ;
723 724 725
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `unionBags` m_warns,
                               errs  `unionBags` m_errs) }
726 727 728 729 730

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
731 732 733 734 735 736 737
  = do  { errs_var <- getErrsVar
        ; (old_warns, _) <- readTcRef errs_var ;

        ; result <- thing_inside

        -- Revert warnings to old_warns
        ; (_new_warns, new_errs) <- readTcRef errs_var
Austin Seipp's avatar
Austin Seipp committed
738
        ; writeTcRef errs_var (old_warns, new_errs)
739

740
        ; return result }
741

Austin Seipp's avatar
Austin Seipp committed
742 743 744
{-
************************************************************************
*                                                                      *
745
        Shared error message stuff: renamer and typechecker
Austin Seipp's avatar
Austin Seipp committed
746 747 748
*                                                                      *
************************************************************************
-}
749

750 751
mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
752 753 754
  = do { dflags <- getDynFlags ;
         printer <- getPrintUnqualified dflags ;
         return $ mkLongErrMsg dflags loc printer msg extra }
755

756 757 758 759 760 761
mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
mkErrDocAt loc errDoc
  = do { dflags <- getDynFlags ;
         printer <- getPrintUnqualified dflags ;
         return $ mkErrDoc dflags loc printer errDoc }

762 763 764 765 766 767 768 769
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError

reportErrors :: [ErrMsg] -> TcM ()
reportErrors = mapM_ reportError

reportError :: ErrMsg -> TcRn ()
reportError err
770 771
  = do { traceTc "Adding error:" (pprLocErrMsg err) ;
         errs_var <- getErrsVar ;
772 773
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns, errs `snocBag` err) }
774

775
reportWarning :: ErrMsg -> TcRn ()
776 777
reportWarning err
  = do { let warn = makeIntoWarning err
778
                    -- 'err' was built by mkLongErrMsg or something like that,
779 780 781 782 783 784 785
                    -- so it's of error severity.  For a warning we downgrade
                    -- its severity to SevWarning

       ; traceTc "Adding warning:" (pprLocErrMsg warn)
       ; errs_var <- getErrsVar
       ; (warns, errs) <- readTcRef errs_var
       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
786

787
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
788
-- Does tryM, with a debug-trace on failure
789
try_m thing
790
  = do { mb_r <- tryM thing ;
791 792
         case mb_r of
             Left exn -> do { traceTc "tryTc/recoverM recovering from" $
793 794
                                      text (showException exn)
                            ; return mb_r }
795
             Right _  -> return mb_r }
796 797

-----------------------
798 799 800
recoverM :: TcRn r      -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first
         -> TcRn r
801
-- Errors in 'thing' are retained
802
recoverM recover thing
803
  = do { mb_res <- try_m thing ;
804 805 806
         case mb_res of
           Left _    -> recover
           Right res -> return res }
807

808 809 810 811 812

-----------------------
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-- Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
Ian Lynagh's avatar
Ian Lynagh committed
813
mapAndRecoverM _ []     = return []
814
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
815 816 817 818 819
                             ; rs <- mapAndRecoverM f xs
                             ; return (case mb_r of
                                          Left _  -> rs
                                          Right r -> r:rs) }

820 821 822 823
-- | Succeeds if applying the argument to all members of the lists succeeds,
--   but nevertheless runs it on all arguments, to collect all errors.
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
824

825
-----------------------
826
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
827
-- (tryTc m) executes m, and returns
828 829
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
830 831
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
832 833 834 835 836 837 838 839 840
tryTc m
 = do { errs_var <- newTcRef emptyMessages ;
        res  <- try_m (setErrsVar errs_var m) ;
        msgs <- readTcRef errs_var ;
        return (msgs, case res of
                            Left _  -> Nothing
                            Right val -> Just val)
        -- The exception is always the IOEnv built-in
        -- in exception; see IOEnv.failM
841 842
   }

Jan Stolarek's avatar
Jan Stolarek committed
843 844 845 846 847 848 849 850 851 852 853 854 855
-- (askNoErrs m) runs m
-- If m fails, (askNoErrs m) fails
-- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
--  where b is True iff m generated no error
-- Regardless of success or failure, any errors generated by m are propagated
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs m
 = do { errs_var <- newTcRef emptyMessages
      ; res  <- setErrsVar errs_var m
      ; (warns, errs) <- readTcRef errs_var
      ; addMessages (warns, errs)
      ; return (res, isEmptyBag errs) }

856 857
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
858 859 860
-- Run the thing, returning
--      Just r,  if m succceeds with no error messages
--      Nothing, if m fails, or if it succeeds but has error messages
861 862
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
863
tryTcErrs thing
864
  = do  { (msgs, res) <- tryTc thing
865
        ; dflags <- getDynFlags
866 867 868 869 870 871
        ; let errs_found = errorsFound dflags msgs
        ; return (msgs, case res of
                          Nothing -> Nothing
                          Just val | errs_found -> Nothing
                                   | otherwise  -> Just val)
        }
872

873
-----------------------
874
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
875
-- Just like tryTcErrs, except that it ensures that the LIE
876 877
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
878
tryTcLIE thing_inside
879
  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
880 881 882 883
        ; case mb_res of
            Nothing  -> return (msgs, Nothing)
            Just val -> do { emitConstraints lie; return (msgs, Just val) }
        }
884

885
-----------------------
886
tryTcLIE_ :: TcM r -> TcM r -> TcM r
887 888 889
-- (tryTcLIE_ r m) tries m;
--      if m succeeds with no error messages, it's the answer
--      otherwise tryTcLIE_ drops everything from m and tries r instead.
890
tryTcLIE_ recover main
891 892 893 894 895 896
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; case mb_res of
             Just val -> do { addMessages msgs  -- There might be warnings
                             ; return val }
             Nothing  -> recover                -- Discard all msgs
        }
897

898
-----------------------
899 900 901 902
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
903 904
--      (it might have recovered internally)
--      If so, it fails too.
905 906
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
907 908 909 910 911 912
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
            Nothing  -> failM
            Just val -> return val
        }
913

914 915 916
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing

917
ifErrsM :: TcRn r -> TcRn r -> TcRn r
918
--      ifErrsM bale_out normal
919
-- does 'bale_out' if there are errors in errors collection
920
-- otherwise does 'normal'
921 922
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
923
        msgs <- readTcRef errs_var ;
924
        dflags <- getDynFlags ;
925 926 927 928
        if errorsFound dflags msgs then
           bale_out
        else
           normal }
929

930
failIfErrsM :: TcRn ()
931 932
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
933 934

#ifdef GHCI
935
checkTH :: a -> String -> TcRn ()
936 937
checkTH _ _ = return () -- OK
#else
938
checkTH :: Outputable a => a -> String -> TcRn ()
939 940 941 942 943
checkTH e what = failTH e what  -- Raise an error in a stage-1 compiler
#endif

failTH :: Outputable a => a -> String -> TcRn x
failTH e what  -- Raise an error in a stage-1 compiler
944 945 946 947
  = failWithTc (vcat [ hang (char 'A' <+> text what
                             <+> ptext (sLit "requires GHC with interpreter support:"))
                          2 (ppr e)
                     , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
948

Austin Seipp's avatar
Austin Seipp committed
949 950 951
{-
************************************************************************
*                                                                      *
952
        Context management for the type checker
Austin Seipp's avatar
Austin Seipp committed
953 954 955
*                                                                      *
************************************************************************
-}
956

957
getErrCtxt :: TcM [ErrCtxt]
958
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
959

960
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
961
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
962

963
addErrCtxt :: MsgDoc -> TcM a -> TcM a
964
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
965

966
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
967 968
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

Simon Peyton Jones's avatar