ghc/compiler/typecheck/TcExpr.lhs

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