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