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