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