ghc/compiler/typecheck/TcExpr.lhs

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