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