TcRnMonad.lhs 37.1 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2 3 4
%
% (c) The University of Glasgow 2006
%

5
\begin{code}
6 7
module TcRnMonad(
	module TcRnMonad,
8 9
	module TcRnTypes,
	module IOEnv
10 11
  ) where

12 13
#include "HsVersions.h"

14 15 16
import TcRnTypes	-- Re-export all
import IOEnv		-- Re-export all

Simon Marlow's avatar
Simon Marlow committed
17 18 19 20 21 22 23 24
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv
25
import PrelNames        ( iNTERACTIVE )
26

Simon Marlow's avatar
Simon Marlow committed
27 28 29 30 31 32 33 34 35
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
36
import Outputable
Simon Marlow's avatar
Simon Marlow committed
37 38
import UniqSupply
import Unique
39
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
40 41 42 43
import DynFlags
import StaticFlags
import FastString
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
44
import Util
45

Simon Marlow's avatar
Simon Marlow committed
46 47
import System.IO
import Data.IORef
48
import qualified Data.Set as Set
49
import Control.Monad
50 51 52 53 54 55 56 57 58 59
\end{code}



%************************************************************************
%*									*
			initTc
%*									*
%************************************************************************

60
\begin{code}
mnislaih's avatar
mnislaih committed
61

62
initTc :: HscEnv
63
       -> HscSource
64
       -> Bool		-- True <=> retain renamed syntax trees
65 66
       -> Module 
       -> TcM r
67
       -> IO (Messages, Maybe r)
68 69 70
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

71
initTc hsc_env hsc_src keep_rn_syntax mod do_this
72
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
73
        meta_var     <- newIORef initTyVarUnique ;
74
      	tvs_var      <- newIORef emptyVarSet ;
75
        keep_var     <- newIORef emptyNameSet ;
76
        used_rdr_var <- newIORef Set.empty ;
77
	th_var	     <- newIORef False ;
78
        lie_var      <- newIORef emptyWC ;
79
	dfun_n_var   <- newIORef emptyOccSet ;
80 81 82
	type_env_var <- case hsc_type_env_var hsc_env of {
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
83
      	let {
84 85
             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax empty_val
86 87 88
		| keep_rn_syntax = Just empty_val
		| otherwise	 = Nothing ;
			
89
	     gbl_env = TcGblEnv {
90 91
		tcg_mod       = mod,
		tcg_src	      = hsc_src,
92
		tcg_rdr_env   = emptyGlobalRdrEnv,
93
		tcg_fix_env   = emptyNameEnv,
94
		tcg_field_env = RecFields emptyNameEnv emptyNameSet,
95
		tcg_default   = Nothing,
96
		tcg_type_env  = emptyNameEnv,
97
		tcg_type_env_var = type_env_var,
98
		tcg_inst_env  = emptyInstEnv,
99
		tcg_fam_inst_env  = emptyFamInstEnv,
100
                tcg_th_used   = th_var,
101
		tcg_exports  = [],
102
		tcg_imports  = emptyImportAvails,
103
                tcg_used_rdrnames = used_rdr_var,
104
		tcg_dus      = emptyDUs,
105

106
                tcg_rn_imports = [],
107 108 109
                tcg_rn_exports = maybe_rn_syntax [],
		tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,

110 111 112 113 114 115 116
		tcg_binds     = emptyLHsBinds,
		tcg_imp_specs = [],
		tcg_sigs      = emptyNameSet,
		tcg_ev_binds  = emptyBag,
		tcg_warns     = NoWarnings,
		tcg_anns      = [],
		tcg_insts     = [],
117 118 119 120 121 122
                tcg_fam_insts = [],
                tcg_rules     = [],
                tcg_fords     = [],
                tcg_vects     = [],
                tcg_dfun_n    = dfun_n_var,
                tcg_keep      = keep_var,
123 124 125
		tcg_doc_hdr   = Nothing,
                tcg_hpc       = False,
                tcg_main      = Nothing
126
	     } ;
127
	     lcl_env = TcLclEnv {
128
		tcl_errs       = errs_var,
Ian Lynagh's avatar
Ian Lynagh committed
129
		tcl_loc	       = mkGeneralSrcSpan (fsLit "Top level"),
130
		tcl_ctxt       = [],
131
		tcl_rdr	       = emptyLocalRdrEnv,
132
		tcl_th_ctxt    = topStage,
ross's avatar
ross committed
133
		tcl_arrow_ctxt = NoArrowCtxt,
134 135
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
136
		tcl_lie	       = lie_var,
137 138
                tcl_meta       = meta_var,
		tcl_untch      = initTyVarUnique
139
	     } ;
140
	} ;
141 142
   
	-- OK, here's the business end!
143
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
144
		     do { r <- tryM do_this
145 146 147
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;
148

149 150
        -- Check for unsolved constraints
	lie <- readIORef lie_var ;
151
        if isEmptyWC lie
152 153 154 155
           then return ()
           else pprPanic "initTc: unsolved constraints" 
                         (pprWantedsWithLocs lie) ;

156
	-- Collect any error messages
157 158
	msgs <- readIORef errs_var ;

159 160
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
161
			| otherwise	   	  = maybe_res } ;
162

163
	return (msgs, final_res)
164
    }
