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 ( tcExpr, tcPolyExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           HsBinds(..), Stmt(..), StmtCtxt(..),
  13                           failureFreePat
  14                         )
  15 import RnHsSyn          ( RenamedHsExpr, RenamedRecordBinds )
  16 import TcHsSyn          ( TcExpr, TcRecordBinds,
  17                           mkHsTyApp
  18                         )
  19
  20 import TcMonad
  21 import BasicTypes       ( RecFlag(..) )
  22
  23 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  24                           LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
  25                           newMethod, newMethodWithGivenTy, newDicts, instToId )
  26 import TcBinds          ( tcBindsAndThen )
  27 import TcEnv            ( tcInstId,
  28                           tcLookupValue, tcLookupClassByKey,
  29                           tcLookupValueByKey,
  30                           tcExtendGlobalTyVars, tcLookupValueMaybe,
  31                           tcLookupTyCon, tcLookupDataCon
  32                         )
  33 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  34 import TcMonoType       ( tcHsType, checkSigTyVars, sigCtxt )
  35 import TcPat            ( badFieldCon )
  36 import TcSimplify       ( tcSimplifyAndCheck )
  37 import TcType           ( TcType, TcTauType,
  38                           tcInstTyVars,
  39                           tcInstTcType, tcSplitRhoTy,
  40                           newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
  41
  42 import Class            ( Class )
  43 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType )
  44 import Id               ( idType, recordSelectorFieldLabel,
  45                           isRecordSelector,
  46                           Id
  47                         )
  48 import DataCon          ( dataConFieldLabels, dataConSig, dataConId )
  49 import Name             ( Name )
  50 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
  51                           splitFunTy_maybe, splitFunTys,
  52                           mkTyConApp,
  53                           splitForAllTys, splitRhoTy,
  54                           isTauTy, tyVarsOfType, tyVarsOfTypes,
  55                           isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
  56                           boxedTypeKind, mkArrowKind,
  57                           substTopTheta, tidyOpenType
  58                         )
  59 import VarEnv           ( zipVarEnv )
  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, zeroClassOpKey, 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                           HsLet (MonoBind inst_binds [] Recursive)
 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     mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..(length args)]    `thenNF_Tc` \ arg_tys ->
 352     tcMonoExprs args arg_tys                                    `thenTc`    \ (args', args_lie) ->
 353
 354         -- The argument types can be unboxed or boxed; the result
 355         -- type must, however, be boxed since it's an argument to the IO
 356         -- type constructor.
 357     newTyVarTy boxedTypeKind            `thenNF_Tc` \ result_ty ->
 358     let
 359         io_result_ty = mkTyConApp ioTyCon [result_ty]
 360         [ioDataCon]  = tyConDataCons ioTyCon
 361     in
 362     unifyTauTy res_ty io_result_ty              `thenTc_`
 363
 364         -- Construct the extra insts, which encode the
 365         -- constraints on the argument and result types.
 366     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 367     newDicts result_origin [(cReturnableClass, [result_ty])]            `thenNF_Tc` \ (ccres_dict, _) ->
 368
 369     returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
 370                     (CCall lbl args' may_gc is_asm result_ty),
 371                       -- do the wrapping in the newtype constructor here
 372               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 373 \end{code}
 374
 375 \begin{code}
 376 tcMonoExpr (HsSCC label expr) res_ty
 377   = tcMonoExpr expr res_ty              `thenTc` \ (expr', lie) ->
 378     returnTc (HsSCC label expr', lie)
 379
 380 tcMonoExpr (HsLet binds expr) res_ty
 381   = tcBindsAndThen
 382         combiner
 383         binds                   -- Bindings to check
 384         tc_expr         `thenTc` \ (expr', lie) ->
 385     returnTc (expr', lie)
 386   where
 387     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
 388               returnTc (expr', lie)
 389     combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
 390
 391 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
 392   = tcAddSrcLoc src_loc                 $
 393     tcAddErrCtxt (caseCtxt in_expr)     $
 394
 395         -- Typecheck the case alternatives first.
 396         -- The case patterns tend to give good type info to use
 397         -- when typechecking the scrutinee.  For example
 398         --      case (map f) of
 399         --        (x:xs) -> ...
 400         -- will report that map is applied to too few arguments
 401         --
 402         -- Not only that, but it's better to check the matches on their
 403         -- own, so that we get the expected results for scoped type variables.
 404         --      f x = case x of
 405         --              (p::a, q::b) -> (q,p)
 406         -- The above should work: the match (p,q) -> (q,p) is polymorphic as
 407         -- claimed by the pattern signatures.  But if we typechecked the
 408         -- match with x in scope and x's type as the expected type, we'd be hosed.
 409
 410     tcMatchesCase matches res_ty        `thenTc`    \ (scrut_ty, matches', lie2) ->
 411
 412     tcAddErrCtxt (caseScrutCtxt scrut)  (
 413       tcMonoExpr scrut scrut_ty
 414     )                                   `thenTc`    \ (scrut',lie1) ->
 415
 416     returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 417
 418 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 419   = tcAddSrcLoc src_loc $
 420     tcAddErrCtxt (predCtxt pred) (
 421     tcMonoExpr pred boolTy      )       `thenTc`    \ (pred',lie1) ->
 422
 423     tcMonoExpr b1 res_ty                `thenTc`    \ (b1',lie2) ->
 424     tcMonoExpr b2 res_ty                `thenTc`    \ (b2',lie3) ->
 425     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
 426 \end{code}
 427
 428 \begin{code}
 429 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
 430   = tcDoStmts do_or_lc stmts src_loc res_ty
 431 \end{code}
 432
 433 \begin{code}
 434 tcMonoExpr in_expr@(ExplicitList exprs) res_ty  -- Non-empty list
 435   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 436     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 437     returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
 438   where
 439     tc_elt elt_ty expr
 440       = tcAddErrCtxt (listCtxt expr) $
 441         tcMonoExpr expr elt_ty
 442
 443 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
 444   = (if boxed
 445         then unifyTupleTy (length exprs) res_ty
 446         else unifyUnboxedTupleTy (length exprs) res_ty
 447                                                 ) `thenTc` \ arg_tys ->
 448     mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
 449                (exprs `zip` arg_tys) -- we know they're of equal length.
 450                                                 `thenTc` \ (exprs', lies) ->
 451     returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
 452
 453 tcMonoExpr (RecordCon con_name rbinds) res_ty
 454   = tcId con_name                       `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 455     let
 456         (_, record_ty) = splitFunTys con_tau
 457     in
 458         -- Con is syntactically constrained to be a data constructor
 459     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
 460     unifyTauTy res_ty record_ty          `thenTc_`
 461
 462         -- Check that the record bindings match the constructor
 463     tcLookupDataCon con_name    `thenTc` \ (data_con, _, _) ->
 464     let
 465         bad_fields = badFields rbinds data_con
 466     in
 467     mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields       `thenNF_Tc_`
 468
 469         -- Typecheck the record bindings
 470         -- (Do this after checkRecordFields in case there's a field that
 471         --  doesn't match the constructor.)
 472     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 473
 474     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 475
 476
 477 -- The main complication with RecordUpd is that we need to explicitly
 478 -- handle the *non-updated* fields.  Consider:
 479 --
 480 --      data T a b = MkT1 { fa :: a, fb :: b }
 481 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 482 --                 | MkT3 { fd :: a }
 483 --
 484 --      upd :: T a b -> c -> T a c
 485 --      upd t x = t { fb = x}
 486 --
 487 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 488 -- because upd should be equivalent to:
 489 --
 490 --      upd t x = case t of
 491 --                      MkT1 p q -> MkT1 p x
 492 --                      MkT2 a b -> MkT2 p b
 493 --                      MkT3 d   -> error ...
 494 --
 495 -- So we need to give a completely fresh type to the result record,
 496 -- and then constrain it by the fields that are *not* updated ("p" above).
 497 --
 498 -- Note that because MkT3 doesn't contain all the fields being updated,
 499 -- its RHS is simply an error, so it doesn't impose any type constraints
 500 --
 501 -- All this is done in STEP 4 below.
 502
 503 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
 504   = tcAddErrCtxt recordUpdCtxt                  $
 505
 506         -- STEP 1
 507         -- Figure out the tycon and data cons from the first field name
 508     ASSERT( not (null rbinds) )
 509     let
 510         ((first_field_name, _, _) : rest) = rbinds
 511     in
 512     tcLookupValueMaybe first_field_name         `thenNF_Tc` \ maybe_sel_id ->
 513     (case maybe_sel_id of
 514         Just sel_id | isRecordSelector sel_id -> returnTc sel_id
 515         other                                 -> failWithTc (notSelector first_field_name)
 516     )                                           `thenTc` \ sel_id ->
 517     let
 518         (_, tau)                  = splitForAllTys (idType sel_id)
 519         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 520         (tycon, _, data_cons)     = splitAlgTyConApp data_ty
 521         (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 522     in
 523     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 524
 525         -- STEP 2
 526         -- Check for bad fields
 527     checkTc (any (null . badFields rbinds) data_cons)
 528             (badFieldsUpd rbinds)               `thenTc_`
 529         -- STEP 3
 530         -- Typecheck the update bindings.
 531         -- (Do this after checking for bad fields in case there's a field that
 532         --  doesn't match the constructor.)
 533     let
 534         result_record_ty = mkTyConApp tycon result_inst_tys
 535     in
 536     unifyTauTy res_ty result_record_ty          `thenTc_`
 537     tcRecordBinds result_record_ty rbinds       `thenTc` \ (rbinds', rbinds_lie) ->
 538
 539         -- STEP 4
 540         -- Use the un-updated fields to find a vector of booleans saying
 541         -- which type arguments must be the same in updatee and result.
 542         --
 543         -- WARNING: this code assumes that all data_cons in a common tycon
 544         -- have FieldLabels abstracted over the same tyvars.
 545     let
 546         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 547         con_field_lbls_s    = map dataConFieldLabels data_cons
 548
 549                 -- A constructor is only relevant to this process if
 550                 -- it contains all the fields that are being updated
 551         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 552         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 553
 554         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 555         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 556
 557         mk_inst_ty (tyvar, result_inst_ty)
 558           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 559           | otherwise                               = newTyVarTy boxedTypeKind  -- Fresh type
 560     in
 561     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 562
 563         -- STEP 5
 564         -- Typecheck the expression to be updated
 565     let
 566         record_ty = mkTyConApp tycon inst_tys
 567     in
 568     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 569
 570         -- STEP 6
 571         -- Figure out the LIE we need.  We have to generate some
 572         -- dictionaries for the data type context, since we are going to
 573         -- do some construction.
 574         --
 575         -- What dictionaries do we need?  For the moment we assume that all
 576         -- data constructors have the same context, and grab it from the first
 577         -- constructor.  If they have varying contexts then we'd have to
 578         -- union the ones that could participate in the update.
 579     let
 580         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 581         inst_env = zipVarEnv tyvars result_inst_tys
 582         theta'   = substTopTheta inst_env theta
 583     in
 584     newDicts RecordUpdOrigin theta'             `thenNF_Tc` \ (con_lie, dicts) ->
 585
 586         -- Phew!
 587     returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
 588               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
 589
 590 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 591   = unifyListTy res_ty                          `thenTc` \ elt_ty ->
 592     tcMonoExpr expr elt_ty                      `thenTc` \ (expr', lie1) ->
 593
 594     tcLookupValueByKey enumFromClassOpKey       `thenNF_Tc` \ sel_id ->
 595     newMethod (ArithSeqOrigin seq)
 596               sel_id [elt_ty]                   `thenNF_Tc` \ (lie2, enum_from_id) ->
 597
 598     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 599               lie1 `plusLIE` lie2)
 600
 601 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 602   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 603     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 604     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 605     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 606     tcLookupValueByKey enumFromThenClassOpKey           `thenNF_Tc` \ sel_id ->
 607     newMethod (ArithSeqOrigin seq)
 608               sel_id [elt_ty]                           `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 609
 610     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 611                            (FromThen expr1' expr2'),
 612               lie1 `plusLIE` lie2 `plusLIE` lie3)
 613
 614 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 615   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 616     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 617     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 618     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 619     tcLookupValueByKey enumFromToClassOpKey     `thenNF_Tc` \ sel_id ->
 620     newMethod (ArithSeqOrigin seq)
 621               sel_id [elt_ty]                           `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 622
 623     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 624                           (FromTo expr1' expr2'),
 625               lie1 `plusLIE` lie2 `plusLIE` lie3)
 626
 627 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 628   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 629     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 630     tcMonoExpr expr1 elt_ty     `thenTc`    \ (expr1',lie1) ->
 631     tcMonoExpr expr2 elt_ty     `thenTc`    \ (expr2',lie2) ->
 632     tcMonoExpr expr3 elt_ty     `thenTc`    \ (expr3',lie3) ->
 633     tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
 634     newMethod (ArithSeqOrigin seq)
 635               sel_id [elt_ty]                           `thenNF_Tc` \ (lie4, eft_id) ->
 636
 637     returnTc (ArithSeqOut (HsVar eft_id)
 638                            (FromThenTo expr1' expr2' expr3'),
 639               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
 640 \end{code}
 641
 642 %************************************************************************
 643 %*                                                                      *
 644 \subsection{Expressions type signatures}
 645 %*                                                                      *
 646 %************************************************************************
 647
 648 \begin{code}
 649 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 650  = tcSetErrCtxt (exprSigCtxt in_expr)   $
 651    tcHsType  poly_ty            `thenTc` \ sig_tc_ty ->
 652
 653    if not (isForAllTy sig_tc_ty) then
 654         -- Easy case
 655         unifyTauTy sig_tc_ty res_ty     `thenTc_`
 656         tcMonoExpr expr sig_tc_ty
 657
 658    else -- Signature is polymorphic
 659         tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 660
 661             -- Now match the signature type with res_ty.
 662             -- We must not do this earlier, because res_ty might well
 663             -- mention variables free in the environment, and we'd get
 664             -- bogus complaints about not being able to for-all the
 665             -- sig_tyvars
 666         unifyTauTy res_ty expr_ty                       `thenTc_`
 667
 668             -- If everything is ok, return the stuff unchanged, except for
 669             -- the effect of any substutions etc.  We simply discard the
 670             -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
 671             -- resolution it may have done, which is recorded in the
 672             -- substitution.
 673         returnTc (expr, lie)
 674 \end{code}
 675
 676 Typecheck expression which in most cases will be an Id.
 677
 678 \begin{code}
 679 tcExpr_id :: RenamedHsExpr
 680            -> TcM s (TcExpr,
 681                      LIE,
 682                      TcType)
 683 tcExpr_id id_expr
 684  = case id_expr of
 685         HsVar name -> tcId name                 `thenNF_Tc` \ stuff ->
 686                       returnTc stuff
 687         other      -> newTyVarTy_OpenKind       `thenNF_Tc` \ id_ty ->
 688                       tcMonoExpr id_expr id_ty  `thenTc`    \ (id_expr', lie_id) ->
 689                       returnTc (id_expr', lie_id, id_ty)
 690 \end{code}
 691
 692 %************************************************************************
 693 %*                                                                      *
 694 \subsection{@tcApp@ typchecks an application}
 695 %*                                                                      *
 696 %************************************************************************
 697
 698 \begin{code}
 699
 700 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 701       -> TcType                     -- Expected result type of application
 702       -> TcM s (TcExpr, [TcExpr],           -- Translated fun and args
 703                 LIE)
 704
 705 tcApp fun args res_ty
 706   =     -- First type-check the function
 707     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 708
 709     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 710         split_fun_ty fun_ty (length args)
 711     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 712
 713         -- Unify with expected result before type-checking the args
 714         -- This is when we might detect a too-few args situation
 715     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 716        unifyTauTy res_ty actual_result_ty
 717     )                                                   `thenTc_`
 718
 719         -- Now typecheck the args
 720     mapAndUnzipTc (tcArg fun)
 721           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 722
 723     -- Check that the result type doesn't have any nested for-alls.
 724     -- For example, a "build" on its own is no good; it must be applied to something.
 725     checkTc (isTauTy actual_result_ty)
 726             (lurkingRank2Err fun fun_ty)        `thenTc_`
 727
 728     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 729
 730
 731 -- If an error happens we try to figure out whether the
 732 -- function has been given too many or too few arguments,
 733 -- and say so
 734 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 735   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 736     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 737     let
 738       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 739       (env2, act_ty'') = tidyOpenType env1     act_ty'
 740       (exp_args, _) = splitFunTys exp_ty''
 741       (act_args, _) = splitFunTys act_ty''
 742
 743       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 744               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 745               | otherwise                         = appCtxt fun args
 746     in
 747     returnNF_Tc (env2, message)
 748
 749
 750 split_fun_ty :: TcType          -- The type of the function
 751              -> Int                     -- Number of arguments
 752              -> TcM s ([TcType],        -- Function argument types
 753                        TcType)  -- Function result types
 754
 755 split_fun_ty fun_ty 0
 756   = returnTc ([], fun_ty)
 757
 758 split_fun_ty fun_ty n
 759   =     -- Expect the function to have type A->B
 760     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 761     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 762     returnTc (arg_ty:arg_tys, final_res_ty)
 763 \end{code}
 764
 765 \begin{code}
 766 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 767       -> (RenamedHsExpr, TcType, Int)   -- Actual argument and expected arg type
 768       -> TcM s (TcExpr, LIE)    -- Resulting argument and LIE
 769
 770 tcArg the_fun (arg, expected_arg_ty, arg_no)
 771   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 772     tcExpr arg expected_arg_ty
 773 \end{code}
 774
 775
 776 %************************************************************************
 777 %*                                                                      *
 778 \subsection{@tcId@ typchecks an identifier occurrence}
 779 %*                                                                      *
 780 %************************************************************************
 781
 782 \begin{code}
 783 tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
 784
 785 tcId name
 786   =     -- Look up the Id and instantiate its type
 787     tcLookupValueMaybe name     `thenNF_Tc` \ maybe_local ->
 788
 789     case maybe_local of
 790       Just tc_id -> instantiate_it tc_id (idType tc_id)
 791
 792       Nothing ->    tcLookupValue name          `thenNF_Tc` \ id ->
 793                     tcInstId id                 `thenNF_Tc` \ (tyvars, theta, tau) ->
 794                     instantiate_it2 id tyvars theta tau
 795
 796   where
 797         -- The instantiate_it loop runs round instantiating the Id.
 798         -- It has to be a loop because we are now prepared to entertain
 799         -- types like
 800         --              f:: forall a. Eq a => forall b. Baz b => tau
 801         -- We want to instantiate this to
 802         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 803     instantiate_it tc_id_occ ty
 804       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 805         tcSplitRhoTy rho        `thenNF_Tc` \ (theta, tau) ->
 806         instantiate_it2 tc_id_occ tyvars theta tau
 807
 808     instantiate_it2 tc_id_occ tyvars theta tau
 809       = if null theta then      -- Is it overloaded?
 810                 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 811         else
 812                 -- Yes, it's overloaded
 813         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 814                              tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
 815         instantiate_it (instToId inst) tau               `thenNF_Tc` \ (expr, lie2, final_tau) ->
 816         returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
 817
 818       where
 819         arg_tys       = mkTyVarTys tyvars
 820 \end{code}
 821
 822 %************************************************************************
 823 %*                                                                      *
 824 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 825 %*                                                                      *
 826 %************************************************************************
 827
 828 \begin{code}
 829 tcDoStmts do_or_lc stmts src_loc res_ty
 830   =     -- get the Monad and MonadZero classes
 831         -- create type consisting of a fresh monad tyvar
 832     ASSERT( not (null stmts) )
 833     tcAddSrcLoc src_loc $
 834
 835     newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind)        `thenNF_Tc` \ m ->
 836     newTyVarTy boxedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 837     unifyTauTy res_ty (mkAppTy m elt_ty)                        `thenTc_`
 838
 839     tcStmts do_or_lc (mkAppTy m) stmts elt_ty                   `thenTc`   \ (stmts', stmts_lie) ->
 840
 841         -- Build the then and zero methods in case we need them
 842         -- It's important that "then" and "return" appear just once in the final LIE,
 843         -- not only for typechecker efficiency, but also because otherwise during
 844         -- simplification we end up with silly stuff like
 845         --      then = case d of (t,r) -> t
 846         --      then = then
 847         -- where the second "then" sees that it already exists in the "available" stuff.
 848         --
 849     tcLookupValueByKey returnMClassOpKey        `thenNF_Tc` \ return_sel_id ->
 850     tcLookupValueByKey thenMClassOpKey          `thenNF_Tc` \ then_sel_id ->
 851     tcLookupValueByKey zeroClassOpKey           `thenNF_Tc` \ zero_sel_id ->
 852     newMethod DoOrigin return_sel_id [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 853     newMethod DoOrigin then_sel_id [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 854     newMethod DoOrigin zero_sel_id [m]          `thenNF_Tc` \ (zero_lie, zero_id) ->
 855     let
 856       monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
 857       perhaps_zero_lie | all failure_free stmts' = emptyLIE
 858                        | otherwise               = zero_lie
 859
 860       failure_free (BindStmt pat _ _) = failureFreePat pat
 861       failure_free (GuardStmt _ _)    = False
 862       failure_free other_stmt         = True
 863     in
 864     returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
 865               stmts_lie `plusLIE` monad_lie)
 866 \end{code}
 867
 868
 869 %************************************************************************
 870 %*                                                                      *
 871 \subsection{Record bindings}
 872 %*                                                                      *
 873 %************************************************************************
 874
 875 Game plan for record bindings
 876 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 877 For each binding
 878         field = value
 879 1. look up "field", to find its selector Id, which must have type
 880         forall a1..an. T a1 .. an -> tau
 881    where tau is the type of the field.
 882
 883 2. Instantiate this type
 884
 885 3. Unify the (T a1 .. an) part with the "expected result type", which
 886    is passed in.  This checks that all the field labels come from the
 887    same type.
 888
 889 4. Type check the value using tcArg, passing tau as the expected
 890    argument type.
 891
 892 This extends OK when the field types are universally quantified.
 893
 894 Actually, to save excessive creation of fresh type variables,
 895 we
 896
 897 \begin{code}
 898 tcRecordBinds
 899         :: TcType               -- Expected type of whole record
 900         -> RenamedRecordBinds
 901         -> TcM s (TcRecordBinds, LIE)
 902
 903 tcRecordBinds expected_record_ty rbinds
 904   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 905     returnTc (rbinds', plusLIEs lies)
 906   where
 907     do_bind (field_label, rhs, pun_flag)
 908       = tcLookupValue field_label       `thenNF_Tc` \ sel_id ->
 909         ASSERT( isRecordSelector sel_id )
 910                 -- This lookup and assertion will surely succeed, because
 911                 -- we check that the fields are indeed record selectors
 912                 -- before calling tcRecordBinds
 913
 914         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 915
 916                 -- Record selectors all have type
 917                 --      forall a1..an.  T a1 .. an -> tau
 918         ASSERT( maybeToBool (splitFunTy_maybe tau) )
 919         let
 920                 -- Selector must have type RecordType -> FieldType
 921           Just (record_ty, field_ty) = splitFunTy_maybe tau
 922         in
 923         unifyTauTy expected_record_ty record_ty         `thenTc_`
 924         tcPolyExpr rhs field_ty                         `thenTc` \ (rhs', lie, _, _, _) ->
 925         returnTc ((sel_id, rhs', pun_flag), lie)
 926
 927 badFields rbinds data_con
 928   = [field_name | (field_name, _, _) <- rbinds,
 929                   not (field_name `elem` field_names)
 930     ]
 931   where
 932     field_names = map fieldLabelName (dataConFieldLabels data_con)
 933 \end{code}
 934
 935 %************************************************************************
 936 %*                                                                      *
 937 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 938 %*                                                                      *
 939 %************************************************************************
 940
 941 \begin{code}
 942 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
 943
 944 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 945 tcMonoExprs (expr:exprs) (ty:tys)
 946  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 947    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 948    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 949 \end{code}
 950
 951
 952 % =================================================
 953
 954 Errors and contexts
 955 ~~~~~~~~~~~~~~~~~~~
 956
 957 Mini-utils:
 958 \begin{code}
 959 pp_nest_hang :: String -> SDoc -> SDoc
 960 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
 961 \end{code}
 962
 963 Boring and alphabetical:
 964 \begin{code}
 965 arithSeqCtxt expr
 966   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 967
 968 caseCtxt expr
 969   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 970
 971 caseScrutCtxt expr
 972   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 973
 974 exprSigCtxt expr
 975   = hang (ptext SLIT("In an expression with a type signature:"))
 976          4 (ppr expr)
 977
 978 listCtxt expr
 979   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
 980
 981 predCtxt expr
 982   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 983
 984 sectionRAppCtxt expr
 985   = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
 986
 987 sectionLAppCtxt expr
 988   = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
 989
 990 funAppCtxt fun arg arg_no
 991   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
 992                     quotes (ppr fun) <> text ", namely"])
 993          4 (quotes (ppr arg))
 994
 995 wrongArgsCtxt too_many_or_few fun args
 996   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
 997                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
 998                     <+> ptext SLIT("arguments in the call"))
 999          4 (parens (ppr the_app))
1000   where
1001     the_app = foldl HsApp fun args      -- Used in error messages
1002
1003 appCtxt fun args
1004   = ptext SLIT("In the application") <+> (ppr the_app)
1005   where
1006     the_app = foldl HsApp fun args      -- Used in error messages
1007
1008 lurkingRank2Err fun fun_ty
1009   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1010          4 (vcat [ptext SLIT("It is applied to too few arguments"),
1011                   ptext SLIT("so that the result type has for-alls in it")])
1012
1013 rank2ArgCtxt arg expected_arg_ty
1014   = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1015
1016 badFieldsUpd rbinds
1017   = hang (ptext SLIT("No constructor has all these fields:"))
1018          4 (pprQuotedList fields)
1019   where
1020     fields = [field | (field, _, _) <- rbinds]
1021
1022 recordUpdCtxt = ptext SLIT("In a record update construct")
1023
1024 notSelector field
1025   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1026 \end{code}