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