ghc/compiler/typecheck/TcMonad.lhs

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