ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           HsBinds(..), Stmt(..), StmtCtxt(..)
  13                         )
  14 import RnHsSyn          ( RenamedHsExpr, RenamedRecordBinds )
  15 import TcHsSyn          ( TcExpr, TcRecordBinds,
  16                           mkHsTyApp, mkHsLet, maybeBoxedPrimType
  17                         )
  18
  19 import TcMonad
  20 import BasicTypes       ( RecFlag(..) )
  21
  22 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  23                           LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
  24                           newMethod, instOverloadedFun, newDicts, instToId )
  25 import TcBinds          ( tcBindsAndThen )
  26 import TcEnv            ( tcInstId,
  27                           tcLookupValue, tcLookupClassByKey,
  28                           tcLookupValueByKey,
  29                           tcExtendGlobalTyVars, tcLookupValueMaybe,
  30                           tcLookupTyCon, tcLookupDataCon
  31                         )
  32 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  33 import TcMonoType       ( tcHsType, checkSigTyVars, sigCtxt )
  34 import TcPat            ( badFieldCon )
  35 import TcSimplify       ( tcSimplifyAndCheck )
  36 import TcType           ( TcType, TcTauType,
  37                           tcInstTyVars,
  38                           tcInstTcType, tcSplitRhoTy,
  39                           newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
  40
  41 import Class            ( Class )
  42 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType )
  43 import Id               ( idType, recordSelectorFieldLabel,
  44                           isRecordSelector,
  45                           Id
  46                         )
  47 import DataCon          ( dataConFieldLabels, dataConSig, dataConId )
  48 import Name             ( Name )
  49 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
  50                           splitFunTy_maybe, splitFunTys, isNotUsgTy,
  51                           mkTyConApp,
  52                           splitForAllTys, splitRhoTy,
  53                           isTauTy, tyVarsOfType, tyVarsOfTypes,
  54                           isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
  55                           boxedTypeKind, mkArrowKind,
  56                           tidyOpenType
  57                         )
  58 import Subst            ( mkTopTyVarSubst, substTheta )
  59 import UsageSPUtils     ( unannotTy )
  60 import VarSet           ( elemVarSet, mkVarSet )
  61 import TyCon            ( tyConDataCons )
  62 import TysPrim          ( intPrimTy, charPrimTy, doublePrimTy,
  63                           floatPrimTy, addrPrimTy
  64                         )
  65 import TysWiredIn       ( boolTy, charTy, stringTy )
  66 import PrelInfo         ( ioTyCon_NAME )
  67 import TcUnify          ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
  68                           unifyUnboxedTupleTy )
  69 import Unique           ( cCallableClassKey, cReturnableClassKey,
  70                           enumFromClassOpKey, enumFromThenClassOpKey,
  71                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  72                           thenMClassOpKey, failMClassOpKey, returnMClassOpKey
  73                         )
  74 import Outputable
  75 import Maybes           ( maybeToBool )
  76 import ListSetOps       ( minusList )
  77 import Util
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Main wrappers}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 tcExpr :: RenamedHsExpr                 -- Expession to type check
  88         -> TcType                       -- Expected type (could be a polytpye)
  89         -> TcM s (TcExpr, LIE)
  90
  91 tcExpr expr ty | isForAllTy ty = -- Polymorphic case
  92                                  tcPolyExpr expr ty     `thenTc` \ (expr', lie, _, _, _) ->
  93                                  returnTc (expr', lie)
  94
  95                | otherwise     = -- Monomorphic case
  96                                  tcMonoExpr expr ty
  97 \end{code}
  98
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{@tcPolyExpr@ typchecks an application}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 \begin{code}
 107 -- tcPolyExpr is like tcMonoExpr, except that the expected type
 108 -- can be a polymorphic one.
 109 tcPolyExpr :: RenamedHsExpr
 110            -> TcType                            -- Expected type
 111            -> TcM s (TcExpr, LIE,               -- Generalised expr with expected type, and LIE
 112                      TcExpr, TcTauType, LIE)    -- Same thing, but instantiated; tau-type returned
 113
 114 tcPolyExpr arg expected_arg_ty
 115   =     -- Ha!  The argument type of the function is a for-all type,
 116         -- An example of rank-2 polymorphism.
 117
 118         -- To ensure that the forall'd type variables don't get unified with each
 119         -- other or any other types, we make fresh copy of the alleged type
 120     tcInstTcType expected_arg_ty        `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 121     let
 122         (sig_theta, sig_tau) = splitRhoTy sig_rho
 123     in
 124         -- Type-check the arg and unify with expected type
 125     tcMonoExpr arg sig_tau                              `thenTc` \ (arg', lie_arg) ->
 126
 127         -- Check that the sig_tyvars havn't been constrained
 128         -- The interesting bit here is that we must include the free variables
 129         -- of the expected arg ty.  Here's an example:
 130         --       runST (newVar True)
 131         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 132         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 133         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 134         -- So now s' isn't unconstrained because it's linked to a.
 135         -- Conclusion: include the free vars of the expected arg type in the
 136         -- list of "free vars" for the signature check.
 137
 138     tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty)         $
 139     tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty)             $
 140
 141     checkSigTyVars sig_tyvars                   `thenTc` \ zonked_sig_tyvars ->
 142
 143     newDicts SignatureOrigin sig_theta          `thenNF_Tc` \ (sig_dicts, dict_ids) ->
 144         -- ToDo: better origin
 145     tcSimplifyAndCheck
 146         (text "tcPolyExpr")
 147         (mkVarSet zonked_sig_tyvars)
 148         sig_dicts lie_arg                       `thenTc` \ (free_insts, inst_binds) ->
 149
 150     let
 151             -- This HsLet binds any Insts which came out of the simplification.
 152             -- It's a bit out of place here, but using AbsBind involves inventing
 153             -- a couple of new names which seems worse.
 154         generalised_arg = TyLam zonked_sig_tyvars $
 155                           DictLam dict_ids $
 156                           mkHsLet inst_binds $
 157                           arg'
 158     in
 159     returnTc ( generalised_arg, free_insts,
 160                arg', sig_tau, lie_arg )
 161   where
 162     sig_msg ty = ptext SLIT("In an expression with expected type:") <+> ppr ty
 163 \end{code}
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection{The TAUT rules for variables}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 tcMonoExpr :: RenamedHsExpr             -- Expession to type check
 173            -> TcTauType                         -- Expected type (could be a type variable)
 174            -> TcM s (TcExpr, LIE)
 175
 176 tcMonoExpr (HsVar name) res_ty
 177   = tcId name                   `thenNF_Tc` \ (expr', lie, id_ty) ->
 178     unifyTauTy res_ty id_ty     `thenTc_`
 179
 180     -- Check that the result type doesn't have any nested for-alls.
 181     -- For example, a "build" on its own is no good; it must be
 182     -- applied to something.
 183     checkTc (isTauTy id_ty)
 184             (lurkingRank2Err name id_ty) `thenTc_`
 185
 186     returnTc (expr', lie)
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection{Literals}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 Overloaded literals.
 196
 197 \begin{code}
 198 tcMonoExpr (HsLit (HsInt i)) res_ty
 199   = newOverloadedLit (LiteralOrigin (HsInt i))
 200                      (OverloadedIntegral i)
 201                      res_ty  `thenNF_Tc` \ stuff ->
 202     returnTc stuff
 203
 204 tcMonoExpr (HsLit (HsFrac f)) res_ty
 205   = newOverloadedLit (LiteralOrigin (HsFrac f))
 206                      (OverloadedFractional f)
 207                      res_ty  `thenNF_Tc` \ stuff ->
 208     returnTc stuff
 209
 210
 211 tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
 212   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 213     newDicts (LitLitOrigin (_UNPK_ s))
 214              [(cCallableClass, [res_ty])]               `thenNF_Tc` \ (dicts, _) ->
 215     returnTc (HsLitOut lit res_ty, dicts)
 216 \end{code}
 217
 218 Primitive literals:
 219
 220 \begin{code}
 221 tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty
 222   = unifyTauTy res_ty charPrimTy                `thenTc_`
 223     returnTc (HsLitOut lit charPrimTy, emptyLIE)
 224
 225 tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty
 226   = unifyTauTy res_ty addrPrimTy                `thenTc_`
 227     returnTc (HsLitOut lit addrPrimTy, emptyLIE)
 228
 229 tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty
 230   = unifyTauTy res_ty intPrimTy         `thenTc_`
 231     returnTc (HsLitOut lit intPrimTy, emptyLIE)
 232
 233 tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty
 234   = unifyTauTy res_ty floatPrimTy               `thenTc_`
 235     returnTc (HsLitOut lit floatPrimTy, emptyLIE)
 236
 237 tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty
 238   = unifyTauTy res_ty doublePrimTy              `thenTc_`
 239     returnTc (HsLitOut lit doublePrimTy, emptyLIE)
 240 \end{code}
 241
 242 Unoverloaded literals:
 243
 244 \begin{code}
 245 tcMonoExpr (HsLit lit@(HsChar c)) res_ty
 246   = unifyTauTy res_ty charTy            `thenTc_`
 247     returnTc (HsLitOut lit charTy, emptyLIE)
 248
 249 tcMonoExpr (HsLit lit@(HsString str)) res_ty
 250   = unifyTauTy res_ty stringTy          `thenTc_`
 251     returnTc (HsLitOut lit stringTy, emptyLIE)
 252 \end{code}
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection{Other expression forms}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 \begin{code}
 261 tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
 262   = tcMonoExpr expr res_ty
 263
 264 -- perform the negate *before* overloading the integer, since the case
 265 -- of minBound on Ints fails otherwise.  Could be done elsewhere, but
 266 -- convenient to do it here.
 267
 268 tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty
 269   = tcMonoExpr (HsLit (HsInt (-i))) res_ty
 270
 271 tcMonoExpr (NegApp expr neg) res_ty
 272   = tcMonoExpr (HsApp neg expr) res_ty
 273
 274 tcMonoExpr (HsLam match) res_ty
 275   = tcMatchLambda match res_ty          `thenTc` \ (match',lie) ->
 276     returnTc (HsLam match', lie)
 277
 278 tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
 279   where
 280     accum (HsApp e1 e2) args = accum e1 (e2:args)
 281     accum fun args
 282       = tcApp fun args res_ty   `thenTc` \ (fun', args', lie) ->
 283         returnTc (foldl HsApp fun' args', lie)
 284
 285 -- equivalent to (op e1) e2:
 286 tcMonoExpr (OpApp arg1 op fix arg2) res_ty
 287   = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
 288     returnTc (OpApp arg1' op' fix arg2', lie)
 289 \end{code}
 290
 291 Note that the operators in sections are expected to be binary, and
 292 a type error will occur if they aren't.
 293
 294 \begin{code}
 295 -- Left sections, equivalent to
 296 --      \ x -> e op x,
 297 -- or
 298 --      \ x -> op e x,
 299 -- or just
 300 --      op e
 301
 302 tcMonoExpr in_expr@(SectionL arg op) res_ty
 303   = tcApp op [arg] res_ty               `thenTc` \ (op', [arg'], lie) ->
 304
 305         -- Check that res_ty is a function type
 306         -- Without this check we barf in the desugarer on
 307         --      f op = (3 `op`)
 308         -- because it tries to desugar to
 309         --      f op = \r -> 3 op r
 310         -- so (3 `op`) had better be a function!
 311     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 312     unifyFunTy res_ty                   `thenTc_`
 313
 314     returnTc (SectionL arg' op', lie)
 315
 316 -- Right sections, equivalent to \ x -> x op expr, or
 317 --      \ x -> op x expr
 318
 319 tcMonoExpr in_expr@(SectionR op expr) res_ty
 320   = tcExpr_id op                `thenTc`    \ (op', lie1, op_ty) ->
 321     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 322     split_fun_ty op_ty 2 {- two args -}                 `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 323     tcMonoExpr expr arg2_ty                             `thenTc` \ (expr',lie2) ->
 324     unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty)       `thenTc_`
 325     returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
 326 \end{code}
 327
 328 The interesting thing about @ccall@ is that it is just a template
 329 which we instantiate by filling in details about the types of its
 330 argument and result (ie minimal typechecking is performed).  So, the
 331 basic story is that we allocate a load of type variables (to hold the
 332 arg/result types); unify them with the args/result; and store them for
 333 later use.
 334
 335 \begin{code}
 336 tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
 337   =     -- Get the callable and returnable classes.
 338     tcLookupClassByKey cCallableClassKey        `thenNF_Tc` \ cCallableClass ->
 339     tcLookupClassByKey cReturnableClassKey      `thenNF_Tc` \ cReturnableClass ->
 340     tcLookupTyCon ioTyCon_NAME                  `thenNF_Tc` \ ioTyCon ->
 341     let
 342         new_arg_dict (arg, arg_ty)
 343           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 344                      [(cCallableClass, [arg_ty])]       `thenNF_Tc` \ (arg_dicts, _) ->
 345             returnNF_Tc arg_dicts       -- Actually a singleton bag
 346
 347         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 348     in
 349
 350         -- Arguments
 351     let n_args = length args
 352         tv_idxs | n_args == 0 = []
 353                 | otherwise   = [1..n_args]
 354     in
 355     mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs       `thenNF_Tc` \ arg_tys ->
 356     tcMonoExprs args arg_tys                            `thenTc`    \ (args', args_lie) ->
 357
 358         -- The argument types can be unboxed or boxed; the result
 359         -- type must, however, be boxed since it's an argument to the IO
 360         -- type constructor.
 361     newTyVarTy boxedTypeKind            `thenNF_Tc` \ result_ty ->
 362     let
 363         io_result_ty = mkTyConApp ioTyCon [result_ty]
 364         [ioDataCon]  = tyConDataCons ioTyCon
 365     in
 366     unifyTauTy res_ty io_result_ty              `thenTc_`
 367
 368         -- Construct the extra insts, which encode the
 369         -- constraints on the argument and result types.
 370     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 371     newDicts result_origin [(cReturnableClass, [result_ty])]            `thenNF_Tc` \ (ccres_dict, _) ->
 372     returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
 373                     (CCall lbl args' may_gc is_asm result_ty),
 374                       -- do the wrapping in the newtype constructor here
 375               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 376 \end{code}
 377
 378 \begin{code}
 379 tcMonoExpr (HsSCC label expr) res_ty
 380   = tcMonoExpr expr res_ty              `thenTc` \ (expr', lie) ->
 381     returnTc (HsSCC label expr', lie)
 382
 383 tcMonoExpr (HsLet binds expr) res_ty
 384   = tcBindsAndThen
 385         combiner
 386         binds                   -- Bindings to check
 387         tc_expr         `thenTc` \ (expr', lie) ->
 388     returnTc (expr', lie)
 389   where
 390     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
 391               returnTc (expr', lie)
 392     combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
 393
 394 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
 395   = tcAddSrcLoc src_loc                 $
 396     tcAddErrCtxt (caseCtxt in_expr)     $
 397
 398         -- Typecheck the case alternatives first.
 399         -- The case patterns tend to give good type info to use
 400         -- when typechecking the scrutinee.  For example
 401         --      case (map f) of
 402         --        (x:xs) -> ...
 403         -- will report that map is applied to too few arguments
 404         --
 405         -- Not only that, but it's better to check the matches on their
 406         -- own, so that we get the expected results for scoped type variables.
 407         --      f x = case x of
 408         --              (p::a, q::b) -> (q,p)
 409         -- The above should work: the match (p,q) -> (q,p) is polymorphic as
 410         -- claimed by the pattern signatures.  But if we typechecked the
 411         -- match with x in scope and x's type as the expected type, we'd be hosed.
 412
 413     tcMatchesCase matches res_ty        `thenTc`    \ (scrut_ty, matches', lie2) ->
 414
 415     tcAddErrCtxt (caseScrutCtxt scrut)  (
 416       tcMonoExpr scrut scrut_ty
 417     )                                   `thenTc`    \ (scrut',lie1) ->
 418
 419     returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 420
 421 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 422   = tcAddSrcLoc src_loc $
 423     tcAddErrCtxt (predCtxt pred) (
 424     tcMonoExpr pred boolTy      )       `thenTc`    \ (pred',lie1) ->
 425
 426     tcMonoExpr b1 res_ty                `thenTc`    \ (b1',lie2) ->
 427     tcMonoExpr b2 res_ty                `thenTc`    \ (b2',lie3) ->
 428     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
 429 \end{code}
 430
 431 \begin{code}
 432 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
 433   = tcDoStmts do_or_lc stmts src_loc res_ty
 434 \end{code}
 435
 436 \begin{code}
 437 tcMonoExpr in_expr@(ExplicitList exprs) res_ty  -- Non-empty list
 438   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 439     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 440     returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
 441   where
 442     tc_elt elt_ty expr
 443       = tcAddErrCtxt (listCtxt expr) $
 444         tcMonoExpr expr elt_ty
 445
 446 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
 447   = (if boxed
 448         then unifyTupleTy (length exprs) res_ty
 449         else unifyUnboxedTupleTy (length exprs) res_ty
 450                                                 ) `thenTc` \ arg_tys ->
 451     mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
 452                (exprs `zip` arg_tys) -- we know they're of equal length.
 453                                                 `thenTc` \ (exprs', lies) ->
 454     returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
 455
 456 tcMonoExpr (RecordCon con_name rbinds) res_ty
 457   = tcId con_name                       `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 458     let
 459         (_, record_ty) = splitFunTys con_tau
 460     in
 461         -- Con is syntactically constrained to be a data constructor
 462     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
 463     unifyTauTy res_ty record_ty          `thenTc_`
 464
 465         -- Check that the record bindings match the constructor
 466     tcLookupDataCon con_name    `thenTc` \ (data_con, _, _) ->
 467     let
 468         bad_fields = badFields rbinds data_con
 469     in
 470     if not (null bad_fields) then
 471         mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields   `thenNF_Tc_`
 472         failTc  -- Fail now, because tcRecordBinds will crash on a bad field
 473     else
 474
 475         -- Typecheck the record bindings
 476     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 477
 478     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 479
 480
 481 -- The main complication with RecordUpd is that we need to explicitly
 482 -- handle the *non-updated* fields.  Consider:
 483 --
 484 --      data T a b = MkT1 { fa :: a, fb :: b }
 485 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 486 --                 | MkT3 { fd :: a }
 487 --
 488 --      upd :: T a b -> c -> T a c
 489 --      upd t x = t { fb = x}
 490 --
 491 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 492 -- because upd should be equivalent to:
 493 --
 494 --      upd t x = case t of
 495 --                      MkT1 p q -> MkT1 p x
 496 --                      MkT2 a b -> MkT2 p b
 497 --                      MkT3 d   -> error ...
 498 --
 499 -- So we need to give a completely fresh type to the result record,
 500 -- and then constrain it by the fields that are *not* updated ("p" above).
 501 --
 502 -- Note that because MkT3 doesn't contain all the fields being updated,
 503 -- its RHS is simply an error, so it doesn't impose any type constraints
 504 --
 505 -- All this is done in STEP 4 below.
 506
 507 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
 508   = tcAddErrCtxt recordUpdCtxt                  $
 509
 510         -- STEP 0
 511         -- Check that the field names are really field names
 512     ASSERT( not (null rbinds) )
 513     let
 514         field_names = [field_name | (field_name, _, _) <- rbinds]
 515     in
 516     mapNF_Tc tcLookupValueMaybe field_names             `thenNF_Tc` \ maybe_sel_ids ->
 517     let
 518         bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 519                                  case maybe_sel_id of
 520                                         Nothing -> True
 521                                         Just sel_id -> not (isRecordSelector sel_id)
 522                    ]
 523     in
 524     mapNF_Tc (addErrTc . notSelector) bad_guys  `thenTc_`
 525     if not (null bad_guys) then
 526         failTc
 527     else
 528
 529         -- STEP 1
 530         -- Figure out the tycon and data cons from the first field name
 531     let
 532         (Just sel_id : _)         = maybe_sel_ids
 533         (_, tau)                  = ASSERT( isNotUsgTy (idType sel_id) )
 534                                     splitForAllTys (idType sel_id)
 535         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 536         (tycon, _, data_cons)     = splitAlgTyConApp data_ty
 537         (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 538     in
 539     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 540
 541         -- STEP 2
 542         -- Check that at least one constructor has all the named fields
 543         -- i.e. has an empty set of bad fields returned by badFields
 544     checkTc (any (null . badFields rbinds) data_cons)
 545             (badFieldsUpd rbinds)               `thenTc_`
 546
 547         -- STEP 3
 548         -- Typecheck the update bindings.
 549         -- (Do this after checking for bad fields in case there's a field that
 550         --  doesn't match the constructor.)
 551     let
 552         result_record_ty = mkTyConApp tycon result_inst_tys
 553     in
 554     unifyTauTy res_ty result_record_ty          `thenTc_`
 555     tcRecordBinds result_record_ty rbinds       `thenTc` \ (rbinds', rbinds_lie) ->
 556
 557         -- STEP 4
 558         -- Use the un-updated fields to find a vector of booleans saying
 559         -- which type arguments must be the same in updatee and result.
 560         --
 561         -- WARNING: this code assumes that all data_cons in a common tycon
 562         -- have FieldLabels abstracted over the same tyvars.
 563     let
 564         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 565         con_field_lbls_s    = map dataConFieldLabels data_cons
 566
 567                 -- A constructor is only relevant to this process if
 568                 -- it contains all the fields that are being updated
 569         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 570         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 571
 572         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 573         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 574
 575         mk_inst_ty (tyvar, result_inst_ty)
 576           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 577           | otherwise                               = newTyVarTy boxedTypeKind  -- Fresh type
 578     in
 579     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 580
 581         -- STEP 5
 582         -- Typecheck the expression to be updated
 583     let
 584         record_ty = mkTyConApp tycon inst_tys
 585     in
 586     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 587
 588         -- STEP 6
 589         -- Figure out the LIE we need.  We have to generate some
 590         -- dictionaries for the data type context, since we are going to
 591         -- do some construction.
 592         --
 593         -- What dictionaries do we need?  For the moment we assume that all
 594         -- data constructors have the same context, and grab it from the first
 595         -- constructor.  If they have varying contexts then we'd have to
 596         -- union the ones that could participate in the update.
 597     let
 598         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 599         inst_env = mkTopTyVarSubst tyvars result_inst_tys
 600         theta'   = substTheta inst_env theta
 601     in
 602     newDicts RecordUpdOrigin theta'             `thenNF_Tc` \ (con_lie, dicts) ->
 603
 604         -- Phew!
 605     returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
 606               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
 607
 608 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 609   = unifyListTy res_ty                          `thenTc` \ elt_ty ->
 610     tcMonoExpr expr elt_ty                      `thenTc` \ (expr', lie1) ->
 611
 612     tcLookupValueByKey enumFromClassOpKey       `thenNF_Tc` \ sel_id ->
 613     newMethod (ArithSeqOrigin seq)
 614               sel_id [elt_ty]                   `thenNF_Tc` \ (lie2, enum_from_id) ->
 615
 616     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 617               lie1 `plusLIE` lie2)
 618
 619 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 620   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 621     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 622     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 623     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 624     tcLookupValueByKey enumFromThenClassOpKey           `thenNF_Tc` \ sel_id ->
 625     newMethod (ArithSeqOrigin seq)
 626               sel_id [elt_ty]                           `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 627
 628     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 629                            (FromThen expr1' expr2'),
 630               lie1 `plusLIE` lie2 `plusLIE` lie3)
 631
 632 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 633   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 634     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 635     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 636     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 637     tcLookupValueByKey enumFromToClassOpKey     `thenNF_Tc` \ sel_id ->
 638     newMethod (ArithSeqOrigin seq)
 639               sel_id [elt_ty]                           `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 640
 641     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 642                           (FromTo expr1' expr2'),
 643               lie1 `plusLIE` lie2 `plusLIE` lie3)
 644
 645 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 646   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 647     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 648     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 649     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 650     tcMonoExpr expr3 elt_ty     `thenTc`    \ (expr3',lie3) ->
 651     tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
 652     newMethod (ArithSeqOrigin seq)
 653               sel_id [elt_ty]                           `thenNF_Tc` \ (lie4, eft_id) ->
 654
 655     returnTc (ArithSeqOut (HsVar eft_id)
 656                            (FromThenTo expr1' expr2' expr3'),
 657               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
 658 \end{code}
 659
 660 %************************************************************************
 661 %*                                                                      *
 662 \subsection{Expressions type signatures}
 663 %*                                                                      *
 664 %************************************************************************
 665
 666 \begin{code}
 667 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 668  = tcSetErrCtxt (exprSigCtxt in_expr)   $
 669    tcHsType  poly_ty            `thenTc` \ sig_tc_ty ->
 670
 671    if not (isForAllTy sig_tc_ty) then
 672         -- Easy case
 673         unifyTauTy sig_tc_ty res_ty     `thenTc_`
 674         tcMonoExpr expr sig_tc_ty
 675
 676    else -- Signature is polymorphic
 677         tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 678
 679             -- Now match the signature type with res_ty.
 680             -- We must not do this earlier, because res_ty might well
 681             -- mention variables free in the environment, and we'd get
 682             -- bogus complaints about not being able to for-all the
 683             -- sig_tyvars
 684         unifyTauTy res_ty expr_ty                       `thenTc_`
 685
 686             -- If everything is ok, return the stuff unchanged, except for
 687             -- the effect of any substutions etc.  We simply discard the
 688             -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
 689             -- resolution it may have done, which is recorded in the
 690             -- substitution.
 691         returnTc (expr, lie)
 692 \end{code}
 693
 694 Typecheck expression which in most cases will be an Id.
 695
 696 \begin{code}
 697 tcExpr_id :: RenamedHsExpr
 698            -> TcM s (TcExpr,
 699                      LIE,
 700                      TcType)
 701 tcExpr_id id_expr
 702  = case id_expr of
 703         HsVar name -> tcId name                 `thenNF_Tc` \ stuff ->
 704                       returnTc stuff
 705         other      -> newTyVarTy_OpenKind       `thenNF_Tc` \ id_ty ->
 706                       tcMonoExpr id_expr id_ty  `thenTc`    \ (id_expr', lie_id) ->
 707                       returnTc (id_expr', lie_id, id_ty)
 708 \end{code}
 709
 710 %************************************************************************
 711 %*                                                                      *
 712 \subsection{@tcApp@ typchecks an application}
 713 %*                                                                      *
 714 %************************************************************************
 715
 716 \begin{code}
 717
 718 tcApp :: RenamedHsExpr -> [RenamedHsExpr]       -- Function and args
 719       -> TcType                                 -- Expected result type of application
 720       -> TcM s (TcExpr, [TcExpr],               -- Translated fun and args
 721                 LIE)
 722
 723 tcApp fun args res_ty
 724   =     -- First type-check the function
 725     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 726
 727     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 728         split_fun_ty fun_ty (length args)
 729     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 730
 731         -- Unify with expected result before type-checking the args
 732         -- This is when we might detect a too-few args situation
 733     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 734        unifyTauTy res_ty actual_result_ty
 735     )                                                   `thenTc_`
 736
 737         -- Now typecheck the args
 738     mapAndUnzipTc (tcArg fun)
 739           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 740
 741     -- Check that the result type doesn't have any nested for-alls.
 742     -- For example, a "build" on its own is no good; it must be applied to something.
 743     checkTc (isTauTy actual_result_ty)
 744             (lurkingRank2Err fun fun_ty)        `thenTc_`
 745
 746     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 747
 748
 749 -- If an error happens we try to figure out whether the
 750 -- function has been given too many or too few arguments,
 751 -- and say so
 752 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 753   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 754     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 755     let
 756       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 757       (env2, act_ty'') = tidyOpenType env1     act_ty'
 758       (exp_args, _) = splitFunTys exp_ty''
 759       (act_args, _) = splitFunTys act_ty''
 760
 761       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 762               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 763               | otherwise                         = appCtxt fun args
 764     in
 765     returnNF_Tc (env2, message)
 766
 767
 768 split_fun_ty :: TcType          -- The type of the function
 769              -> Int                     -- Number of arguments
 770              -> TcM s ([TcType],        -- Function argument types
 771                        TcType)  -- Function result types
 772
 773 split_fun_ty fun_ty 0
 774   = returnTc ([], fun_ty)
 775
 776 split_fun_ty fun_ty n
 777   =     -- Expect the function to have type A->B
 778     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 779     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 780     returnTc (arg_ty:arg_tys, final_res_ty)
 781 \end{code}
 782
 783 \begin{code}
 784 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 785       -> (RenamedHsExpr, TcType, Int)   -- Actual argument and expected arg type
 786       -> TcM s (TcExpr, LIE)    -- Resulting argument and LIE
 787
 788 tcArg the_fun (arg, expected_arg_ty, arg_no)
 789   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 790     tcExpr arg expected_arg_ty
 791 \end{code}
 792
 793
 794 %************************************************************************
 795 %*                                                                      *
 796 \subsection{@tcId@ typchecks an identifier occurrence}
 797 %*                                                                      *
 798 %************************************************************************
 799
 800 Between the renamer and the first invocation of the UsageSP inference,
 801 identifiers read from interface files will have usage information in
 802 their types, whereas other identifiers will not.  The unannotTy here
 803 in @tcId@ prevents this information from pointlessly propagating
 804 further prior to the first usage inference.
 805
 806 \begin{code}
 807 tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
 808
 809 tcId name
 810   =     -- Look up the Id and instantiate its type
 811     tcLookupValueMaybe name     `thenNF_Tc` \ maybe_local ->
 812
 813     case maybe_local of
 814       Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
 815
 816       Nothing ->    tcLookupValue name          `thenNF_Tc` \ id ->
 817                     tcInstId id                 `thenNF_Tc` \ (tyvars, theta, tau) ->
 818                     instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
 819
 820   where
 821         -- The instantiate_it loop runs round instantiating the Id.
 822         -- It has to be a loop because we are now prepared to entertain
 823         -- types like
 824         --              f:: forall a. Eq a => forall b. Baz b => tau
 825         -- We want to instantiate this to
 826         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 827     instantiate_it orig fun ty
 828       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 829         tcSplitRhoTy rho        `thenNF_Tc` \ (theta, tau) ->
 830         instantiate_it2 orig fun tyvars theta tau
 831
 832     instantiate_it2 orig fun tyvars theta tau
 833       = if null theta then      -- Is it overloaded?
 834                 returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
 835         else
 836                 -- Yes, it's overloaded
 837         instOverloadedFun orig fun arg_tys theta tau    `thenNF_Tc` \ (fun', lie1) ->
 838         instantiate_it orig fun' tau                    `thenNF_Tc` \ (expr, lie2, final_tau) ->
 839         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 840
 841       where
 842         arg_tys = mkTyVarTys tyvars
 843 \end{code}
 844
 845 %************************************************************************
 846 %*                                                                      *
 847 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 848 %*                                                                      *
 849 %************************************************************************
 850
 851 \begin{code}
 852 tcDoStmts do_or_lc stmts src_loc res_ty
 853   =     -- get the Monad and MonadZero classes
 854         -- create type consisting of a fresh monad tyvar
 855     ASSERT( not (null stmts) )
 856     tcAddSrcLoc src_loc $
 857
 858     newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind)        `thenNF_Tc` \ m ->
 859     newTyVarTy boxedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 860     unifyTauTy res_ty (mkAppTy m elt_ty)                        `thenTc_`
 861
 862         -- If it's a comprehension we're dealing with,
 863         -- force it to be a list comprehension.
 864         -- (as of Haskell 98, monad comprehensions are no more.)
 865     (case do_or_lc of
 866        ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
 867        _        -> returnTc ())                                 `thenTc_`
 868
 869     tcStmts do_or_lc (mkAppTy m) stmts elt_ty   `thenTc`   \ (stmts', stmts_lie) ->
 870
 871         -- Build the then and zero methods in case we need them
 872         -- It's important that "then" and "return" appear just once in the final LIE,
 873         -- not only for typechecker efficiency, but also because otherwise during
 874         -- simplification we end up with silly stuff like
 875         --      then = case d of (t,r) -> t
 876         --      then = then
 877         -- where the second "then" sees that it already exists in the "available" stuff.
 878         --
 879     tcLookupValueByKey returnMClassOpKey        `thenNF_Tc` \ return_sel_id ->
 880     tcLookupValueByKey thenMClassOpKey          `thenNF_Tc` \ then_sel_id ->
 881     tcLookupValueByKey failMClassOpKey          `thenNF_Tc` \ fail_sel_id ->
 882     newMethod DoOrigin return_sel_id [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 883     newMethod DoOrigin then_sel_id [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 884     newMethod DoOrigin fail_sel_id [m]          `thenNF_Tc` \ (fail_lie, fail_id) ->
 885     let
 886       monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
 887     in
 888     returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
 889               stmts_lie `plusLIE` monad_lie)
 890 \end{code}
 891
 892
 893 %************************************************************************
 894 %*                                                                      *
 895 \subsection{Record bindings}
 896 %*                                                                      *
 897 %************************************************************************
 898
 899 Game plan for record bindings
 900 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 901 For each binding
 902         field = value
 903 1. look up "field", to find its selector Id, which must have type
 904         forall a1..an. T a1 .. an -> tau
 905    where tau is the type of the field.
 906
 907 2. Instantiate this type
 908
 909 3. Unify the (T a1 .. an) part with the "expected result type", which
 910    is passed in.  This checks that all the field labels come from the
 911    same type.
 912
 913 4. Type check the value using tcArg, passing tau as the expected
 914    argument type.
 915
 916 This extends OK when the field types are universally quantified.
 917
 918 Actually, to save excessive creation of fresh type variables,
 919 we
 920
 921 \begin{code}
 922 tcRecordBinds
 923         :: TcType               -- Expected type of whole record
 924         -> RenamedRecordBinds
 925         -> TcM s (TcRecordBinds, LIE)
 926
 927 tcRecordBinds expected_record_ty rbinds
 928   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 929     returnTc (rbinds', plusLIEs lies)
 930   where
 931     do_bind (field_label, rhs, pun_flag)
 932       = tcLookupValue field_label       `thenNF_Tc` \ sel_id ->
 933         ASSERT( isRecordSelector sel_id )
 934                 -- This lookup and assertion will surely succeed, because
 935                 -- we check that the fields are indeed record selectors
 936                 -- before calling tcRecordBinds
 937
 938         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 939
 940                 -- Record selectors all have type
 941                 --      forall a1..an.  T a1 .. an -> tau
 942         ASSERT( maybeToBool (splitFunTy_maybe tau) )
 943         let
 944                 -- Selector must have type RecordType -> FieldType
 945           Just (record_ty, field_ty) = splitFunTy_maybe tau
 946         in
 947         unifyTauTy expected_record_ty record_ty         `thenTc_`
 948         tcPolyExpr rhs field_ty                         `thenTc` \ (rhs', lie, _, _, _) ->
 949         returnTc ((sel_id, rhs', pun_flag), lie)
 950
 951 badFields rbinds data_con
 952   = [field_name | (field_name, _, _) <- rbinds,
 953                   not (field_name `elem` field_names)
 954     ]
 955   where
 956     field_names = map fieldLabelName (dataConFieldLabels data_con)
 957 \end{code}
 958
 959 %************************************************************************
 960 %*                                                                      *
 961 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 962 %*                                                                      *
 963 %************************************************************************
 964
 965 \begin{code}
 966 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
 967
 968 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 969 tcMonoExprs (expr:exprs) (ty:tys)
 970  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 971    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 972    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 973 \end{code}
 974
 975
 976 % =================================================
 977
 978 Errors and contexts
 979 ~~~~~~~~~~~~~~~~~~~
 980
 981 Mini-utils:
 982 \begin{code}
 983 pp_nest_hang :: String -> SDoc -> SDoc
 984 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
 985 \end{code}
 986
 987 Boring and alphabetical:
 988 \begin{code}
 989 arithSeqCtxt expr
 990   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 991
 992 caseCtxt expr
 993   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 994
 995 caseScrutCtxt expr
 996   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 997
 998 exprSigCtxt expr
 999   = hang (ptext SLIT("In an expression with a type signature:"))
1000          4 (ppr expr)
1001
1002 listCtxt expr
1003   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1004
1005 predCtxt expr
1006   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1007
1008 sectionRAppCtxt expr
1009   = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1010
1011 sectionLAppCtxt expr
1012   = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1013
1014 funAppCtxt fun arg arg_no
1015   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1016                     quotes (ppr fun) <> text ", namely"])
1017          4 (quotes (ppr arg))
1018
1019 wrongArgsCtxt too_many_or_few fun args
1020   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1021                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1022                     <+> ptext SLIT("arguments in the call"))
1023          4 (parens (ppr the_app))
1024   where
1025     the_app = foldl HsApp fun args      -- Used in error messages
1026
1027 appCtxt fun args
1028   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1029   where
1030     the_app = foldl HsApp fun args      -- Used in error messages
1031
1032 lurkingRank2Err fun fun_ty
1033   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1034          4 (vcat [ptext SLIT("It is applied to too few arguments"),
1035                   ptext SLIT("so that the result type has for-alls in it")])
1036
1037 rank2ArgCtxt arg expected_arg_ty
1038   = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1039
1040 badFieldsUpd rbinds
1041   = hang (ptext SLIT("No constructor has all these fields:"))
1042          4 (pprQuotedList fields)
1043   where
1044     fields = [field | (field, _, _) <- rbinds]
1045
1046 recordUpdCtxt = ptext SLIT("In a record update construct")
1047
1048 notSelector field
1049   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1050
1051 illegalCcallTyErr isArg ty
1052   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
1053          4 (hsep [ppr ty])
1054   where
1055    arg_or_res
1056     | isArg     = ptext SLIT("argument")
1057     | otherwise = ptext SLIT("result")
1058
1059
1060 \end{code}