165

166
initTcPrintErrors	-- Used from the interactive loop only
167 168 169
       :: HscEnv
       -> Module 
       -> TcM r
170
       -> IO (Messages, Maybe r)
171 172

initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
173 174
\end{code}

175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
%************************************************************************
%*									*
		Initialisation
%*									*
%************************************************************************


\begin{code}
initTcRnIf :: Char		-- Tag for unique supply
	   -> HscEnv
	   -> gbl -> lcl 
	   -> TcRnIf gbl lcl a 
	   -> IO a
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
   = do	{ us     <- mkSplitUniqSupply uniq_tag ;
	; us_var <- newIORef us ;

	; let { env = Env { env_top = hsc_env,
			    env_us  = us_var,
			    env_gbl = gbl_env,
195
			    env_lcl = lcl_env} }
196 197 198 199 200

	; runIOEnv env thing_inside
	}
\end{code}

201 202 203 204 205 206 207
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

\begin{code}
208
getTopEnv :: TcRnIf gbl lcl HscEnv
209 210
getTopEnv = do { env <- getEnv; return (env_top env) }

211
getGblEnv :: TcRnIf gbl lcl gbl
212 213
getGblEnv = do { env <- getEnv; return (env_gbl env) }

214
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
215 216 217
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
			  env { env_gbl = upd gbl })

218
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
219 220
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

221
getLclEnv :: TcRnIf gbl lcl lcl
222 223
getLclEnv = do { env <- getEnv; return (env_lcl env) }

224
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
225 226 227
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
			  env { env_lcl = upd lcl })

228
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
229
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
230

231
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
232 233
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

234
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
235
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
236 237
\end{code}

238

239 240 241
Command-line flags

\begin{code}
242 243
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
244

245 246 247 248
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }

doptM :: DynFlag -> TcRnIf gbl lcl Bool
249 250
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

251 252
-- XXX setOptM and unsetOptM operate on different types. One should be renamed.

253
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
254
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
255
			 env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
256

257
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
258 259 260
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
			 env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )

261
-- | Do it flag is true
262 263 264 265 266 267
ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifDOptM flag thing_inside = do { b <- doptM flag; 
				if b then thing_inside else return () }

ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifXOptM flag thing_inside = do { b <- xoptM flag; 
268 269
				if b then thing_inside else return () }

270 271
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
272 273 274
\end{code}

\begin{code}
275 276 277 278 279 280
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) }

281 282 283 284 285
-- | 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.
286 287
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
288 289 290 291 292 293 294 295 296
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.
297 298
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
299 300 301 302
updateEps_ upd_fn = do
  traceIf (text "updating EPS_")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
303 304 305

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
306 307 308 309

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
		  ; return (eps, hsc_HPT env) }
310
\end{code}
311

312 313 314 315 316 317 318
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
319 320 321 322 323 324 325 326 327 328
newMetaUnique :: TcM Unique
-- The uniques for TcMetaTyVars are allocated specially
-- in guaranteed linear order, starting at zero for each module
newMetaUnique 
 = do { env <- getLclEnv
      ; let meta_var = tcl_meta env
      ; uniq <- readMutVar meta_var
      ; writeMutVar meta_var (incrUnique uniq)
      ; return uniq }

