ghc/compiler/typecheck/TcMonad.lhs

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