ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType, TcMaybe(..), TcBox,
   4         TcTauType, TcThetaType, TcRhoType,
   5         TcTyVar, TcTyVarSet,
   6         TcKind,
   7
   8         TcM, NF_TcM, TcDown, TcEnv,
   9         SST_R, FSST_R,
  10
  11         initTc,
  12         returnTc, thenTc, thenTc_, mapTc, listTc,
  13         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  14         mapBagTc, fixTc, tryTc, getErrsTc,
  15
  16         uniqSMToTcM,
  17
  18         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
  19         fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
  20
  21         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  22
  23         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  24         failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
  25         addErrTcM, failWithTcM,
  26
  27         tcGetEnv, tcSetEnv,
  28         tcGetDefaultTys, tcSetDefaultTys,
  29         tcGetUnique, tcGetUniques,
  30
  31         tcAddSrcLoc, tcGetSrcLoc,
  32         tcAddErrCtxtM, tcSetErrCtxtM,
  33         tcAddErrCtxt, tcSetErrCtxt,
  34
  35         tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
  36
  37         TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
  38         arityErr
  39   ) where
  40
  41 #include "HsVersions.h"
  42
  43 import {-# SOURCE #-} TcEnv  ( TcEnv )
  44
  45 import Type             ( Type, GenType )
  46 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  47 import CmdLineOpts      ( opt_PprStyle_Debug )
  48
  49 import SST
  50 import Bag              ( Bag, emptyBag, isEmptyBag,
  51                           foldBag, unitBag, unionBags, snocBag )
  52 import Class            ( Class )
  53 import Var              ( GenTyVar )
  54 import VarEnv           ( TyVarEnv, emptyVarEnv )
  55 import VarSet           ( GenTyVarSet )
  56 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
  57                           UniqSM, initUs )
  58 import SrcLoc           ( SrcLoc, noSrcLoc )
  59 import FiniteMap        ( FiniteMap, emptyFM )
  60 import UniqFM           ( UniqFM, emptyUFM )
  61 import Unique           ( Unique )
  62 import Util
  63 import Outputable
  64
  65 import GlaExts          ( State#, RealWorld )
  66
  67
  68 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  69 \end{code}
  70
  71
  72 Types
  73 ~~~~~
  74 \begin{code}
  75 type TcType s = GenType (TcBox s)       -- Used during typechecker
  76         -- Invariant on ForAllTy in TcTypes:
  77         --      forall a. T
  78         -- a cannot occur inside a MutTyVar in T; that is,
  79         -- T is "flattened" before quantifying over a
  80
  81 type TcKind s = TcType s
  82
  83 type TcThetaType s = [(Class, [TcType s])]
  84 type TcRhoType s   = TcType s           -- No ForAllTys
  85 type TcTauType s   = TcType s           -- No DictTys or ForAllTys
  86
  87 type TcBox s = TcRef s (TcMaybe s)
  88
  89 data TcMaybe s = UnBound
  90                | BoundTo (TcType s)
  91
  92 -- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
  93 -- because you get a synonym loop if you do!
  94
  95 type TcTyVar s    = GenTyVar (TcBox s)
  96 type TcTyVarSet s = GenTyVarSet (TcBox s)
  97 \end{code}
  98
  99
 100 \section{TcM, NF_TcM: the type checker monads}
 101 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 102
 103 \begin{code}
 104 type NF_TcM s r =  TcDown s -> TcEnv s -> SST s r
 105 type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
 106 \end{code}
 107
 108 \begin{code}
 109 -- With a builtin polymorphic type for runSST the type for
 110 -- initTc should use  TcM s r  instead of  TcM RealWorld r
 111
 112 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
 113
 114 initTc :: UniqSupply
 115        -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
 116        -> TcM RealWorld r
 117        -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
 118
 119 initTc us initenv do_this
 120   = runSST (
 121       newMutVarSST us                   `thenSST` \ us_var ->
 122       newMutVarSST (emptyBag,emptyBag)  `thenSST` \ errs_var ->
 123       newMutVarSST emptyUFM             `thenSST` \ tvs_var ->
 124       let
 125           init_down = TcDown [] us_var
 126                              noSrcLoc
 127                              [] errs_var
 128           init_env  = initenv tvs_var
 129       in
 130       recoverSST
 131         (\_ -> returnSST Nothing)
 132         (do_this init_down init_env `thenFSST` \ res ->
 133          returnFSST (Just res))
 134                                         `thenSST` \ maybe_res ->
 135       readMutVarSST errs_var            `thenSST` \ (warns,errs) ->
 136       returnSST (maybe_res, warns, errs)
 137     )
 138
 139 thenNF_Tc :: NF_TcM s a
 140           -> (a -> TcDown s -> TcEnv s -> State# s -> b)
 141           -> TcDown s -> TcEnv s -> State# s -> b
 142 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
 143 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b)    -> TcM s b
 144
 145 thenNF_Tc m k down env
 146   = m down env  `thenSST` \ r ->
 147     k r down env
 148
 149 thenNF_Tc_ :: NF_TcM s a
 150            -> (TcDown s -> TcEnv s -> State# s -> b)
 151            -> TcDown s -> TcEnv s -> State# s -> b
 152 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
 153 -- thenNF_Tc :: NF_TcM s a -> TcM s b    -> TcM s b
 154
 155 thenNF_Tc_ m k down env
 156   = m down env  `thenSST_` k down env
 157
 158 returnNF_Tc :: a -> NF_TcM s a
 159 returnNF_Tc v down env = returnSST v
 160
 161 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
 162 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
 163
 164 mapNF_Tc    :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 165 mapNF_Tc f []     = returnNF_Tc []
 166 mapNF_Tc f (x:xs) = f x                 `thenNF_Tc` \ r ->
 167                     mapNF_Tc f xs       `thenNF_Tc` \ rs ->
 168                     returnNF_Tc (r:rs)
 169
 170 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
 171 foldrNF_Tc k z []     = returnNF_Tc z
 172 foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs       `thenNF_Tc` \r ->
 173                         k x r
 174
 175 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
 176 foldlNF_Tc k z []     = returnNF_Tc z
 177 foldlNF_Tc k z (x:xs) = k z x           `thenNF_Tc` \r ->
 178                         foldlNF_Tc k r xs
 179
 180 listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
 181 listNF_Tc []     = returnNF_Tc []
 182 listNF_Tc (x:xs) = x                    `thenNF_Tc` \ r ->
 183                    listNF_Tc xs         `thenNF_Tc` \ rs ->
 184                    returnNF_Tc (r:rs)
 185
 186 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
 187 mapBagNF_Tc f bag
 188   = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
 189                         b2 `thenNF_Tc` \ r2 ->
 190                         returnNF_Tc (unionBags r1 r2))
 191             (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
 192             (returnNF_Tc emptyBag)
 193             bag
 194
 195 mapAndUnzipNF_Tc    :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
 196 mapAndUnzipNF_Tc f []     = returnNF_Tc ([],[])
 197 mapAndUnzipNF_Tc f (x:xs) = f x                         `thenNF_Tc` \ (r1,r2) ->
 198                             mapAndUnzipNF_Tc f xs       `thenNF_Tc` \ (rs1,rs2) ->
 199                             returnNF_Tc (r1:rs1, r2:rs2)
 200
 201 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
 202 thenTc m k down env
 203   = m down env  `thenFSST` \ r ->
 204     k r down env
 205
 206 thenTc_ :: TcM s a -> TcM s b -> TcM s b
 207 thenTc_ m k down env
 208   = m down env  `thenFSST_`  k down env
 209
 210 returnTc :: a -> TcM s a
 211 returnTc val down env = returnFSST val
 212
 213 mapTc    :: (a -> TcM s b) -> [a]   -> TcM s [b]
 214 mapTc f []     = returnTc []
 215 mapTc f (x:xs) = f x            `thenTc` \ r ->
 216                  mapTc f xs     `thenTc` \ rs ->
 217                  returnTc (r:rs)
 218
 219 listTc    :: [TcM s a] -> TcM s [a]
 220 listTc []     = returnTc []
 221 listTc (x:xs) = x                       `thenTc` \ r ->
 222                 listTc xs               `thenTc` \ rs ->
 223                 returnTc (r:rs)
 224
 225 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
 226 foldrTc k z []     = returnTc z
 227 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 228                      k x r
 229
 230 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
 231 foldlTc k z []     = returnTc z
 232 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 233                      foldlTc k r xs
 234
 235 mapAndUnzipTc    :: (a -> TcM s (b,c)) -> [a]   -> TcM s ([b],[c])
 236 mapAndUnzipTc f []     = returnTc ([],[])
 237 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 238                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 239                          returnTc (r1:rs1, r2:rs2)
 240
 241 mapAndUnzip3Tc    :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
 242 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 243 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 244                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 245                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 246
 247 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
 248 mapBagTc f bag
 249   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 250                         b2 `thenTc` \ r2 ->
 251                         returnTc (unionBags r1 r2))
 252             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 253             (returnTc emptyBag)
 254             bag
 255
 256 fixTc :: (a -> TcM s a) -> TcM s a
 257 fixTc m env down = fixFSST (\ loop -> m loop env down)
 258 \end{code}
 259
 260 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 261 thread.  Ideally, this elegantly ensures that it can't zap any type
 262 variables that belong to the main thread.  But alas, the environment
 263 contains TyCon and Class environments that include (TcKind s) stuff,
 264 which is a Royal Pain.  By the time this fork stuff is used they'll
 265 have been unified down so there won't be any kind variables, but we
 266 can't express that in the current typechecker framework.
 267
 268 So we compromise and use unsafeInterleaveSST.
 269
 270 We throw away any error messages!
 271
 272 \begin{code}
 273 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
 274 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 275   =     -- Get a fresh unique supply
 276     readMutVarSST u_var         `thenSST` \ us ->
 277     let
 278         (us1, us2) = splitUniqSupply us
 279     in
 280     writeMutVarSST u_var us1    `thenSST_`
 281
 282     unsafeInterleaveSST (
 283         newMutVarSST us2                        `thenSST` \ us_var'   ->
 284         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ err_var' ->
 285         newMutVarSST emptyUFM                   `thenSST` \ tv_var'  ->
 286         let
 287             down' = TcDown deflts us_var' src_loc err_cxt err_var'
 288         in
 289         m down' env
 290         -- ToDo: optionally dump any error messages
 291     )
 292 \end{code}
 293
 294
 295 Error handling
 296 ~~~~~~~~~~~~~~
 297 \begin{code}
 298 getErrsTc :: NF_TcM s (Bag ErrMsg, Bag  WarnMsg)
 299 getErrsTc down env
 300   = readMutVarSST errs_var
 301   where
 302     errs_var = getTcErrs down
 303
 304
 305 failTc :: TcM s a
 306 failTc down env
 307   = failFSST ()
 308
 309 failWithTc :: Message -> TcM s a                        -- Add an error message and fail
 310 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 311
 312 addErrTc :: Message -> NF_TcM s ()
 313 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 314
 315 -- The 'M' variants do the TidyTypeEnv bit
 316 failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a      -- Add an error message and fail
 317 failWithTcM env_and_msg
 318   = addErrTcM env_and_msg       `thenNF_Tc_`
 319     failTc
 320
 321 addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s ()    -- Add an error message but don't fail
 322 addErrTcM (tidy_env, err_msg) down env
 323   = readMutVarSST errs_var              `thenSST` \ (warns,errs) ->
 324     do_ctxt tidy_env ctxt down env      `thenSST` \ ctxt_msgs ->
 325     let
 326         err = addShortErrLocLine loc $
 327               vcat (err_msg : ctxt_to_use ctxt_msgs)
 328     in
 329     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 330     returnSST ()
 331   where
 332     errs_var = getTcErrs down
 333     ctxt     = getErrCtxt down
 334     loc      = getLoc down
 335
 336 do_ctxt tidy_env [] down env
 337   = returnSST []
 338 do_ctxt tidy_env (c:cs) down env
 339   = c tidy_env down env                 `thenSST` \ (tidy_env', m) ->
 340     do_ctxt tidy_env' cs down env       `thenSST` \ ms ->
 341     returnSST (m:ms)
 342
 343 -- warnings don't have an 'M' variant
 344 warnTc :: Bool -> Message -> NF_TcM s ()
 345 warnTc warn_if_true warn_msg down env
 346   = if warn_if_true then
 347         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 348         do_ctxt emptyTidyEnv ctxt down env      `thenSST` \ ctxt_msgs ->
 349         let
 350             warn = addShortWarnLocLine loc $
 351                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 352         in
 353         writeMutVarSST errs_var (warns `snocBag` warn, errs)    `thenSST_`
 354         returnSST ()
 355     else
 356         returnSST ()
 357   where
 358     errs_var = getTcErrs down
 359     ctxt     = getErrCtxt down
 360     loc      = getLoc down
 361
 362 recoverTc :: TcM s r -> TcM s r -> TcM s r
 363 recoverTc recover m down env
 364   = recoverFSST (\ _ -> recover down env) (m down env)
 365
 366 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
 367 recoverNF_Tc recover m down env
 368   = recoverSST (\ _ -> recover down env) (m down env)
 369
 370 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 371 -- If m fails then (checkNoErrsTc m) fails.
 372 -- If m succeeds, it checks whether m generated any errors messages
 373 --      (it might have recovered internally)
 374 --      If so, it fails too.
 375 -- Regardless, any errors generated by m are propagated to the enclosing
 376 -- context.
 377
 378 checkNoErrsTc :: TcM s r -> TcM s r
 379 checkNoErrsTc m down env
 380   = newMutVarSST (emptyBag,emptyBag)    `thenSST` \ m_errs_var ->
 381     let
 382         errs_var = getTcErrs down
 383         propagate_errs _
 384          = readMutVarSST m_errs_var     `thenSST` \ (m_warns, m_errs) ->
 385            readMutVarSST errs_var       `thenSST` \ (warns, errs) ->
 386            writeMutVarSST errs_var (warns `unionBags` m_warns,
 387                                     errs  `unionBags` m_errs)   `thenSST_`
 388            failFSST()
 389     in
 390
 391     recoverFSST propagate_errs $
 392
 393     m (setTcErrs down m_errs_var) env   `thenFSST` \ result ->
 394
 395         -- Check that m has no errors; if it has internal recovery
 396         -- mechanisms it might "succeed" but having found a bunch of
 397         -- errors along the way.
 398     readMutVarSST m_errs_var            `thenSST` \ (m_warns, m_errs) ->
 399     if isEmptyBag m_errs then
 400         returnFSST result
 401     else
 402         failFSST ()     -- This triggers the recoverFSST
 403
 404 -- (tryTc r m) tries m; if it succeeds it returns it,
 405 -- otherwise it returns r.  Any error messages added by m are discarded,
 406 -- whether or not m succeeds.
 407 tryTc :: TcM s r -> TcM s r -> TcM s r
 408 tryTc recover m down env
 409   = recoverFSST (\ _ -> recover down env) $
 410
 411     newMutVarSST (emptyBag,emptyBag)    `thenSST` \ new_errs_var ->
 412     m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
 413
 414         -- Check that m has no errors; if it has internal recovery
 415         -- mechanisms it might "succeed" but having found a bunch of
 416         -- errors along the way. If so we want tryTc to use
 417         -- "recover" instead
 418     readMutVarSST new_errs_var          `thenSST` \ (_,errs) ->
 419     if isEmptyBag errs then
 420         returnFSST result
 421     else
 422         recover down env
 423
 424 -- Run the thing inside, but throw away all its error messages.
 425 -- discardErrsTc :: TcM s r -> TcM s r
 426 -- discardErrsTc :: NF_TcM s r -> NF_TcM s r
 427 discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a)
 428               -> (TcDown s -> TcEnv s -> State# s -> a)
 429 discardErrsTc m down env
 430   = newMutVarSST (emptyBag,emptyBag)    `thenSST` \ new_errs_var ->
 431     m (setTcErrs down new_errs_var) env
 432
 433 checkTc :: Bool -> Message -> TcM s ()          -- Check that the boolean is true
 434 checkTc True  err = returnTc ()
 435 checkTc False err = failWithTc err
 436
 437 checkTcM :: Bool -> TcM s () -> TcM s ()        -- Check that the boolean is true
 438 checkTcM True  err = returnTc ()
 439 checkTcM False err = err
 440
 441 checkMaybeTc :: Maybe val -> Message -> TcM s val
 442 checkMaybeTc (Just val) err = returnTc val
 443 checkMaybeTc Nothing    err = failWithTc err
 444
 445 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
 446 checkMaybeTcM (Just val) err = returnTc val
 447 checkMaybeTcM Nothing    err = err
 448 \end{code}
 449
 450 Mutable variables
 451 ~~~~~~~~~~~~~~~~~
 452 \begin{code}
 453 type TcRef s a = SSTRef s a
 454
 455 tcNewMutVar :: a -> NF_TcM s (TcRef s a)
 456 tcNewMutVar val down env = newMutVarSST val
 457
 458 tcWriteMutVar :: TcRef s a -> a -> NF_TcM s ()
 459 tcWriteMutVar var val down env = writeMutVarSST var val
 460
 461 tcReadMutVar :: TcRef s a -> NF_TcM s a
 462 tcReadMutVar var down env = readMutVarSST var
 463 \end{code}
 464
 465
 466 Environment
 467 ~~~~~~~~~~~
 468 \begin{code}
 469 tcGetEnv :: NF_TcM s (TcEnv s)
 470 tcGetEnv down env = returnSST env
 471
 472 tcSetEnv :: TcEnv s
 473           -> (TcDown s -> TcEnv s -> State# s -> b)
 474           ->  TcDown s -> TcEnv s -> State# s -> b
 475 -- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
 476 -- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a
 477
 478 tcSetEnv new_env m down old_env = m down new_env
 479 \end{code}
 480
 481
 482 Source location
 483 ~~~~~~~~~~~~~~~
 484 \begin{code}
 485 tcGetDefaultTys :: NF_TcM s [Type]
 486 tcGetDefaultTys down env = returnSST (getDefaultTys down)
 487
 488 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 489 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 490
 491 -- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
 492 -- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
 493 tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
 494                       -> (TcDown s -> env -> result)
 495 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 496
 497 tcGetSrcLoc :: NF_TcM s SrcLoc
 498 tcGetSrcLoc down env = returnSST (getLoc down)
 499
 500 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message))
 501                              -> TcM s a -> TcM s a
 502 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 503 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 504
 505 tcSetErrCtxt, tcAddErrCtxt
 506           :: Message
 507           -> (TcDown s -> TcEnv s -> State# s -> b)
 508           ->  TcDown s -> TcEnv s -> State# s -> b
 509 -- Usual thing
 510 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 511 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 512 \end{code}
 513
 514
 515 Unique supply
 516 ~~~~~~~~~~~~~
 517 \begin{code}
 518 tcGetUnique :: NF_TcM s Unique
 519 tcGetUnique down env
 520   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 521     let
 522       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 523       uniq                      = uniqFromSupply uniq_s
 524     in
 525     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 526     returnSST uniq
 527   where
 528     u_var = getUniqSupplyVar down
 529
 530 tcGetUniques :: Int -> NF_TcM s [Unique]
 531 tcGetUniques n down env
 532   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 533     let
 534       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 535       uniqs                     = uniqsFromSupply n uniq_s
 536     in
 537     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 538     returnSST uniqs
 539   where
 540     u_var = getUniqSupplyVar down
 541
 542 uniqSMToTcM :: UniqSM a -> NF_TcM s a
 543 uniqSMToTcM m down env
 544   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 545     let
 546       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 547     in
 548     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 549     returnSST (initUs uniq_s m)
 550   where
 551     u_var = getUniqSupplyVar down
 552 \end{code}
 553
 554
 555 \section{TcDown}
 556 %~~~~~~~~~~~~~~~
 557
 558 \begin{code}
 559 data TcDown s
 560   = TcDown
 561         [Type]                          -- Types used for defaulting
 562
 563         (TcRef s UniqSupply)    -- Unique supply
 564
 565         SrcLoc                          -- Source location
 566         (ErrCtxt s)                     -- Error context
 567         (TcRef s (Bag WarnMsg,
 568                   Bag ErrMsg))
 569
 570 -- The TidyTypeEnv gives us a chance to tidy up the type,
 571 -- so it prints nicely in error messages
 572 type TidyTypeEnv s = (FiniteMap FastString Int, -- Says what the 'next' unique to use
 573                                                 -- for this occname is
 574                       TyVarEnv (TcType s))      -- Current mapping
 575
 576 emptyTidyEnv :: TidyTypeEnv s
 577 emptyTidyEnv = (emptyFM, emptyVarEnv)
 578
 579 type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message)]
 580                         -- Innermost first.  Monadic so that we have a chance
 581                         -- to deal with bound type variables just before error
 582                         -- message construction
 583 \end{code}
 584
 585 -- These selectors are *local* to TcMonad.lhs
 586
 587 \begin{code}
 588 getTcErrs (TcDown def us loc ctxt errs)      = errs
 589 setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 590
 591 getDefaultTys (TcDown def us loc ctxt errs)     = def
 592 setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 593
 594 getLoc (TcDown def us loc ctxt errs)     = loc
 595 setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 596
 597 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 598
 599 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
 600 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
 601 getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 602 \end{code}
 603
 604
 605
 606
 607 TypeChecking Errors
 608 ~~~~~~~~~~~~~~~~~~~
 609
 610 \begin{code}
 611 type TcError   = Message
 612 type TcWarning = Message
 613
 614 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 615                  | otherwise          = takeAtMost 3 ctxt
 616                  where
 617                    takeAtMost :: Int -> [a] -> [a]
 618                    takeAtMost 0 ls = []
 619                    takeAtMost n [] = []
 620                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 621
 622 arityErr kind name n m
 623   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 624            n_arguments <> comma, text "but has been given", int m]
 625     where
 626         n_arguments | n == 0 = ptext SLIT("no arguments")
 627                     | n == 1 = ptext SLIT("1 argument")
 628                     | True   = hsep [int n, ptext SLIT("arguments")]
 629 \end{code}
 630
 631