329
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
330 331
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
332 333
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
334 335 336
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
337 338 339 340 341 342
   -- 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.
343 344 345 346

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
347 348
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
349
        case splitUniqSupply us of { (us1,us2) -> do {
Ian Lynagh's avatar
Ian Lynagh committed
350 351
        writeMutVar u_var us1 ;
        return us2 }}}
352 353 354

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
355
  = do	{ uniq <- newUnique
356
	; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
357 358 359 360 361

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
362 363 364 365

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
366 367
\end{code}

368 369 370 371 372 373 374

%************************************************************************
%*									*
		Debugging
%*									*
%************************************************************************

375
\begin{code}
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef = newMutVar 

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

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

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef = updMutVar
\end{code}

%************************************************************************
%*									*
		Debugging
%*									*
%************************************************************************

\begin{code}
traceTc :: String -> SDoc -> TcRn () 
traceTc = traceTcN 1

traceTcN :: Int -> String -> SDoc -> TcRn () 
traceTcN level herald doc
  | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $
                              hang (text herald) 2 doc
  | otherwise               = return ()

traceRn, traceSplice :: SDoc -> TcRn ()
406 407
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
408 409


Ian Lynagh's avatar
Ian Lynagh committed
410
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
411 412
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
413

414

415
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
416
traceOptIf flag doc = ifDOptM flag $
417
		      liftIO (printForUser stderr alwaysQualify doc)
418

419
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
420
-- Output the message, with current location if opt_PprStyle_Debug
421
traceOptTcRn flag doc = ifDOptM flag $ do
422 423 424 425 426
			{ loc  <- getSrcSpanM
			; let real_doc 
                                | opt_PprStyle_Debug = mkLocMessage loc doc
                                | otherwise = doc   -- The full location is 
				  	      	    -- usually way too much
427
			; dumpTcRn real_doc }
428 429

dumpTcRn :: SDoc -> TcRn ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
430 431
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv 
                  ; dflags <- getDOpts 
432
                  ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
433 434 435 436

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc
437 438

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
439
dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc)
440 441 442 443 444 445 446 447
\end{code}


%************************************************************************
%*									*
		Typechecker global environment
%*									*
%************************************************************************
448

449 450
\begin{code}
getModule :: TcRn Module
451 452
getModule = do { env <- getGblEnv; return (tcg_mod env) }

453 454 455
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

456 457 458
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }

459 460 461
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

462
getGlobalRdrEnv :: TcRn GlobalRdrEnv
463 464
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

465 466 467
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

468
getImports :: TcRn ImportAvails
469 470
getImports = do { env <- getGblEnv; return (tcg_imports env) }

471
getFixityEnv :: TcRn FixityEnv
472 473
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

474
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
475 476 477 478
extendFixityEnv new_bit
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
		env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})	     

479 480 481
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

482 483
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
484 485 486 487 488 489 490 491 492
\end{code}

%************************************************************************
%*									*
		Error management
%*									*
%************************************************************************

\begin{code}
493
getSrcSpanM :: TcRn SrcSpan
494
	-- Avoid clash with Name.getSrcLoc
495
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
496

497 498
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
499 500
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
501 502

addLocM :: (a -> TcM b) -> Located a -> TcM b
503
addLocM fn (L loc a) = setSrcSpan loc $ fn a
504 505

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
506
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
507 508 509

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
510
  setSrcSpan loc $ do
511 512 513 514 515
    (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) =
516
  setSrcSpan loc $ do
517 518
    (b,c) <- fn a
    return (b, L loc c)
519
\end{code}
520

521
Reporting errors
522

523 524 525 526 527 528 529
\begin{code}
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 })

530
addErr :: Message -> TcRn ()	-- Ignores the context stack
531
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
532

533 534 535
failWith :: Message -> TcRn a
failWith msg = addErr msg >> failM

536
addErrAt :: SrcSpan -> Message -> TcRn ()
537 538 539 540 541 542 543
-- addErrAt is mainly (exclusively?) used by the renamer, where
-- tidying is not an issue, but it's all lazy so the extra
-- work doesn't matter
addErrAt loc msg = do { ctxt <- getErrCtxt 
	     	      ; tidy_env <- tcInitTidyEnv
                      ; err_info <- mkErrInfo tidy_env ctxt
	              ; addLongErrAt loc msg err_info }
