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, tcMonoExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           HsMatchContext(..), HsDoContext(..), mkMonoBind
  13                         )
  14 import RnHsSyn          ( RenamedHsExpr, RenamedRecordBinds )
  15 import TcHsSyn          ( TcExpr, TcRecordBinds, simpleHsLitTy  )
  16
  17 import TcMonad
  18 import TcUnify          ( tcSub, tcGen, (<$>),
  19                           unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
  20                           unifyTupleTy )
  21 import BasicTypes       ( RecFlag(..),  isMarkedStrict )
  22 import Inst             ( InstOrigin(..),
  23                           LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
  24                           newOverloadedLit, newMethod, newIPDict,
  25                           newDicts,
  26                           instToId, tcInstId
  27                         )
  28 import TcBinds          ( tcBindsAndThen )
  29 import TcEnv            ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
  30                           tcLookupTyCon, tcLookupDataCon, tcLookupId
  31                         )
  32 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  33 import TcMonoType       ( tcHsSigType, UserTypeCtxt(..) )
  34 import TcPat            ( badFieldCon )
  35 import TcSimplify       ( tcSimplifyIPs )
  36 import TcMType          ( tcInstTyVars, newTyVarTy, newTyVarTys, zonkTcType )
  37 import TcType           ( TcType, TcSigmaType, TcPhiType,
  38                           tcSplitFunTys, tcSplitTyConApp,
  39                           isSigmaTy, mkFunTy, mkAppTy, mkTyConTy,
  40                           mkTyConApp, mkClassPred, tcFunArgTy,
  41                           tyVarsOfTypes,
  42                           liftedTypeKind, openTypeKind, mkArrowKind,
  43                           tcSplitSigmaTy, tcTyConAppTyCon,
  44                           tidyOpenType
  45                         )
  46 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
  47 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  48 import DataCon          ( dataConFieldLabels, dataConSig,
  49                           dataConStrictMarks
  50                         )
  51 import Name             ( Name )
  52 import TyCon            ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons )
  53 import Subst            ( mkTopTyVarSubst, substTheta, substTy )
  54 import VarSet           ( elemVarSet )
  55 import TysWiredIn       ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
  56 import PrelNames        ( cCallableClassName,
  57                           cReturnableClassName,
  58                           enumFromName, enumFromThenName,
  59                           enumFromToName, enumFromThenToName,
  60                           enumFromToPName, enumFromThenToPName,
  61                           thenMName, failMName, returnMName, ioTyConName
  62                         )
  63 import Outputable
  64 import ListSetOps       ( minusList )
  65 import Util
  66 import CmdLineOpts
  67 import HscTypes         ( TyThing(..) )
  68
  69 \end{code}
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection{Main wrappers}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 \begin{code}
  78 tcExpr :: RenamedHsExpr         -- Expession to type check
  79         -> TcSigmaType          -- Expected type (could be a polytpye)
  80         -> TcM (TcExpr, LIE)    -- Generalised expr with expected type, and LIE
  81
  82 tcExpr expr expected_ty
  83   | not (isSigmaTy expected_ty)  -- Monomorphic case
  84   = tcMonoExpr expr expected_ty
  85
  86   | otherwise
  87   = tcGen expected_ty (tcMonoExpr expr)         `thenTc` \ (gen_fn, expr', lie) ->
  88     returnTc (gen_fn <$> expr', lie)
  89 \end{code}
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{The TAUT rules for variables}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 tcMonoExpr :: RenamedHsExpr             -- Expession to type check
 100            -> TcPhiType                 -- Expected type (could be a type variable)
 101                                         -- Definitely no foralls at the top
 102                                         -- Can be a 'hole'.
 103            -> TcM (TcExpr, LIE)
 104
 105 tcMonoExpr (HsVar name) res_ty
 106   = tcId name                   `thenNF_Tc` \ (expr', lie1, id_ty) ->
 107     tcSub res_ty id_ty          `thenTc` \ (co_fn, lie2) ->
 108     returnTc (co_fn <$> expr', lie1 `plusLIE` lie2)
 109
 110 tcMonoExpr (HsIPVar ip) res_ty
 111   =     -- Implicit parameters must have a *tau-type* not a
 112         -- type scheme.  We enforce this by creating a fresh
 113         -- type variable as its type.  (Because res_ty may not
 114         -- be a tau-type.)
 115     newTyVarTy openTypeKind             `thenNF_Tc` \ ip_ty ->
 116     newIPDict (IPOcc ip) ip ip_ty       `thenNF_Tc` \ (ip', inst) ->
 117     tcSub res_ty ip_ty                  `thenTc` \ (co_fn, lie) ->
 118     returnNF_Tc (co_fn <$> HsIPVar ip', lie `plusLIE` unitLIE inst)
 119 \end{code}
 120
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection{Expressions type signatures}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 130  = tcHsSigType ExprSigCtxt poly_ty      `thenTc` \ sig_tc_ty ->
 131    tcAddErrCtxt (exprSigCtxt in_expr)   $
 132    tcExpr expr sig_tc_ty                `thenTc` \ (expr', lie1) ->
 133    tcSub res_ty sig_tc_ty               `thenTc` \ (co_fn, lie2) ->
 134    returnTc (co_fn <$> expr', lie1 `plusLIE` lie2)
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Other expression forms}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 tcMonoExpr (HsLit lit)     res_ty = tcLit lit res_ty
 146 tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
 147 tcMonoExpr (HsPar expr)    res_ty = tcMonoExpr expr res_ty
 148
 149 tcMonoExpr (NegApp expr neg_name) res_ty
 150   = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
 151
 152 tcMonoExpr (HsLam match) res_ty
 153   = tcMatchLambda match res_ty          `thenTc` \ (match',lie) ->
 154     returnTc (HsLam match', lie)
 155
 156 tcMonoExpr (HsApp e1 e2) res_ty
 157   = tcApp e1 [e2] res_ty
 158 \end{code}
 159
 160 Note that the operators in sections are expected to be binary, and
 161 a type error will occur if they aren't.
 162
 163 \begin{code}
 164 -- Left sections, equivalent to
 165 --      \ x -> e op x,
 166 -- or
 167 --      \ x -> op e x,
 168 -- or just
 169 --      op e
 170
 171 tcMonoExpr in_expr@(SectionL arg1 op) res_ty
 172   = tcExpr_id op                                `thenTc` \ (op', lie1, op_ty) ->
 173     split_fun_ty op_ty 2 {- two args -}         `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 174     tcArg op (arg1, arg1_ty, 1)                 `thenTc` \ (arg1',lie2) ->
 175     tcAddErrCtxt (exprCtxt in_expr)             $
 176     tcSub res_ty (mkFunTy arg2_ty op_res_ty)    `thenTc` \ (co_fn, lie3) ->
 177     returnTc (co_fn <$> SectionL arg1' op', lie1 `plusLIE` lie2 `plusLIE` lie3)
 178
 179 -- Right sections, equivalent to \ x -> x op expr, or
 180 --      \ x -> op x expr
 181
 182 tcMonoExpr in_expr@(SectionR op arg2) res_ty
 183   = tcExpr_id op                                `thenTc` \ (op', lie1, op_ty) ->
 184     split_fun_ty op_ty 2 {- two args -}         `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 185     tcArg op (arg2, arg2_ty, 2)                 `thenTc` \ (arg2',lie2) ->
 186     tcAddErrCtxt (exprCtxt in_expr)             $
 187     tcSub res_ty (mkFunTy arg1_ty op_res_ty)    `thenTc` \ (co_fn, lie3) ->
 188     returnTc (co_fn <$> SectionR op' arg2', lie1 `plusLIE` lie2 `plusLIE` lie3)
 189
 190 -- equivalent to (op e1) e2:
 191
 192 tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
 193   = tcExpr_id op                                `thenTc` \ (op', lie1, op_ty) ->
 194     split_fun_ty op_ty 2 {- two args -}         `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 195     tcArg op (arg1, arg1_ty, 1)                 `thenTc` \ (arg1',lie2a) ->
 196     tcArg op (arg2, arg2_ty, 2)                 `thenTc` \ (arg2',lie2b) ->
 197     tcAddErrCtxt (exprCtxt in_expr)             $
 198     tcSub res_ty op_res_ty                      `thenTc` \ (co_fn, lie3) ->
 199     returnTc (OpApp arg1' op' fix arg2',
 200               lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3)
 201 \end{code}
 202
 203 The interesting thing about @ccall@ is that it is just a template
 204 which we instantiate by filling in details about the types of its
 205 argument and result (ie minimal typechecking is performed).  So, the
 206 basic story is that we allocate a load of type variables (to hold the
 207 arg/result types); unify them with the args/result; and store them for
 208 later use.
 209
 210 \begin{code}
 211 tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
 212
 213   = getDOptsTc                          `thenNF_Tc` \ dflags ->
 214
 215     checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
 216         (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
 217                text "Either compile with -fvia-C, or, better, rewrite your code",
 218                text "to use the foreign function interface.  _casm_s are deprecated",
 219                text "and support for them may one day disappear."])
 220                                         `thenTc_`
 221
 222     -- Get the callable and returnable classes.
 223     tcLookupClass cCallableClassName    `thenNF_Tc` \ cCallableClass ->
 224     tcLookupClass cReturnableClassName  `thenNF_Tc` \ cReturnableClass ->
 225     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
 226     let
 227         new_arg_dict (arg, arg_ty)
 228           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 229                      [mkClassPred cCallableClass [arg_ty]]      `thenNF_Tc` \ arg_dicts ->
 230             returnNF_Tc arg_dicts       -- Actually a singleton bag
 231
 232         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 233     in
 234
 235         -- Arguments
 236     let tv_idxs | null args  = []
 237                 | otherwise  = [1..length args]
 238     in
 239     newTyVarTys (length tv_idxs) openTypeKind           `thenNF_Tc` \ arg_tys ->
 240     tcMonoExprs args arg_tys                            `thenTc`    \ (args', args_lie) ->
 241
 242         -- The argument types can be unlifted or lifted; the result
 243         -- type must, however, be lifted since it's an argument to the IO
 244         -- type constructor.
 245     newTyVarTy liftedTypeKind           `thenNF_Tc` \ result_ty ->
 246     let
 247         io_result_ty = mkTyConApp ioTyCon [result_ty]
 248     in
 249     unifyTauTy res_ty io_result_ty              `thenTc_`
 250
 251         -- Construct the extra insts, which encode the
 252         -- constraints on the argument and result types.
 253     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 254     newDicts result_origin [mkClassPred cReturnableClass [result_ty]]   `thenNF_Tc` \ ccres_dict ->
 255     returnTc (HsCCall lbl args' may_gc is_casm io_result_ty,
 256               mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
 257 \end{code}
 258
 259 \begin{code}
 260 tcMonoExpr (HsSCC lbl expr) res_ty
 261   = tcMonoExpr expr res_ty              `thenTc` \ (expr', lie) ->
 262     returnTc (HsSCC lbl expr', lie)
 263
 264 tcMonoExpr (HsLet binds expr) res_ty
 265   = tcBindsAndThen
 266         combiner
 267         binds                   -- Bindings to check
 268         tc_expr         `thenTc` \ (expr', lie) ->
 269     returnTc (expr', lie)
 270   where
 271     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
 272               returnTc (expr', lie)
 273     combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 274
 275 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
 276   = tcAddSrcLoc src_loc                 $
 277     tcAddErrCtxt (caseCtxt in_expr)     $
 278
 279         -- Typecheck the case alternatives first.
 280         -- The case patterns tend to give good type info to use
 281         -- when typechecking the scrutinee.  For example
 282         --      case (map f) of
 283         --        (x:xs) -> ...
 284         -- will report that map is applied to too few arguments
 285         --
 286         -- Not only that, but it's better to check the matches on their
 287         -- own, so that we get the expected results for scoped type variables.
 288         --      f x = case x of
 289         --              (p::a, q::b) -> (q,p)
 290         -- The above should work: the match (p,q) -> (q,p) is polymorphic as
 291         -- claimed by the pattern signatures.  But if we typechecked the
 292         -- match with x in scope and x's type as the expected type, we'd be hosed.
 293
 294     tcMatchesCase matches res_ty        `thenTc`    \ (scrut_ty, matches', lie2) ->
 295
 296     tcAddErrCtxt (caseScrutCtxt scrut)  (
 297       tcMonoExpr scrut scrut_ty
 298     )                                   `thenTc`    \ (scrut',lie1) ->
 299
 300     returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 301
 302 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 303   = tcAddSrcLoc src_loc $
 304     tcAddErrCtxt (predCtxt pred) (
 305     tcMonoExpr pred boolTy      )       `thenTc`    \ (pred',lie1) ->
 306
 307     tcMonoExpr b1 res_ty                `thenTc`    \ (b1',lie2) ->
 308     tcMonoExpr b2 res_ty                `thenTc`    \ (b2',lie3) ->
 309     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
 310 \end{code}
 311
 312 \begin{code}
 313 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
 314   = tcDoStmts do_or_lc stmts src_loc res_ty
 315 \end{code}
 316
 317 \begin{code}
 318 tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty        -- Non-empty list
 319   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 320     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 321     returnTc (ExplicitList elt_ty exprs', plusLIEs lies)
 322   where
 323     tc_elt elt_ty expr
 324       = tcAddErrCtxt (listCtxt expr) $
 325         tcMonoExpr expr elt_ty
 326
 327 tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty        -- maybe empty
 328   = unifyPArrTy res_ty                        `thenTc` \ elt_ty ->
 329     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 330     returnTc (ExplicitPArr elt_ty exprs', plusLIEs lies)
 331   where
 332     tc_elt elt_ty expr
 333       = tcAddErrCtxt (parrCtxt expr) $
 334         tcMonoExpr expr elt_ty
 335
 336 tcMonoExpr (ExplicitTuple exprs boxity) res_ty
 337   = unifyTupleTy boxity (length exprs) res_ty   `thenTc` \ arg_tys ->
 338     mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
 339                (exprs `zip` arg_tys) -- we know they're of equal length.
 340                                                 `thenTc` \ (exprs', lies) ->
 341     returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
 342
 343 tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
 344   = tcAddErrCtxt (recordConCtxt expr)           $
 345     tcId con_name                       `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 346     let
 347         (_, record_ty)   = tcSplitFunTys con_tau
 348         (tycon, ty_args) = tcSplitTyConApp record_ty
 349     in
 350     ASSERT( isAlgTyCon tycon )
 351     unifyTauTy res_ty record_ty          `thenTc_`
 352
 353         -- Check that the record bindings match the constructor
 354         -- con_name is syntactically constrained to be a data constructor
 355     tcLookupDataCon con_name    `thenTc` \ data_con ->
 356     let
 357         bad_fields = badFields rbinds data_con
 358     in
 359     if not (null bad_fields) then
 360         mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields   `thenNF_Tc_`
 361         failTc  -- Fail now, because tcRecordBinds will crash on a bad field
 362     else
 363
 364         -- Typecheck the record bindings
 365     tcRecordBinds tycon ty_args rbinds          `thenTc` \ (rbinds', rbinds_lie) ->
 366
 367     let
 368       (missing_s_fields, missing_fields) = missingFields rbinds data_con
 369     in
 370     checkTcM (null missing_s_fields)
 371         (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
 372          returnNF_Tc ())  `thenNF_Tc_`
 373     doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
 374     checkTcM (not (warn && not (null missing_fields)))
 375         (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
 376          returnNF_Tc ())  `thenNF_Tc_`
 377
 378     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 379
 380 -- The main complication with RecordUpd is that we need to explicitly
 381 -- handle the *non-updated* fields.  Consider:
 382 --
 383 --      data T a b = MkT1 { fa :: a, fb :: b }
 384 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 385 --                 | MkT3 { fd :: a }
 386 --
 387 --      upd :: T a b -> c -> T a c
 388 --      upd t x = t { fb = x}
 389 --
 390 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 391 -- because upd should be equivalent to:
 392 --
 393 --      upd t x = case t of
 394 --                      MkT1 p q -> MkT1 p x
 395 --                      MkT2 a b -> MkT2 p b
 396 --                      MkT3 d   -> error ...
 397 --
 398 -- So we need to give a completely fresh type to the result record,
 399 -- and then constrain it by the fields that are *not* updated ("p" above).
 400 --
 401 -- Note that because MkT3 doesn't contain all the fields being updated,
 402 -- its RHS is simply an error, so it doesn't impose any type constraints
 403 --
 404 -- All this is done in STEP 4 below.
 405
 406 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 407   = tcAddErrCtxt (recordUpdCtxt expr)           $
 408
 409         -- STEP 0
 410         -- Check that the field names are really field names
 411     ASSERT( not (null rbinds) )
 412     let
 413         field_names = [field_name | (field_name, _, _) <- rbinds]
 414     in
 415     mapNF_Tc tcLookupGlobal_maybe field_names           `thenNF_Tc` \ maybe_sel_ids ->
 416     let
 417         bad_guys = [ addErrTc (notSelector field_name)
 418                    | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 419                       case maybe_sel_id of
 420                         Just (AnId sel_id) -> not (isRecordSelector sel_id)
 421                         other              -> True
 422                    ]
 423     in
 424     checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc)   `thenTc_`
 425
 426         -- STEP 1
 427         -- Figure out the tycon and data cons from the first field name
 428     let
 429                 -- It's OK to use the non-tc splitters here (for a selector)
 430         (Just (AnId sel_id) : _)    = maybe_sel_ids
 431         (_, _, tau)                 = tcSplitSigmaTy (idType sel_id)    -- Selectors can be overloaded
 432                                                                         -- when the data type has a context
 433         data_ty                     = tcFunArgTy tau                    -- Must succeed since sel_id is a selector
 434         tycon                       = tcTyConAppTyCon data_ty
 435         data_cons                   = tyConDataCons tycon
 436         (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
 437     in
 438     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 439
 440         -- STEP 2
 441         -- Check that at least one constructor has all the named fields
 442         -- i.e. has an empty set of bad fields returned by badFields
 443     checkTc (any (null . badFields rbinds) data_cons)
 444             (badFieldsUpd rbinds)               `thenTc_`
 445
 446         -- STEP 3
 447         -- Typecheck the update bindings.
 448         -- (Do this after checking for bad fields in case there's a field that
 449         --  doesn't match the constructor.)
 450     let
 451         result_record_ty = mkTyConApp tycon result_inst_tys
 452     in
 453     unifyTauTy res_ty result_record_ty          `thenTc_`
 454     tcRecordBinds tycon result_inst_tys rbinds  `thenTc` \ (rbinds', rbinds_lie) ->
 455
 456         -- STEP 4
 457         -- Use the un-updated fields to find a vector of booleans saying
 458         -- which type arguments must be the same in updatee and result.
 459         --
 460         -- WARNING: this code assumes that all data_cons in a common tycon
 461         -- have FieldLabels abstracted over the same tyvars.
 462     let
 463         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 464         con_field_lbls_s    = map dataConFieldLabels data_cons
 465
 466                 -- A constructor is only relevant to this process if
 467                 -- it contains all the fields that are being updated
 468         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 469         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 470
 471         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 472         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 473
 474         mk_inst_ty (tyvar, result_inst_ty)
 475           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 476           | otherwise                               = newTyVarTy liftedTypeKind -- Fresh type
 477     in
 478     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 479
 480         -- STEP 5
 481         -- Typecheck the expression to be updated
 482     let
 483         record_ty = mkTyConApp tycon inst_tys
 484     in
 485     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 486
 487         -- STEP 6
 488         -- Figure out the LIE we need.  We have to generate some
 489         -- dictionaries for the data type context, since we are going to
 490         -- do some construction.
 491         --
 492         -- What dictionaries do we need?  For the moment we assume that all
 493         -- data constructors have the same context, and grab it from the first
 494         -- constructor.  If they have varying contexts then we'd have to
 495         -- union the ones that could participate in the update.
 496     let
 497         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 498         inst_env = mkTopTyVarSubst tyvars result_inst_tys
 499         theta'   = substTheta inst_env theta
 500     in
 501     newDicts RecordUpdOrigin theta'     `thenNF_Tc` \ dicts ->
 502
 503         -- Phew!
 504     returnTc (RecordUpdOut record_expr' record_ty result_record_ty (map instToId dicts) rbinds',
 505               mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
 506
 507 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 508   = unifyListTy res_ty                          `thenTc` \ elt_ty ->
 509     tcMonoExpr expr elt_ty                      `thenTc` \ (expr', lie1) ->
 510
 511     tcLookupGlobalId enumFromName               `thenNF_Tc` \ sel_id ->
 512     newMethod (ArithSeqOrigin seq)
 513               sel_id [elt_ty]                   `thenNF_Tc` \ enum_from ->
 514
 515     returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
 516               lie1 `plusLIE` unitLIE enum_from)
 517
 518 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 519   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 520     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 521     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 522     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 523     tcLookupGlobalId enumFromThenName                   `thenNF_Tc` \ sel_id ->
 524     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ enum_from_then ->
 525
 526     returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
 527                           (FromThen expr1' expr2'),
 528               lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_then)
 529
 530 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 531   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 532     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 533     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 534     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 535     tcLookupGlobalId enumFromToName                     `thenNF_Tc` \ sel_id ->
 536     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ enum_from_to ->
 537
 538     returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
 539                           (FromTo expr1' expr2'),
 540               lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
 541
 542 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 543   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 544     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 545     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 546     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 547     tcMonoExpr expr3 elt_ty                             `thenTc`    \ (expr3',lie3) ->
 548     tcLookupGlobalId enumFromThenToName                 `thenNF_Tc` \ sel_id ->
 549     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ eft ->
 550
 551     returnTc (ArithSeqOut (HsVar (instToId eft))
 552                           (FromThenTo expr1' expr2' expr3'),
 553               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
 554
 555 tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
 556   = tcAddErrCtxt (parrSeqCtxt in_expr) $
 557     unifyPArrTy  res_ty                                 `thenTc`    \ elt_ty ->
 558     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 559     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 560     tcLookupGlobalId enumFromToPName                    `thenNF_Tc` \ sel_id ->
 561     newMethod (PArrSeqOrigin seq) sel_id [elt_ty]       `thenNF_Tc` \ enum_from_to ->
 562
 563     returnTc (PArrSeqOut (HsVar (instToId enum_from_to))
 564                          (FromTo expr1' expr2'),
 565               lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
 566
 567 tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 568   = tcAddErrCtxt  (parrSeqCtxt in_expr) $
 569     unifyPArrTy  res_ty                                 `thenTc`    \ elt_ty ->
 570     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 571     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 572     tcMonoExpr expr3 elt_ty                             `thenTc`    \ (expr3',lie3) ->
 573     tcLookupGlobalId enumFromThenToPName                `thenNF_Tc` \ sel_id ->
 574     newMethod (PArrSeqOrigin seq) sel_id [elt_ty]       `thenNF_Tc` \ eft ->
 575
 576     returnTc (PArrSeqOut (HsVar (instToId eft))
 577                          (FromThenTo expr1' expr2' expr3'),
 578               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
 579
 580 tcMonoExpr (PArrSeqIn _) _
 581   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 582     -- the parser shouldn't have generated it and the renamer shouldn't have
 583     -- let it through
 584 \end{code}
 585
 586 %************************************************************************
 587 %*                                                                      *
 588 \subsection{Implicit Parameter bindings}
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 \begin{code}
 593 tcMonoExpr (HsWith expr binds) res_ty
 594   = tcMonoExpr expr res_ty                      `thenTc` \ (expr', expr_lie) ->
 595     mapAndUnzip3Tc tcIPBind binds               `thenTc` \ (avail_ips, binds', bind_lies) ->
 596
 597         -- If the binding binds ?x = E, we  must now
 598         -- discharge any ?x constraints in expr_lie
 599     tcSimplifyIPs avail_ips expr_lie            `thenTc` \ (expr_lie', dict_binds) ->
 600     let
 601         expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
 602     in
 603     returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies)
 604
 605 tcIPBind (ip, expr)
 606   = newTyVarTy openTypeKind             `thenTc` \ ty ->
 607     tcGetSrcLoc                         `thenTc` \ loc ->
 608     newIPDict (IPBind ip) ip ty         `thenNF_Tc` \ (ip', ip_inst) ->
 609     tcMonoExpr expr ty                  `thenTc` \ (expr', lie) ->
 610     returnTc (ip_inst, (ip', expr'), lie)
 611 \end{code}
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection{@tcApp@ typchecks an application}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620
 621 tcApp :: RenamedHsExpr -> [RenamedHsExpr]       -- Function and args
 622       -> TcType                                 -- Expected result type of application
 623       -> TcM (TcExpr, LIE)                      -- Translated fun and args
 624
 625 tcApp (HsApp e1 e2) args res_ty
 626   = tcApp e1 (e2:args) res_ty           -- Accumulate the arguments
 627
 628 tcApp fun args res_ty
 629   =     -- First type-check the function
 630     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 631
 632     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 633         split_fun_ty fun_ty (length args)
 634     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 635
 636         -- Now typecheck the args
 637     mapAndUnzipTc (tcArg fun)
 638           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 639
 640         -- Unify with expected result after type-checking the args
 641         -- so that the info from args percolates to actual_result_ty.
 642         -- This is when we might detect a too-few args situation.
 643         -- (One can think of cases when the opposite order would give
 644         -- a better error message.)
 645     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
 646                   (tcSub res_ty actual_result_ty)       `thenTc` \ (co_fn, lie_res) ->
 647
 648     returnTc (co_fn <$> foldl HsApp fun' args',
 649               lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s)
 650
 651
 652 -- If an error happens we try to figure out whether the
 653 -- function has been given too many or too few arguments,
 654 -- and say so
 655 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 656   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 657     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 658     let
 659       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 660       (env2, act_ty'') = tidyOpenType env1     act_ty'
 661       (exp_args, _)    = tcSplitFunTys exp_ty''
 662       (act_args, _)    = tcSplitFunTys act_ty''
 663
 664       len_act_args     = length act_args
 665       len_exp_args     = length exp_args
 666
 667       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 668               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 669               | otherwise                   = appCtxt fun args
 670     in
 671     returnNF_Tc (env2, message)
 672
 673
 674 split_fun_ty :: TcType          -- The type of the function
 675              -> Int             -- Number of arguments
 676              -> TcM ([TcType],  -- Function argument types
 677                      TcType)    -- Function result types
 678
 679 split_fun_ty fun_ty 0
 680   = returnTc ([], fun_ty)
 681
 682 split_fun_ty fun_ty n
 683   =     -- Expect the function to have type A->B
 684     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 685     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 686     returnTc (arg_ty:arg_tys, final_res_ty)
 687 \end{code}
 688
 689 \begin{code}
 690 tcArg :: RenamedHsExpr                          -- The function (for error messages)
 691       -> (RenamedHsExpr, TcSigmaType, Int)      -- Actual argument and expected arg type
 692       -> TcM (TcExpr, LIE)                      -- Resulting argument and LIE
 693
 694 tcArg the_fun (arg, expected_arg_ty, arg_no)
 695   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 696     tcExpr arg expected_arg_ty
 697 \end{code}
 698
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsection{@tcId@ typchecks an identifier occurrence}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 \begin{code}
 707 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
 708 tcId name       -- Look up the Id and instantiate its type
 709   = tcLookupId name                     `thenNF_Tc` \ id ->
 710     tcInstId id
 711 \end{code}
 712
 713 Typecheck expression which in most cases will be an Id.
 714
 715 \begin{code}
 716 tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
 717 tcExpr_id (HsVar name) = tcId name
 718 tcExpr_id expr         = newTyVarTy openTypeKind        `thenNF_Tc` \ id_ty ->
 719                          tcMonoExpr expr id_ty          `thenTc`    \ (expr', lie_id) ->
 720                          returnTc (expr', lie_id, id_ty)
 721 \end{code}
 722
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 \begin{code}
 731 -- I don't like this lumping together of do expression and list/array
 732 -- comprehensions; creating the monad instances is entirely pointless in the
 733 -- latter case; I'll leave the list case as it is for the moment, but handle
 734 -- arrays extra (would be better to handle arrays and lists together, though)
 735 -- -=chak
 736 --
 737 tcDoStmts PArrComp stmts src_loc res_ty
 738   =
 739     ASSERT( not (null stmts) )
 740     tcAddSrcLoc src_loc $
 741
 742     unifyPArrTy res_ty                        `thenTc` \elt_ty              ->
 743     let tc_ty = mkTyConTy parrTyCon
 744         m_ty  = (mkPArrTy, elt_ty)
 745     in
 746     tcStmts (DoCtxt PArrComp) m_ty stmts      `thenTc` \(stmts', stmts_lie) ->
 747     returnTc (HsDoOut PArrComp stmts'
 748                       undefined undefined undefined  -- don't touch!
 749                       res_ty src_loc,
 750               stmts_lie)
 751
 752 tcDoStmts do_or_lc stmts src_loc res_ty
 753   =     -- get the Monad and MonadZero classes
 754         -- create type consisting of a fresh monad tyvar
 755     ASSERT( not (null stmts) )
 756     tcAddSrcLoc src_loc $
 757
 758         -- If it's a comprehension we're dealing with,
 759         -- force it to be a list comprehension.
 760         -- (as of Haskell 98, monad comprehensions are no more.)
 761         -- Similarily, array comprehensions must involve parallel arrays types
 762         --   -=chak
 763     (case do_or_lc of
 764        ListComp -> unifyListTy res_ty                   `thenTc` \ elt_ty ->
 765                    returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
 766
 767        PArrComp -> panic "TcExpr.tcDoStmts: How did we get here?!?"
 768
 769        _        -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)       `thenNF_Tc` \ m_ty ->
 770                    newTyVarTy liftedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 771                    unifyTauTy res_ty (mkAppTy m_ty elt_ty)                      `thenTc_`
 772                    returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
 773     )                                                   `thenNF_Tc` \ (tc_ty, m_ty) ->
 774
 775     tcStmts (DoCtxt do_or_lc) m_ty stmts                `thenTc`   \ (stmts', stmts_lie) ->
 776
 777         -- Build the then and zero methods in case we need them
 778         -- It's important that "then" and "return" appear just once in the final LIE,
 779         -- not only for typechecker efficiency, but also because otherwise during
 780         -- simplification we end up with silly stuff like
 781         --      then = case d of (t,r) -> t
 782         --      then = then
 783         -- where the second "then" sees that it already exists in the "available" stuff.
 784         --
 785     tcLookupGlobalId returnMName                `thenNF_Tc` \ return_sel_id ->
 786     tcLookupGlobalId thenMName                  `thenNF_Tc` \ then_sel_id ->
 787     tcLookupGlobalId failMName                  `thenNF_Tc` \ fail_sel_id ->
 788     newMethod DoOrigin return_sel_id [tc_ty]    `thenNF_Tc` \ return_inst ->
 789     newMethod DoOrigin then_sel_id   [tc_ty]    `thenNF_Tc` \ then_inst ->
 790     newMethod DoOrigin fail_sel_id   [tc_ty]    `thenNF_Tc` \ fail_inst ->
 791     let
 792         monad_lie = mkLIE [return_inst, then_inst, fail_inst]
 793     in
 794     returnTc (HsDoOut do_or_lc stmts'
 795                       (instToId return_inst) (instToId then_inst) (instToId fail_inst)
 796                       res_ty src_loc,
 797               stmts_lie `plusLIE` monad_lie)
 798 \end{code}
 799
 800
 801 %************************************************************************
 802 %*                                                                      *
 803 \subsection{Record bindings}
 804 %*                                                                      *
 805 %************************************************************************
 806
 807 Game plan for record bindings
 808 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 809 1. Find the TyCon for the bindings, from the first field label.
 810
 811 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 812
 813 For each binding field = value
 814
 815 3. Instantiate the field type (from the field label) using the type
 816    envt from step 2.
 817
 818 4  Type check the value using tcArg, passing the field type as
 819    the expected argument type.
 820
 821 This extends OK when the field types are universally quantified.
 822
 823
 824 \begin{code}
 825 tcRecordBinds
 826         :: TyCon                -- Type constructor for the record
 827         -> [TcType]             -- Args of this type constructor
 828         -> RenamedRecordBinds
 829         -> TcM (TcRecordBinds, LIE)
 830
 831 tcRecordBinds tycon ty_args rbinds
 832   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 833     returnTc (rbinds', plusLIEs lies)
 834   where
 835     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 836
 837     do_bind (field_lbl_name, rhs, pun_flag)
 838       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 839         let
 840             field_lbl = recordSelectorFieldLabel sel_id
 841             field_ty  = substTy tenv (fieldLabelType field_lbl)
 842         in
 843         ASSERT( isRecordSelector sel_id )
 844                 -- This lookup and assertion will surely succeed, because
 845                 -- we check that the fields are indeed record selectors
 846                 -- before calling tcRecordBinds
 847         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 848                 -- The caller of tcRecordBinds has already checked
 849                 -- that all the fields come from the same type
 850
 851         tcExpr rhs field_ty                     `thenTc` \ (rhs', lie) ->
 852
 853         returnTc ((sel_id, rhs', pun_flag), lie)
 854
 855 badFields rbinds data_con
 856   = [field_name | (field_name, _, _) <- rbinds,
 857                   not (field_name `elem` field_names)
 858     ]
 859   where
 860     field_names = map fieldLabelName (dataConFieldLabels data_con)
 861
 862 missingFields rbinds data_con
 863   | null field_labels = ([], [])        -- Not declared as a record;
 864                                         -- But C{} is still valid
 865   | otherwise
 866   = (missing_strict_fields, other_missing_fields)
 867   where
 868     missing_strict_fields
 869         = [ fl | (fl, str) <- field_info,
 870                  isMarkedStrict str,
 871                  not (fieldLabelName fl `elem` field_names_used)
 872           ]
 873     other_missing_fields
 874         = [ fl | (fl, str) <- field_info,
 875                  not (isMarkedStrict str),
 876                  not (fieldLabelName fl `elem` field_names_used)
 877           ]
 878
 879     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 880     field_labels     = dataConFieldLabels data_con
 881
 882     field_info = zipEqual "missingFields"
 883                           field_labels
 884                           (dropList ex_theta (dataConStrictMarks data_con))
 885         -- The 'drop' is because dataConStrictMarks
 886         -- includes the existential dictionaries
 887     (_, _, _, ex_theta, _, _) = dataConSig data_con
 888 \end{code}
 889
 890 %************************************************************************
 891 %*                                                                      *
 892 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 893 %*                                                                      *
 894 %************************************************************************
 895
 896 \begin{code}
 897 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
 898
 899 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 900 tcMonoExprs (expr:exprs) (ty:tys)
 901  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 902    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 903    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 904 \end{code}
 905
 906
 907 %************************************************************************
 908 %*                                                                      *
 909 \subsection{Literals}
 910 %*                                                                      *
 911 %************************************************************************
 912
 913 Overloaded literals.
 914
 915 \begin{code}
 916 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 917 tcLit (HsLitLit s _) res_ty
 918   = tcLookupClass cCallableClassName                    `thenNF_Tc` \ cCallableClass ->
 919     newDicts (LitLitOrigin (_UNPK_ s))
 920              [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
 921     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
 922
 923 tcLit lit res_ty
 924   = unifyTauTy res_ty (simpleHsLitTy lit)               `thenTc_`
 925     returnTc (HsLit lit, emptyLIE)
 926 \end{code}
 927
 928
 929 %************************************************************************
 930 %*                                                                      *
 931 \subsection{Errors and contexts}
 932 %*                                                                      *
 933 %************************************************************************
 934
 935 Mini-utils:
 936
 937 Boring and alphabetical:
 938 \begin{code}
 939 arithSeqCtxt expr
 940   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 941
 942 parrSeqCtxt expr
 943   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
 944
 945 caseCtxt expr
 946   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 947
 948 caseScrutCtxt expr
 949   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 950
 951 exprSigCtxt expr
 952   = hang (ptext SLIT("In an expression with a type signature:"))
 953          4 (ppr expr)
 954
 955 listCtxt expr
 956   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
 957
 958 parrCtxt expr
 959   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
 960
 961 predCtxt expr
 962   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 963
 964 exprCtxt expr
 965   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
 966
 967 funAppCtxt fun arg arg_no
 968   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
 969                     quotes (ppr fun) <> text ", namely"])
 970          4 (quotes (ppr arg))
 971
 972 wrongArgsCtxt too_many_or_few fun args
 973   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
 974                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
 975                     <+> ptext SLIT("arguments in the call"))
 976          4 (parens (ppr the_app))
 977   where
 978     the_app = foldl HsApp fun args      -- Used in error messages
 979
 980 appCtxt fun args
 981   = ptext SLIT("In the application") <+> quotes (ppr the_app)
 982   where
 983     the_app = foldl HsApp fun args      -- Used in error messages
 984
 985 lurkingRank2Err fun fun_ty
 986   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
 987          4 (vcat [ptext SLIT("It is applied to too few arguments"),
 988                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
 989
 990 badFieldsUpd rbinds
 991   = hang (ptext SLIT("No constructor has all these fields:"))
 992          4 (pprQuotedList fields)
 993   where
 994     fields = [field | (field, _, _) <- rbinds]
 995
 996 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
 997 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
 998
 999 notSelector field
1000   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1001
1002 missingStrictFieldCon :: Name -> FieldLabel -> SDoc
1003 missingStrictFieldCon con field
1004   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1005           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1006
1007 missingFieldCon :: Name -> FieldLabel -> SDoc
1008 missingFieldCon con field
1009   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1010           ptext SLIT("is not initialised")]
1011 \end{code}