ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType,
   4         TcTauType, TcPredType, TcThetaType, TcRhoType,
   5         TcTyVar, TcTyVarSet,
   6         TcKind,
   7
   8         TcM, NF_TcM, TcDown, TcEnv,
   9
  10         initTc,
  11         returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
  12         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  13         mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
  14         traceTc, ioToTc,
  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, addInstErrTcM, failWithTcM,
  26
  27         tcGetEnv, tcSetEnv,
  28         tcGetDefaultTys, tcSetDefaultTys,
  29         tcGetUnique, tcGetUniques,
  30
  31         tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
  32         tcAddErrCtxtM, tcSetErrCtxtM,
  33         tcAddErrCtxt, tcSetErrCtxt,
  34
  35         tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
  36         tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
  37
  38         InstOrigin(..), InstLoc, pprInstLoc,
  39
  40         TcError, TcWarning, TidyEnv, emptyTidyEnv,
  41         arityErr
  42   ) where
  43
  44 #include "HsVersions.h"
  45
  46 import {-# SOURCE #-} TcEnv  ( TcEnv )
  47
  48 import HsSyn            ( HsLit )
  49 import RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
  50 import Type             ( Type, Kind, PredType, ThetaType, RhoType, TauType,
  51                         )
  52 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
  53 import CmdLineOpts      ( opt_PprStyle_Debug )
  54
  55 import Bag              ( Bag, emptyBag, isEmptyBag,
  56                           foldBag, unitBag, unionBags, snocBag )
  57 import Class            ( Class )
  58 import Name             ( Name )
  59 import Var              ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
  60 import VarEnv           ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
  61 import VarSet           ( TyVarSet )
  62 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
  63                           UniqSM, initUs_ )
  64 import SrcLoc           ( SrcLoc, noSrcLoc )
  65 import UniqFM           ( UniqFM, emptyUFM )
  66 import Unique           ( Unique )
  67 import BasicTypes       ( Unused )
  68 import Outputable
  69 import FastString       ( FastString )
  70
  71 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  72                           unsafeInterleaveIO, fixIO
  73                         )
  74
  75
  76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  77 \end{code}
  78
  79
  80 Types
  81 ~~~~~
  82 \begin{code}
  83 type TcTyVar    = TyVar         -- Might be a mutable tyvar
  84 type TcTyVarSet = TyVarSet
  85
  86 type TcType = Type              -- A TcType can have mutable type variables
  87         -- Invariant on ForAllTy in TcTypes:
  88         --      forall a. T
  89         -- a cannot occur inside a MutTyVar in T; that is,
  90         -- T is "flattened" before quantifying over a
  91
  92 type TcPredType  = PredType
  93 type TcThetaType = ThetaType
  94 type TcRhoType   = RhoType
  95 type TcTauType   = TauType
  96 type TcKind      = TcType
  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 -> TcEnv -> IO r      -- Can't raise UserError
 105 type TcM    s r =  TcDown -> TcEnv -> IO r      -- Can raise UserError
 106         -- ToDo: nuke the 's' part
 107         -- The difference between the two is
 108         -- now for documentation purposes only
 109
 110 type Either_TcM s r =  TcDown -> TcEnv -> IO r  -- Either NF_TcM or TcM
 111         -- Used only in this file for type signatures which
 112         -- have a part that's polymorphic in whether it's NF_TcM or TcM
 113         -- E.g. thenNF_Tc
 114
 115 type TcRef a = IORef a
 116 \end{code}
 117
 118 \begin{code}
 119 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
 120
 121 initTc :: UniqSupply
 122        -> (TcRef (UniqFM a) -> TcEnv)
 123        -> TcM s r
 124        -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
 125
 126 initTc us initenv do_this
 127   = do {
 128       us_var   <- newIORef us ;
 129       errs_var <- newIORef (emptyBag,emptyBag) ;
 130       tvs_var  <- newIORef emptyUFM ;
 131
 132       let
 133           init_down = TcDown [] us_var
 134                              noSrcLoc
 135                              [] errs_var
 136           init_env  = initenv tvs_var
 137       ;
 138
 139       maybe_res <- catch (do {  res <- do_this init_down init_env ;
 140                                 return (Just res)})
 141                          (\_ -> return Nothing) ;
 142
 143       (warns,errs) <- readIORef errs_var ;
 144       return (maybe_res, warns, errs)
 145     }
 146
 147 -- Monadic operations
 148
 149 returnNF_Tc :: a -> NF_TcM s a
 150 returnTc    :: a -> TcM s a
 151 returnTc v down env = return v
 152
 153 thenTc    :: TcM s a ->    (a -> TcM s b)        -> TcM s b
 154 thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
 155 thenTc m k down env = do { r <- m down env; k r down env }
 156
 157 thenTc_    :: TcM s a    -> TcM s b        -> TcM s b
 158 thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
 159 thenTc_ m k down env = do { m down env; k down env }
 160
 161 listTc    :: [TcM s a]    -> TcM s [a]
 162 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
 163 listTc []     = returnTc []
 164 listTc (x:xs) = x                       `thenTc` \ r ->
 165                 listTc xs               `thenTc` \ rs ->
 166                 returnTc (r:rs)
 167
 168 mapTc    :: (a -> TcM s b)    -> [a] -> TcM s [b]
 169 mapTc_   :: (a -> TcM s b)    -> [a] -> TcM s ()
 170 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 171 mapTc f []     = returnTc []
 172 mapTc f (x:xs) = f x            `thenTc` \ r ->
 173                  mapTc f xs     `thenTc` \ rs ->
 174                  returnTc (r:rs)
 175 mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
 176
 177
 178 foldrTc    :: (a -> b -> TcM s b)    -> b -> [a] -> TcM s b
 179 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
 180 foldrTc k z []     = returnTc z
 181 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 182                      k x r
 183
 184 foldlTc    :: (a -> b -> TcM s a)    -> a -> [b] -> TcM s a
 185 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
 186 foldlTc k z []     = returnTc z
 187 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 188                      foldlTc k r xs
 189
 190 mapAndUnzipTc    :: (a -> TcM s (b,c))    -> [a]   -> TcM s ([b],[c])
 191 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
 192 mapAndUnzipTc f []     = returnTc ([],[])
 193 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 194                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 195                          returnTc (r1:rs1, r2:rs2)
 196
 197 mapAndUnzip3Tc    :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
 198 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 199 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 200                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 201                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 202
 203 mapBagTc    :: (a -> TcM s b)    -> Bag a -> TcM s (Bag b)
 204 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
 205 mapBagTc f bag
 206   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 207                         b2 `thenTc` \ r2 ->
 208                         returnTc (unionBags r1 r2))
 209             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 210             (returnTc emptyBag)
 211             bag
 212
 213 fixTc    :: (a -> TcM s a)    -> TcM s a
 214 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
 215 fixTc m env down = fixIO (\ loop -> m loop env down)
 216
 217 recoverTc    :: TcM s r -> TcM s r -> TcM s r
 218 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
 219 recoverTc recover m down env
 220   = catch (m down env) (\ _ -> recover down env)
 221
 222 returnNF_Tc      = returnTc
 223 thenNF_Tc        = thenTc
 224 thenNF_Tc_       = thenTc_
 225 fixNF_Tc         = fixTc
 226 recoverNF_Tc     = recoverTc
 227 mapNF_Tc         = mapTc
 228 foldrNF_Tc       = foldrTc
 229 foldlNF_Tc       = foldlTc
 230 listNF_Tc        = listTc
 231 mapAndUnzipNF_Tc = mapAndUnzipTc
 232 mapBagNF_Tc      = mapBagTc
 233 \end{code}
 234
 235 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 236 thread.  Ideally, this elegantly ensures that it can't zap any type
 237 variables that belong to the main thread.  But alas, the environment
 238 contains TyCon and Class environments that include TcKind stuff,
 239 which is a Royal Pain.  By the time this fork stuff is used they'll
 240 have been unified down so there won't be any kind variables, but we
 241 can't express that in the current typechecker framework.
 242
 243 So we compromise and use unsafeInterleaveSST.
 244
 245 We throw away any error messages!
 246
 247 \begin{code}
 248 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
 249 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 250   = do
 251         -- Get a fresh unique supply
 252         us <- readIORef u_var
 253         let (us1, us2) = splitUniqSupply us
 254         writeIORef u_var us1
 255
 256         unsafeInterleaveIO (do {
 257                 us_var'  <- newIORef us2 ;
 258                 err_var' <- newIORef (emptyBag,emptyBag) ;
 259                 tv_var'  <- newIORef emptyUFM ;
 260                 let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
 261                 m down' env
 262                         -- ToDo: optionally dump any error messages
 263                 })
 264 \end{code}
 265
 266 \begin{code}
 267 traceTc :: SDoc -> NF_TcM s ()
 268 traceTc doc down env = printErrs doc
 269
 270 ioToTc :: IO a -> NF_TcM s a
 271 ioToTc io down env = io
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection{Error handling}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 \begin{code}
 282 getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
 283 getErrsTc down env
 284   = readIORef (getTcErrs down)
 285
 286 failTc :: TcM s a
 287 failTc down env = give_up
 288
 289 give_up :: IO a
 290 give_up = IOERROR (userError "Typecheck failed")
 291
 292 failWithTc :: Message -> TcM s a                        -- Add an error message and fail
 293 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 294
 295 addErrTc :: Message -> NF_TcM s ()
 296 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 297
 298 -- The 'M' variants do the TidyEnv bit
 299 failWithTcM :: (TidyEnv, Message) -> TcM s a    -- Add an error message and fail
 300 failWithTcM env_and_msg
 301   = addErrTcM env_and_msg       `thenNF_Tc_`
 302     failTc
 303
 304 checkTc :: Bool -> Message -> TcM s ()          -- Check that the boolean is true
 305 checkTc True  err = returnTc ()
 306 checkTc False err = failWithTc err
 307
 308 checkTcM :: Bool -> TcM s () -> TcM s ()        -- Check that the boolean is true
 309 checkTcM True  err = returnTc ()
 310 checkTcM False err = err
 311
 312 checkMaybeTc :: Maybe val -> Message -> TcM s val
 313 checkMaybeTc (Just val) err = returnTc val
 314 checkMaybeTc Nothing    err = failWithTc err
 315
 316 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
 317 checkMaybeTcM (Just val) err = returnTc val
 318 checkMaybeTcM Nothing    err = err
 319
 320 addErrTcM :: (TidyEnv, Message) -> NF_TcM s ()  -- Add an error message but don't fail
 321 addErrTcM (tidy_env, err_msg) down env
 322   = add_err_tcm tidy_env err_msg ctxt loc down env
 323   where
 324     ctxt     = getErrCtxt down
 325     loc      = getLoc down
 326
 327 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s ()   -- Add an error message but don't fail
 328 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
 329   = add_err_tcm tidy_env err_msg full_ctxt loc down env
 330   where
 331     full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
 332
 333 add_err_tcm tidy_env err_msg ctxt loc down env
 334   = do
 335         (warns, errs) <- readIORef errs_var
 336         ctxt_msgs     <- do_ctxt tidy_env ctxt down env
 337         let err = addShortErrLocLine loc $
 338                   vcat (err_msg : ctxt_to_use ctxt_msgs)
 339         writeIORef errs_var (warns, errs `snocBag` err)
 340   where
 341     errs_var = getTcErrs down
 342
 343 do_ctxt tidy_env [] down env
 344   = return []
 345 do_ctxt tidy_env (c:cs) down env
 346   = do
 347         (tidy_env', m) <- c tidy_env down env
 348         ms             <- do_ctxt tidy_env' cs down env
 349         return (m:ms)
 350
 351 -- warnings don't have an 'M' variant
 352 warnTc :: Bool -> Message -> NF_TcM s ()
 353 warnTc warn_if_true warn_msg down env
 354   | warn_if_true
 355   = do
 356         (warns,errs) <- readIORef errs_var
 357         ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env
 358         let warn = addShortWarnLocLine loc $
 359                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 360         writeIORef errs_var (warns `snocBag` warn, errs)
 361   | otherwise
 362   = return ()
 363   where
 364     errs_var = getTcErrs down
 365     ctxt     = getErrCtxt down
 366     loc      = getLoc down
 367
 368 -- (tryTc r m) succeeds if m succeeds and generates no errors
 369 -- If m fails then r is invoked, passing the warnings and errors from m
 370 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
 371 --      (it might have recovered internally)
 372 --      If so, then r is invoked, passing the warnings and errors from m
 373
 374 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
 375       -> TcM s r                                -- Thing to try
 376       -> TcM s r
 377 tryTc recover main down env
 378   = do
 379         m_errs_var <- newIORef (emptyBag,emptyBag)
 380         catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
 381   where
 382     my_recover m_errs_var
 383       = do warns_and_errs <- readIORef m_errs_var
 384            recover warns_and_errs down env
 385
 386     my_main m_errs_var
 387        = do result <- main (setTcErrs down m_errs_var) env
 388
 389                 -- Check that m has no errors; if it has internal recovery
 390                 -- mechanisms it might "succeed" but having found a bunch of
 391                 -- errors along the way.
 392             (m_warns, m_errs) <- readIORef m_errs_var
 393             if isEmptyBag m_errs then
 394                 return result
 395               else
 396                 give_up         -- This triggers the catch
 397
 398
 399 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 400 -- If m fails then (checkNoErrsTc m) fails.
 401 -- If m succeeds, it checks whether m generated any errors messages
 402 --      (it might have recovered internally)
 403 --      If so, it fails too.
 404 -- Regardless, any errors generated by m are propagated to the enclosing context.
 405 checkNoErrsTc :: TcM s r -> TcM s r
 406 checkNoErrsTc main
 407   = tryTc my_recover main
 408   where
 409     my_recover (m_warns, m_errs) down env
 410         = do (warns, errs)     <- readIORef errs_var
 411              writeIORef errs_var (warns `unionBags` m_warns,
 412                                   errs  `unionBags` m_errs)
 413              give_up
 414         where
 415           errs_var = getTcErrs down
 416
 417
 418 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 419 -- otherwise it returns r.  Any error messages added by m are discarded,
 420 -- whether or not m succeeds.
 421 tryTc_ :: TcM s r -> TcM s r -> TcM s r
 422 tryTc_ recover main
 423   = tryTc my_recover main
 424   where
 425     my_recover warns_and_errs = recover
 426
 427 -- (discardErrsTc m) runs m, but throw away all its error messages.
 428 discardErrsTc :: Either_TcM s r -> Either_TcM s r
 429 discardErrsTc main down env
 430   = do new_errs_var <- newIORef (emptyBag,emptyBag)
 431        main (setTcErrs down new_errs_var) env
 432 \end{code}
 433
 434 Mutable variables
 435 ~~~~~~~~~~~~~~~~~
 436 \begin{code}
 437 tcNewMutVar :: a -> NF_TcM s (TcRef a)
 438 tcNewMutVar val down env = newIORef val
 439
 440 tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
 441 tcWriteMutVar var val down env = writeIORef var val
 442
 443 tcReadMutVar :: TcRef a -> NF_TcM s a
 444 tcReadMutVar var down env = readIORef var
 445
 446 tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
 447 tcNewMutTyVar name kind down env = newMutTyVar name kind
 448
 449 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
 450 tcNewSigTyVar name kind down env = newSigTyVar name kind
 451
 452 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
 453 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 454
 455 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
 456 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 457 \end{code}
 458
 459
 460 Environment
 461 ~~~~~~~~~~~
 462 \begin{code}
 463 tcGetEnv :: NF_TcM s TcEnv
 464 tcGetEnv down env = return env
 465
 466 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
 467 tcSetEnv new_env m down old_env = m down new_env
 468 \end{code}
 469
 470
 471 Source location
 472 ~~~~~~~~~~~~~~~
 473 \begin{code}
 474 tcGetDefaultTys :: NF_TcM s [Type]
 475 tcGetDefaultTys down env = return (getDefaultTys down)
 476
 477 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 478 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 479
 480 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
 481 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 482
 483 tcGetSrcLoc :: NF_TcM s SrcLoc
 484 tcGetSrcLoc down env = return (getLoc down)
 485
 486 tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
 487 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
 488
 489 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
 490                              -> TcM s a -> TcM s a
 491 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 492 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 493
 494 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
 495 -- Usual thing
 496 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 497 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 498 \end{code}
 499
 500
 501 Unique supply
 502 ~~~~~~~~~~~~~
 503 \begin{code}
 504 tcGetUnique :: NF_TcM s Unique
 505 tcGetUnique down env
 506   = do  uniq_supply <- readIORef u_var
 507         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 508             uniq                      = uniqFromSupply uniq_s
 509         writeIORef u_var new_uniq_supply
 510         return uniq
 511   where
 512     u_var = getUniqSupplyVar down
 513
 514 tcGetUniques :: Int -> NF_TcM s [Unique]
 515 tcGetUniques n down env
 516   = do  uniq_supply <- readIORef u_var
 517         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 518             uniqs                     = uniqsFromSupply n uniq_s
 519         writeIORef u_var new_uniq_supply
 520         return uniqs
 521   where
 522     u_var = getUniqSupplyVar down
 523
 524 uniqSMToTcM :: UniqSM a -> NF_TcM s a
 525 uniqSMToTcM m down env
 526   = do  uniq_supply <- readIORef u_var
 527         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 528         writeIORef u_var new_uniq_supply
 529         return (initUs_ uniq_s m)
 530   where
 531     u_var = getUniqSupplyVar down
 532 \end{code}
 533
 534
 535 \section{TcDown}
 536 %~~~~~~~~~~~~~~~
 537
 538 \begin{code}
 539 data TcDown
 540   = TcDown
 541         [Type]                  -- Types used for defaulting
 542
 543         (TcRef UniqSupply)      -- Unique supply
 544
 545         SrcLoc                  -- Source location
 546         ErrCtxt                 -- Error context
 547         (TcRef (Bag WarnMsg,
 548                   Bag ErrMsg))
 549
 550 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
 551                         -- Innermost first.  Monadic so that we have a chance
 552                         -- to deal with bound type variables just before error
 553                         -- message construction
 554 \end{code}
 555
 556 -- These selectors are *local* to TcMonad.lhs
 557
 558 \begin{code}
 559 getTcErrs (TcDown def us loc ctxt errs)      = errs
 560 setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 561
 562 getDefaultTys (TcDown def us loc ctxt errs)     = def
 563 setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 564
 565 getLoc (TcDown def us loc ctxt errs)     = loc
 566 setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 567
 568 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 569
 570 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
 571 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
 572 getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 573 \end{code}
 574
 575
 576
 577
 578 TypeChecking Errors
 579 ~~~~~~~~~~~~~~~~~~~
 580
 581 \begin{code}
 582 type TcError   = Message
 583 type TcWarning = Message
 584
 585 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 586                  | otherwise          = takeAtMost 3 ctxt
 587                  where
 588                    takeAtMost :: Int -> [a] -> [a]
 589                    takeAtMost 0 ls = []
 590                    takeAtMost n [] = []
 591                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 592
 593 arityErr kind name n m
 594   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 595            n_arguments <> comma, text "but has been given", int m]
 596     where
 597         n_arguments | n == 0 = ptext SLIT("no arguments")
 598                     | n == 1 = ptext SLIT("1 argument")
 599                     | True   = hsep [int n, ptext SLIT("arguments")]
 600 \end{code}
 601
 602
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection[Inst-origin]{The @InstOrigin@ type}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 The @InstOrigin@ type gives information about where a dictionary came from.
 611 This is important for decent error message reporting because dictionaries
 612 don't appear in the original source code.  Doubtless this type will evolve...
 613
 614 It appears in TcMonad because there are a couple of error-message-generation
 615 functions that deal with it.
 616
 617 \begin{code}
 618 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 619
 620 data InstOrigin
 621   = OccurrenceOf Id             -- Occurrence of an overloaded identifier
 622
 623   | RecordUpdOrigin
 624
 625   | DataDeclOrigin              -- Typechecking a data declaration
 626
 627   | InstanceDeclOrigin          -- Typechecking an instance decl
 628
 629   | LiteralOrigin HsLit         -- Occurrence of a literal
 630
 631   | PatOrigin RenamedPat
 632
 633   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 634
 635   | SignatureOrigin             -- A dict created from a type signature
 636   | Rank2Origin                 -- A dict created when typechecking the argument
 637                                 -- of a rank-2 typed function
 638
 639   | DoOrigin                    -- The monad for a do expression
 640
 641   | ClassDeclOrigin             -- Manufactured during a class decl
 642
 643   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 644                         Type
 645
 646         -- When specialising instances the instance info attached to
 647         -- each class is not yet ready, so we record it inside the
 648         -- origin information.  This is a bit of a hack, but it works
 649         -- fine.  (Patrick is to blame [WDP].)
 650
 651   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 652
 653         -- Argument or result of a ccall
 654         -- Dictionaries with this origin aren't actually mentioned in the
 655         -- translated term, and so need not be bound.  Nor should they
 656         -- be abstracted over.
 657
 658   | CCallOrigin         String                  -- CCall label
 659                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 660                                                 -- Just arg, for an argument
 661
 662   | LitLitOrigin        String  -- the litlit
 663
 664   | UnknownOrigin       -- Help! I give up...
 665 \end{code}
 666
 667 \begin{code}
 668 pprInstLoc :: InstLoc -> SDoc
 669 pprInstLoc (orig, locn, ctxt)
 670   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 671   where
 672     pp_orig (OccurrenceOf id)
 673         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 674     pp_orig (LiteralOrigin lit)
 675         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 676     pp_orig (PatOrigin pat)
 677         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 678     pp_orig (InstanceDeclOrigin)
 679         =  ptext SLIT("an instance declaration")
 680     pp_orig (ArithSeqOrigin seq)
 681         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 682     pp_orig (SignatureOrigin)
 683         =  ptext SLIT("a type signature")
 684     pp_orig (Rank2Origin)
 685         =  ptext SLIT("a function with an overloaded argument type")
 686     pp_orig (DoOrigin)
 687         =  ptext SLIT("a do statement")
 688     pp_orig (ClassDeclOrigin)
 689         =  ptext SLIT("a class declaration")
 690     pp_orig (InstanceSpecOrigin clas ty)
 691         = hsep [text "a SPECIALIZE instance pragma; class",
 692                 quotes (ppr clas), text "type:", ppr ty]
 693     pp_orig (ValSpecOrigin name)
 694         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 695     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 696         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 697     pp_orig (CCallOrigin clabel (Just arg_expr))
 698         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 699                 text "namely", quotes (ppr arg_expr)]
 700     pp_orig (LitLitOrigin s)
 701         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 702     pp_orig (UnknownOrigin)
 703         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 704 \end{code}