544

545
addErrs :: [(SrcSpan,Message)] -> TcRn ()
546
addErrs msgs = mapM_ add msgs
547
	     where
548
	       add (loc,msg) = addErrAt loc msg
549

550
addWarn :: Message -> TcRn ()
551
addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
552

553
addWarnAt :: SrcSpan -> Message -> TcRn ()
554
addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
555

556
checkErr :: Bool -> Message -> TcRn ()
557
-- Add the error if the bool is False
558
checkErr ok msg = unless ok (addErr msg)
559

560
warnIf :: Bool -> Message -> TcRn ()
561
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
562
warnIf False _   = return ()
563

564
addMessages :: Messages -> TcRn ()
565 566
addMessages (m_warns, m_errs)
  = do { errs_var <- getErrsVar ;
567 568
	 (warns, errs) <- readTcRef errs_var ;
  	 writeTcRef errs_var (warns `unionBags` m_warns,
569
			       errs  `unionBags` m_errs) }
570 571 572 573 574 575 576

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
-- With -dppr-debug, the effects is switched off, so you can still see
-- what warnings derived code would give
discardWarnings thing_inside
577 578
  | opt_PprStyle_Debug = thing_inside
  | otherwise
579
  = do	{ errs_var <- newTcRef emptyMessages
580
	; result <- setErrsVar errs_var thing_inside
581
	; (_warns, errs) <- readTcRef errs_var
582 583
	; addMessages (emptyBag, errs)
	; return result }
584 585 586
\end{code}


587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603
%************************************************************************
%*									*
	Shared error message stuff: renamer and typechecker
%*									*
%************************************************************************

\begin{code}
addReport :: Message -> Message -> TcRn ()
addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info

addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
addReportAt loc msg extra_info
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
         dflags <- getDOpts ;
	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
	                            msg extra_info } ;
604 605
	 (warns, errs) <- readTcRef errs_var ;
  	 writeTcRef errs_var (warns `snocBag` warn, errs) }
606 607 608

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
609
  = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ;	
610 611 612 613
	 errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
         dflags <- getDOpts ;
	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
614 615
	 (warns, errs) <- readTcRef errs_var ;
  	 writeTcRef errs_var (warns, errs `snocBag` err) }
616 617 618 619 620 621 622 623

dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
  = do { dflags <- getDOpts
       ; when (dopt Opt_D_dump_deriv dflags) $ do
       { rdr_env <- getGlobalRdrEnv
       ; let unqual = mkPrintUnqualified dflags rdr_env
       ; liftIO (putMsgWith dflags unqual doc) } }
624 625 626
\end{code}


627
\begin{code}
628
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
629 630 631 632
-- Does try_m, with a debug-trace on failure
try_m thing 
  = do { mb_r <- tryM thing ;
	 case mb_r of 
633 634 635
	     Left exn -> do { traceTc "tryTc/recoverM recovering from" $
                                      text (showException exn)
                            ; return mb_r }
Ian Lynagh's avatar
Ian Lynagh committed
636
	     Right _  -> return mb_r }
637 638

-----------------------
639 640 641
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
642
-- Errors in 'thing' are retained
643
recoverM recover thing 
644
  = do { mb_res <- try_m thing ;
645
	 case mb_res of
Ian Lynagh's avatar
Ian Lynagh committed
646
	   Left _    -> recover
647
	   Right res -> return res }
648

649 650 651 652 653

-----------------------
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
654
mapAndRecoverM _ []     = return []
655
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
656 657 658 659 660 661
			     ; rs <- mapAndRecoverM f xs
			     ; return (case mb_r of
					  Left _  -> rs
					  Right r -> r:rs) }
			

662
-----------------------
663
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
664 665 666 667 668
-- (tryTc m) executes m, and returns
--	Just r,  if m succeeds (returning r)
--	Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
669
tryTc m 
670
 = do {	errs_var <- newTcRef emptyMessages ;
671
	res  <- try_m (setErrsVar errs_var m) ; 
672
	msgs <- readTcRef errs_var ;
673
	return (msgs, case res of
Ian Lynagh's avatar
Ian Lynagh committed
674
			    Left _  -> Nothing
675 676 677
			    Right val -> Just val)
	-- The exception is always the IOEnv built-in
	-- in exception; see IOEnv.failM
678 679
   }

