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