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