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