680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
-- Run the thing, returning 
--	Just r,  if m succceeds with no error messages
--	Nothing, if m fails, or if it succeeds but has error messages
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
tryTcErrs thing 
  = do  { (msgs, res) <- tryTc thing
	; dflags <- getDOpts
	; let errs_found = errorsFound dflags msgs
	; return (msgs, case res of
			  Nothing -> Nothing
			  Just val | errs_found -> Nothing
			 	   | otherwise  -> Just val)
	}
696

697
-----------------------
698
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
699
-- Just like tryTcErrs, except that it ensures that the LIE
700 701
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
702
tryTcLIE thing_inside
703
  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
704 705
	; case mb_res of
	    Nothing  -> return (msgs, Nothing)
706
	    Just val -> do { emitConstraints lie; return (msgs, Just val) }
707
	}
708

709
-----------------------
710
tryTcLIE_ :: TcM r -> TcM r -> TcM r
711 712 713
-- (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.
714
tryTcLIE_ recover main
715 716 717 718 719 720
  = 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
	}
721

722
-----------------------
723 724 725 726 727 728 729 730
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
--	(it might have recovered internally)
-- 	If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
731 732 733
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
734
	    Nothing  -> failM
735 736
	    Just val -> return val
	} 
737

738
ifErrsM :: TcRn r -> TcRn r -> TcRn r
739 740 741 742 743
--	ifErrsM bale_out main
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'main'
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
744
	msgs <- readTcRef errs_var ;
745 746
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
747 748 749 750
	   bale_out
	else	
	   normal }

751
failIfErrsM :: TcRn ()
752 753 754 755 756 757 758
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


%************************************************************************
%*									*
759
	Context management for the type checker
760 761 762 763
%*									*
%************************************************************************

\begin{code}
764
getErrCtxt :: TcM [ErrCtxt]
765
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
766

767
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
768
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
769

770
addErrCtxt :: Message -> TcM a -> TcM a
771
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
772

773
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
774 775 776 777
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

addLandmarkErrCtxt :: Message -> TcM a -> TcM a
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
778

779
-- Helper function for the above
780
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
781 782 783
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
			   env { tcl_ctxt = upd ctxt })

784
popErrCtxt :: TcM a -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
785
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
786

787 788
getCtLoc :: orig -> TcM (CtLoc orig)
getCtLoc origin
789
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
790
	 return (CtLoc origin loc (tcl_ctxt env)) }
791

792 793
setCtLoc :: CtLoc orig -> TcM a -> TcM a
setCtLoc (CtLoc _ src_loc ctxt) thing_inside
794
  = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
795 796
\end{code}

797 798 799 800 801 802
%************************************************************************
%*									*
	     Error message generation (type checker)
%*									*
%************************************************************************

803
    The addErrTc functions add an error message, but do not cause failure.
804 805 806 807 808
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages

\begin{code}
addErrTc :: Message -> TcM ()
809 810
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
811 812

addErrsTc :: [Message] -> TcM ()
813
addErrsTc err_msgs = mapM_ addErrTc err_msgs
814 815 816 817

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
818
	 loc  <- getSrcSpanM ;
819 820 821 822 823 824 825 826 827 828 829 830 831 832 833
	 add_err_tcm tidy_env err_msg loc ctxt }
\end{code}

The failWith functions add an error message and cause failure

\begin{code}
failWithTc :: Message -> TcM a		     -- Add an error message and fail
failWithTc err_msg 
  = addErrTc err_msg >> failM

failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
failWithTcM local_and_msg
  = addErrTcM local_and_msg >> failM

checkTc :: Bool -> Message -> TcM ()	     -- Check that the boolean is true
Ian Lynagh's avatar
Ian Lynagh committed
834
checkTc True  _   = return ()
835 836 837 838 839 840 841
checkTc False err = failWithTc err
\end{code}

	Warnings have no 'M' variant, nor failure

