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