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