\begin{code}
addWarnTc :: Message -> TcM ()
842 843 844 845 846
addWarnTc msg = do { env0 <- tcInitTidyEnv 
		   ; addWarnTcM (env0, msg) }

addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
847
 = do { ctxt <- getErrCtxt ;
848
	err_info <- mkErrInfo env0 ctxt ;
849
	addReport (ptext (sLit "Warning:") <+> msg) err_info }
850 851 852 853 854 855 856

warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
  | warn_if_true = addWarnTc warn_msg
  | otherwise	 = return ()
\end{code}

857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882
-----------------------------------
	 Tidying

We initialise the "tidy-env", used for tidying types before printing,
by building a reverse map from the in-scope type variables to the
OccName that the programmer originally used for them

\begin{code}
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
  = do	{ lcl_env <- getLclEnv
	; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
			  | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
			  , tcIsTyVarTy ty ]
	; return (foldl add emptyTidyEnv nm_tv_prs) }
  where
    add (env,subst) (name, tyvar)
	= case tidyOccName env (nameOccName name) of
	    (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
		where
		  tyvar' = setTyVarName tyvar name'
		  name'  = tidyNameOcc name occ'
\end{code}

-----------------------------------
 	Other helper functions
883 884

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
885
add_err_tcm :: TidyEnv -> Message -> SrcSpan
886
            -> [ErrCtxt]
Ian Lynagh's avatar
Ian Lynagh committed
887
            -> TcM ()
888
add_err_tcm tidy_env err_msg loc ctxt
889 890 891 892 893 894 895 896 897 898 899
 = do { err_info <- mkErrInfo tidy_env ctxt ;
	addLongErrAt loc err_msg err_info }

mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo env ctxts
 = go 0 env ctxts
 where
   go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
   go _ _   [] = return empty
   go n env ((is_landmark, ctxt) : ctxts)
900
     | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug 
901 902 903 904 905 906 907 908 909
     = do { (env', msg) <- ctxt env
	  ; let n' = if is_landmark then n else n+1
          ; rest <- go n' env' ctxts
	  ; return (msg $$ rest) }
     | otherwise
     = go n env ctxts

mAX_CONTEXTS :: Int	-- No more than this number of non-landmark contexts
mAX_CONTEXTS = 3
910 911
\end{code}

912
debugTc is useful for monadic debugging code
913 914 915

\begin{code}
debugTc :: TcM () -> TcM ()
Ian Lynagh's avatar
Ian Lynagh committed
916 917 918
debugTc thing
 | debugIsOn = thing
 | otherwise = return ()
919 920
\end{code}

921
%************************************************************************
922
%*									*
923
	     Type constraints
924 925 926 927
%*									*
%************************************************************************

\begin{code}
928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
       		  ; uniq <- newUnique
       		  ; return (EvBindsVar ref uniq) }

extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds
extendTcEvBinds binds@(TcEvBinds binds_var) var rhs 
  = do { addTcEvBind binds_var var rhs
       ; return binds }
extendTcEvBinds (EvBinds bnds) var rhs
  = return (EvBinds (bnds `snocBag` EvBind var rhs))

addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind (EvBindsVar ev_ref _) var rhs
  = do { bnds <- readTcRef ev_ref
       ; writeTcRef ev_ref (extendEvBinds bnds var rhs) }

946 947 948 949
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
  do { env <- getGblEnv
     ; let dfun_n_var = tcg_dfun_n env
950
     ; set <- readTcRef dfun_n_var
951
     ; let occ = fn set
952 953
     ; writeTcRef dfun_n_var (extendOccSet set occ)
     ; return occ }
954

955 956
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
957

958 959
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
960

961 962 963
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
  = do { lie_var <- getConstraintVar ;
964
         updTcRef lie_var (`andWC` ct) }
965

966 967
emitFlat :: WantedEvVar -> TcM ()
emitFlat ct
968
  = do { lie_var <- getConstraintVar ;
969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984
         updTcRef lie_var (`addFlats` unitBag ct) }

emitFlats :: Bag WantedEvVar -> TcM ()
emitFlats ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addFlats` ct) }

emitImplication :: Implication -> TcM ()
emitImplication ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addImplics` unitBag ct) }