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