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