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