ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           HsMatchContext(..), 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,
  24                           instToId, tcInstId
  25                         )
  26 import TcBinds          ( tcBindsAndThen )
  27 import TcEnv            ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
  28                           tcLookupTyCon, tcLookupDataCon, tcLookupId,
  29                           tcExtendGlobalTyVars, tcLookupSyntaxName
  30                         )
  31 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  32 import TcMonoType       ( tcHsSigType, checkSigTyVars, sigCtxt )
  33 import TcPat            ( badFieldCon, simpleHsLitTy )
  34 import TcSimplify       ( tcSimplifyCheck, tcSimplifyIPs )
  35 import TcType           ( TcType, TcTauType,
  36                           tcInstTyVars, tcInstType,
  37                           newTyVarTy, newTyVarTys, zonkTcType )
  38
  39 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
  40 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  41 import DataCon          ( dataConFieldLabels, dataConSig,
  42                           dataConStrictMarks
  43                         )
  44 import Demand           ( isMarkedStrict )
  45 import Name             ( Name )
  46 import Type             ( mkFunTy, mkAppTy, mkTyConTy,
  47                           splitFunTy_maybe, splitFunTys,
  48                           mkTyConApp, splitSigmaTy, mkClassPred,
  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, substTheta, 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 )
  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           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 273                      [mkClassPred 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     newDicts result_origin [mkClassPred 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, missing_fields) = missingFields 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     doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
 410     checkTcM (not (warn && not (null missing_fields)))
 411         (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
 412          returnNF_Tc ())  `thenNF_Tc_`
 413
 414     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 415
 416 -- The main complication with RecordUpd is that we need to explicitly
 417 -- handle the *non-updated* fields.  Consider:
 418 --
 419 --      data T a b = MkT1 { fa :: a, fb :: b }
 420 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 421 --                 | MkT3 { fd :: a }
 422 --
 423 --      upd :: T a b -> c -> T a c
 424 --      upd t x = t { fb = x}
 425 --
 426 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 427 -- because upd should be equivalent to:
 428 --
 429 --      upd t x = case t of
 430 --                      MkT1 p q -> MkT1 p x
 431 --                      MkT2 a b -> MkT2 p b
 432 --                      MkT3 d   -> error ...
 433 --
 434 -- So we need to give a completely fresh type to the result record,
 435 -- and then constrain it by the fields that are *not* updated ("p" above).
 436 --
 437 -- Note that because MkT3 doesn't contain all the fields being updated,
 438 -- its RHS is simply an error, so it doesn't impose any type constraints
 439 --
 440 -- All this is done in STEP 4 below.
 441
 442 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 443   = tcAddErrCtxt (recordUpdCtxt expr)           $
 444
 445         -- STEP 0
 446         -- Check that the field names are really field names
 447     ASSERT( not (null rbinds) )
 448     let
 449         field_names = [field_name | (field_name, _, _) <- rbinds]
 450     in
 451     mapNF_Tc tcLookupGlobal_maybe field_names           `thenNF_Tc` \ maybe_sel_ids ->
 452     let
 453         bad_guys = [ addErrTc (notSelector field_name)
 454                    | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 455                       case maybe_sel_id of
 456                         Just (AnId sel_id) -> not (isRecordSelector sel_id)
 457                         other              -> True
 458                    ]
 459     in
 460     checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc)   `thenTc_`
 461
 462         -- STEP 1
 463         -- Figure out the tycon and data cons from the first field name
 464     let
 465         (Just (AnId sel_id) : _)  = maybe_sel_ids
 466         (_, _, tau)               = splitSigmaTy (idType sel_id)        -- Selectors can be overloaded
 467                                                                         -- when the data type has a context
 468         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 469         (tycon, _, data_cons)       = splitAlgTyConApp data_ty
 470         (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
 471     in
 472     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 473
 474         -- STEP 2
 475         -- Check that at least one constructor has all the named fields
 476         -- i.e. has an empty set of bad fields returned by badFields
 477     checkTc (any (null . badFields rbinds) data_cons)
 478             (badFieldsUpd rbinds)               `thenTc_`
 479
 480         -- STEP 3
 481         -- Typecheck the update bindings.
 482         -- (Do this after checking for bad fields in case there's a field that
 483         --  doesn't match the constructor.)
 484     let
 485         result_record_ty = mkTyConApp tycon result_inst_tys
 486     in
 487     unifyTauTy res_ty result_record_ty          `thenTc_`
 488     tcRecordBinds tycon result_inst_tys rbinds  `thenTc` \ (rbinds', rbinds_lie) ->
 489
 490         -- STEP 4
 491         -- Use the un-updated fields to find a vector of booleans saying
 492         -- which type arguments must be the same in updatee and result.
 493         --
 494         -- WARNING: this code assumes that all data_cons in a common tycon
 495         -- have FieldLabels abstracted over the same tyvars.
 496     let
 497         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 498         con_field_lbls_s    = map dataConFieldLabels data_cons
 499
 500                 -- A constructor is only relevant to this process if
 501                 -- it contains all the fields that are being updated
 502         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 503         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 504
 505         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 506         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 507
 508         mk_inst_ty (tyvar, result_inst_ty)
 509           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 510           | otherwise                               = newTyVarTy liftedTypeKind -- Fresh type
 511     in
 512     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 513
 514         -- STEP 5
 515         -- Typecheck the expression to be updated
 516     let
 517         record_ty = mkTyConApp tycon inst_tys
 518     in
 519     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 520
 521         -- STEP 6
 522         -- Figure out the LIE we need.  We have to generate some
 523         -- dictionaries for the data type context, since we are going to
 524         -- do some construction.
 525         --
 526         -- What dictionaries do we need?  For the moment we assume that all
 527         -- data constructors have the same context, and grab it from the first
 528         -- constructor.  If they have varying contexts then we'd have to
 529         -- union the ones that could participate in the update.
 530     let
 531         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 532         inst_env = mkTopTyVarSubst tyvars result_inst_tys
 533         theta'   = substTheta inst_env theta
 534     in
 535     newDicts RecordUpdOrigin theta'     `thenNF_Tc` \ dicts ->
 536
 537         -- Phew!
 538     returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds',
 539               mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
 540
 541 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 542   = unifyListTy res_ty                          `thenTc` \ elt_ty ->
 543     tcMonoExpr expr elt_ty                      `thenTc` \ (expr', lie1) ->
 544
 545     tcLookupGlobalId enumFromName               `thenNF_Tc` \ sel_id ->
 546     newMethod (ArithSeqOrigin seq)
 547               sel_id [elt_ty]                   `thenNF_Tc` \ enum_from ->
 548
 549     returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
 550               lie1 `plusLIE` unitLIE enum_from)
 551
 552 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 553   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 554     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 555     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 556     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 557     tcLookupGlobalId enumFromThenName                   `thenNF_Tc` \ sel_id ->
 558     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ enum_from_then ->
 559
 560     returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
 561                           (FromThen expr1' expr2'),
 562               lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_then)
 563
 564 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 565   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 566     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 567     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 568     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 569     tcLookupGlobalId enumFromToName                     `thenNF_Tc` \ sel_id ->
 570     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ enum_from_to ->
 571
 572     returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
 573                           (FromTo expr1' expr2'),
 574               lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
 575
 576 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 577   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 578     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 579     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 580     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 581     tcMonoExpr expr3 elt_ty                             `thenTc`    \ (expr3',lie3) ->
 582     tcLookupGlobalId enumFromThenToName                 `thenNF_Tc` \ sel_id ->
 583     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ eft ->
 584
 585     returnTc (ArithSeqOut (HsVar (instToId eft))
 586                           (FromThenTo expr1' expr2' expr3'),
 587               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
 588 \end{code}
 589
 590 %************************************************************************
 591 %*                                                                      *
 592 \subsection{Expressions type signatures}
 593 %*                                                                      *
 594 %************************************************************************
 595
 596 \begin{code}
 597 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 598  = tcAddErrCtxt (exprSigCtxt in_expr)   $
 599    tcHsSigType  poly_ty         `thenTc` \ sig_tc_ty ->
 600
 601    if not (isSigmaTy sig_tc_ty) then
 602         -- Easy case
 603         unifyTauTy sig_tc_ty res_ty     `thenTc_`
 604         tcMonoExpr expr sig_tc_ty
 605
 606    else -- Signature is polymorphic
 607         tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 608
 609             -- Now match the signature type with res_ty.
 610             -- We must not do this earlier, because res_ty might well
 611             -- mention variables free in the environment, and we'd get
 612             -- bogus complaints about not being able to for-all the
 613             -- sig_tyvars
 614         unifyTauTy res_ty expr_ty                       `thenTc_`
 615
 616             -- If everything is ok, return the stuff unchanged, except for
 617             -- the effect of any substutions etc.  We simply discard the
 618             -- result of the tcSimplifyCheck (inside tcPolyExpr), except for any default
 619             -- resolution it may have done, which is recorded in the
 620             -- substitution.
 621         returnTc (expr, lie)
 622 \end{code}
 623
 624 Implicit Parameter bindings.
 625
 626 \begin{code}
 627 tcMonoExpr (HsWith expr binds) res_ty
 628   = tcMonoExpr expr res_ty                      `thenTc` \ (expr', expr_lie) ->
 629     mapAndUnzipTc tcIPBind binds                `thenTc` \ (pairs, bind_lies) ->
 630
 631         -- If the binding binds ?x = E, we  must now
 632         -- discharge any ?x constraints in expr_lie
 633     tcSimplifyIPs (map fst pairs) 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 %************************************************************************
 649 %*                                                                      *
 650 \subsection{@tcApp@ typchecks an application}
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 \begin{code}
 655
 656 tcApp :: RenamedHsExpr -> [RenamedHsExpr]       -- Function and args
 657       -> TcType                                 -- Expected result type of application
 658       -> TcM (TcExpr, [TcExpr],         -- Translated fun and args
 659                 LIE)
 660
 661 tcApp fun args res_ty
 662   =     -- First type-check the function
 663     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 664
 665     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 666         split_fun_ty fun_ty (length args)
 667     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 668
 669         -- Unify with expected result before type-checking the args
 670         -- This is when we might detect a too-few args situation
 671     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 672        unifyTauTy res_ty actual_result_ty
 673     )                                                   `thenTc_`
 674
 675         -- Now typecheck the args
 676     mapAndUnzipTc (tcArg fun)
 677           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 678
 679     -- Check that the result type doesn't have any nested for-alls.
 680     -- For example, a "build" on its own is no good; it must be applied to something.
 681     checkTc (isTauTy actual_result_ty)
 682             (lurkingRank2Err fun actual_result_ty)      `thenTc_`
 683
 684     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 685
 686
 687 -- If an error happens we try to figure out whether the
 688 -- function has been given too many or too few arguments,
 689 -- and say so
 690 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 691   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 692     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 693     let
 694       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 695       (env2, act_ty'') = tidyOpenType env1     act_ty'
 696       (exp_args, _) = splitFunTys exp_ty''
 697       (act_args, _) = splitFunTys act_ty''
 698
 699       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 700               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 701               | otherwise                         = appCtxt fun args
 702     in
 703     returnNF_Tc (env2, message)
 704
 705
 706 split_fun_ty :: TcType          -- The type of the function
 707              -> Int                     -- Number of arguments
 708              -> TcM ([TcType],  -- Function argument types
 709                        TcType)  -- Function result types
 710
 711 split_fun_ty fun_ty 0
 712   = returnTc ([], fun_ty)
 713
 714 split_fun_ty fun_ty n
 715   =     -- Expect the function to have type A->B
 716     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 717     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 718     returnTc (arg_ty:arg_tys, final_res_ty)
 719 \end{code}
 720
 721 \begin{code}
 722 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 723       -> (RenamedHsExpr, TcType, Int)   -- Actual argument and expected arg type
 724       -> TcM (TcExpr, LIE)      -- Resulting argument and LIE
 725
 726 tcArg the_fun (arg, expected_arg_ty, arg_no)
 727   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 728     tcExpr arg expected_arg_ty
 729 \end{code}
 730
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection{@tcId@ typchecks an identifier occurrence}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 \begin{code}
 739 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
 740 tcId name       -- Look up the Id and instantiate its type
 741   = tcLookupId name                     `thenNF_Tc` \ id ->
 742     tcInstId id
 743 \end{code}
 744
 745 Typecheck expression which in most cases will be an Id.
 746
 747 \begin{code}
 748 tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
 749 tcExpr_id (HsVar name) = tcId name
 750 tcExpr_id expr         = newTyVarTy openTypeKind        `thenNF_Tc` \ id_ty ->
 751                          tcMonoExpr expr id_ty  `thenTc`    \ (expr', lie_id) ->
 752                          returnTc (expr', lie_id, id_ty)
 753 \end{code}
 754
 755
 756 %************************************************************************
 757 %*                                                                      *
 758 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 759 %*                                                                      *
 760 %************************************************************************
 761
 762 \begin{code}
 763 tcDoStmts do_or_lc stmts src_loc res_ty
 764   =     -- get the Monad and MonadZero classes
 765         -- create type consisting of a fresh monad tyvar
 766     ASSERT( not (null stmts) )
 767     tcAddSrcLoc src_loc $
 768
 769         -- If it's a comprehension we're dealing with,
 770         -- force it to be a list comprehension.
 771         -- (as of Haskell 98, monad comprehensions are no more.)
 772     (case do_or_lc of
 773        ListComp -> unifyListTy res_ty                   `thenTc` \ elt_ty ->
 774                    returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
 775
 776        _        -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)       `thenNF_Tc` \ m_ty ->
 777                    newTyVarTy liftedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 778                    unifyTauTy res_ty (mkAppTy m_ty elt_ty)                              `thenTc_`
 779                    returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
 780     )                                                   `thenNF_Tc` \ (tc_ty, m_ty) ->
 781
 782     tcStmts do_or_lc m_ty stmts                         `thenTc`   \ (stmts', stmts_lie) ->
 783
 784         -- Build the then and zero methods in case we need them
 785         -- It's important that "then" and "return" appear just once in the final LIE,
 786         -- not only for typechecker efficiency, but also because otherwise during
 787         -- simplification we end up with silly stuff like
 788         --      then = case d of (t,r) -> t
 789         --      then = then
 790         -- where the second "then" sees that it already exists in the "available" stuff.
 791         --
 792     tcLookupGlobalId returnMName                `thenNF_Tc` \ return_sel_id ->
 793     tcLookupGlobalId thenMName                  `thenNF_Tc` \ then_sel_id ->
 794     tcLookupGlobalId failMName                  `thenNF_Tc` \ fail_sel_id ->
 795     newMethod DoOrigin return_sel_id [tc_ty]    `thenNF_Tc` \ return_inst ->
 796     newMethod DoOrigin then_sel_id   [tc_ty]    `thenNF_Tc` \ then_inst ->
 797     newMethod DoOrigin fail_sel_id   [tc_ty]    `thenNF_Tc` \ fail_inst ->
 798     let
 799         monad_lie = mkLIE [return_inst, then_inst, fail_inst]
 800     in
 801     returnTc (HsDoOut do_or_lc stmts'
 802                       (instToId return_inst) (instToId then_inst) (instToId fail_inst)
 803                       res_ty src_loc,
 804               stmts_lie `plusLIE` monad_lie)
 805 \end{code}
 806
 807
 808 %************************************************************************
 809 %*                                                                      *
 810 \subsection{Record bindings}
 811 %*                                                                      *
 812 %************************************************************************
 813
 814 Game plan for record bindings
 815 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 816 1. Find the TyCon for the bindings, from the first field label.
 817
 818 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 819
 820 For each binding field = value
 821
 822 3. Instantiate the field type (from the field label) using the type
 823    envt from step 2.
 824
 825 4  Type check the value using tcArg, passing the field type as
 826    the expected argument type.
 827
 828 This extends OK when the field types are universally quantified.
 829
 830
 831 \begin{code}
 832 tcRecordBinds
 833         :: TyCon                -- Type constructor for the record
 834         -> [TcType]             -- Args of this type constructor
 835         -> RenamedRecordBinds
 836         -> TcM (TcRecordBinds, LIE)
 837
 838 tcRecordBinds tycon ty_args rbinds
 839   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 840     returnTc (rbinds', plusLIEs lies)
 841   where
 842     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 843
 844     do_bind (field_lbl_name, rhs, pun_flag)
 845       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 846         let
 847             field_lbl = recordSelectorFieldLabel sel_id
 848             field_ty  = substTy tenv (fieldLabelType field_lbl)
 849         in
 850         ASSERT( isRecordSelector sel_id )
 851                 -- This lookup and assertion will surely succeed, because
 852                 -- we check that the fields are indeed record selectors
 853                 -- before calling tcRecordBinds
 854         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 855                 -- The caller of tcRecordBinds has already checked
 856                 -- that all the fields come from the same type
 857
 858         tcPolyExpr rhs field_ty         `thenTc` \ (rhs', lie, _, _, _) ->
 859
 860         returnTc ((sel_id, rhs', pun_flag), lie)
 861
 862 badFields rbinds data_con
 863   = [field_name | (field_name, _, _) <- rbinds,
 864                   not (field_name `elem` field_names)
 865     ]
 866   where
 867     field_names = map fieldLabelName (dataConFieldLabels data_con)
 868
 869 missingFields rbinds data_con
 870   | null field_labels = ([], [])        -- Not declared as a record;
 871                                         -- But C{} is still valid
 872   | otherwise
 873   = (missing_strict_fields, other_missing_fields)
 874   where
 875     missing_strict_fields
 876         = [ fl | (fl, str) <- field_info,
 877                  isMarkedStrict str,
 878                  not (fieldLabelName fl `elem` field_names_used)
 879           ]
 880     other_missing_fields
 881         = [ fl | (fl, str) <- field_info,
 882                  not (isMarkedStrict str),
 883                  not (fieldLabelName fl `elem` field_names_used)
 884           ]
 885
 886     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 887     field_labels     = dataConFieldLabels data_con
 888
 889     field_info = zipEqual "missingFields"
 890                           field_labels
 891                           (drop (length ex_theta) (dataConStrictMarks data_con))
 892         -- The 'drop' is because dataConStrictMarks
 893         -- includes the existential dictionaries
 894     (_, _, _, ex_theta, _, _) = dataConSig data_con
 895 \end{code}
 896
 897 %************************************************************************
 898 %*                                                                      *
 899 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 900 %*                                                                      *
 901 %************************************************************************
 902
 903 \begin{code}
 904 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
 905
 906 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 907 tcMonoExprs (expr:exprs) (ty:tys)
 908  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 909    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 910    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 911 \end{code}
 912
 913
 914 %************************************************************************
 915 %*                                                                      *
 916 \subsection{Literals}
 917 %*                                                                      *
 918 %************************************************************************
 919
 920 Overloaded literals.
 921
 922 \begin{code}
 923 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 924 tcLit (HsLitLit s _) res_ty
 925   = tcLookupClass cCallableClassName                    `thenNF_Tc` \ cCallableClass ->
 926     newDicts (LitLitOrigin (_UNPK_ s))
 927              [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
 928     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
 929
 930 tcLit lit res_ty
 931   = unifyTauTy res_ty (simpleHsLitTy lit)               `thenTc_`
 932     returnTc (HsLit lit, emptyLIE)
 933 \end{code}
 934
 935
 936 %************************************************************************
 937 %*                                                                      *
 938 \subsection{Errors and contexts}
 939 %*                                                                      *
 940 %************************************************************************
 941
 942 Mini-utils:
 943
 944 Boring and alphabetical:
 945 \begin{code}
 946 arithSeqCtxt expr
 947   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 948
 949 caseCtxt expr
 950   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 951
 952 caseScrutCtxt expr
 953   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 954
 955 exprSigCtxt expr
 956   = hang (ptext SLIT("In an expression with a type signature:"))
 957          4 (ppr expr)
 958
 959 listCtxt expr
 960   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
 961
 962 predCtxt expr
 963   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 964
 965 sectionRAppCtxt expr
 966   = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
 967
 968 sectionLAppCtxt expr
 969   = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
 970
 971 funAppCtxt fun arg arg_no
 972   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
 973                     quotes (ppr fun) <> text ", namely"])
 974          4 (quotes (ppr arg))
 975
 976 wrongArgsCtxt too_many_or_few fun args
 977   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
 978                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
 979                     <+> ptext SLIT("arguments in the call"))
 980          4 (parens (ppr the_app))
 981   where
 982     the_app = foldl HsApp fun args      -- Used in error messages
 983
 984 appCtxt fun args
 985   = ptext SLIT("In the application") <+> quotes (ppr the_app)
 986   where
 987     the_app = foldl HsApp fun args      -- Used in error messages
 988
 989 lurkingRank2Err fun fun_ty
 990   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
 991          4 (vcat [ptext SLIT("It is applied to too few arguments"),
 992                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
 993
 994 badFieldsUpd rbinds
 995   = hang (ptext SLIT("No constructor has all these fields:"))
 996          4 (pprQuotedList fields)
 997   where
 998     fields = [field | (field, _, _) <- rbinds]
 999
1000 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1001 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1002
1003 notSelector field
1004   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1005
1006 missingStrictFieldCon :: Name -> FieldLabel -> SDoc
1007 missingStrictFieldCon con field
1008   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1009           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1010
1011 missingFieldCon :: Name -> FieldLabel -> SDoc
1012 missingFieldCon con field
1013   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1014           ptext SLIT("is not initialised")]
1015 \end{code}