ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           HsMatchContext(..), mkMonoBind
  13                         )
  14 import RnHsSyn          ( RenamedHsExpr, RenamedRecordBinds )
  15 import TcHsSyn          ( TcExpr, TcRecordBinds, mkHsLet )
  16
  17 import TcMonad
  18 import BasicTypes       ( RecFlag(..) )
  19
  20 import Inst             ( InstOrigin(..),
  21                           LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
  22                           newOverloadedLit, newMethod, newIPDict,
  23                           newDicts,
  24                           instToId, tcInstId
  25                         )
  26 import TcBinds          ( tcBindsAndThen )
  27 import TcEnv            ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
  28                           tcLookupTyCon, tcLookupDataCon, tcLookupId,
  29                           tcExtendGlobalTyVars, tcLookupSyntaxName
  30                         )
  31 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  32 import TcMonoType       ( tcHsSigType, checkSigTyVars, sigCtxt )
  33 import TcPat            ( badFieldCon, simpleHsLitTy )
  34 import TcSimplify       ( tcSimplifyCheck, tcSimplifyIPs )
  35 import TcType           ( TcType, TcTauType,
  36                           tcInstTyVars, tcInstType,
  37                           newTyVarTy, newTyVarTys, zonkTcType )
  38
  39 import FieldLabel       ( fieldLabelName, fieldLabelType, fieldLabelTyCon )
  40 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  41 import DataCon          ( dataConFieldLabels, dataConSig,
  42                           dataConStrictMarks, StrictnessMark(..)
  43                         )
  44 import Name             ( Name )
  45 import Type             ( mkFunTy, mkAppTy, mkTyConTy,
  46                           splitFunTy_maybe, splitFunTys,
  47                           mkTyConApp, splitSigmaTy, mkClassPred,
  48                           isTauTy, tyVarsOfType, tyVarsOfTypes,
  49                           isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
  50                           liftedTypeKind, openTypeKind, mkArrowKind,
  51                           tidyOpenType
  52                         )
  53 import TyCon            ( TyCon, tyConTyVars )
  54 import Subst            ( mkTopTyVarSubst, substTheta, substTy )
  55 import VarSet           ( elemVarSet )
  56 import TysWiredIn       ( boolTy, mkListTy, listTyCon )
  57 import TcUnify          ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
  58 import PrelNames        ( cCallableClassName,
  59                           cReturnableClassName,
  60                           enumFromName, enumFromThenName, negateName,
  61                           enumFromToName, enumFromThenToName,
  62                           thenMName, failMName, returnMName, ioTyConName
  63                         )
  64 import Outputable
  65 import Maybes           ( maybeToBool, mapMaybe )
  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 | isSigmaTy 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) = splitFunTys con_tau
 383         (tycon, ty_args, _) = splitAlgTyConApp record_ty
 384     in
 385     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
 386     unifyTauTy res_ty record_ty          `thenTc_`
 387
 388         -- Check that the record bindings match the constructor
 389         -- con_name is syntactically constrained to be a data constructor
 390     tcLookupDataCon con_name    `thenTc` \ data_con ->
 391     let
 392         bad_fields = badFields rbinds data_con
 393     in
 394     if not (null bad_fields) then
 395         mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields   `thenNF_Tc_`
 396         failTc  -- Fail now, because tcRecordBinds will crash on a bad field
 397     else
 398
 399         -- Typecheck the record bindings
 400     tcRecordBinds tycon ty_args rbinds          `thenTc` \ (rbinds', rbinds_lie) ->
 401
 402     let
 403       missing_s_fields = missingStrictFields rbinds data_con
 404     in
 405     checkTcM (null missing_s_fields)
 406         (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
 407          returnNF_Tc ())  `thenNF_Tc_`
 408     let
 409       missing_fields = missingFields rbinds data_con
 410     in
 411     doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
 412     checkTcM (not (warn && not (null missing_fields)))
 413         (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
 414          returnNF_Tc ())  `thenNF_Tc_`
 415
 416     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 417
 418 -- The main complication with RecordUpd is that we need to explicitly
 419 -- handle the *non-updated* fields.  Consider:
 420 --
 421 --      data T a b = MkT1 { fa :: a, fb :: b }
 422 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 423 --                 | MkT3 { fd :: a }
 424 --
 425 --      upd :: T a b -> c -> T a c
 426 --      upd t x = t { fb = x}
 427 --
 428 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 429 -- because upd should be equivalent to:
 430 --
 431 --      upd t x = case t of
 432 --                      MkT1 p q -> MkT1 p x
 433 --                      MkT2 a b -> MkT2 p b
 434 --                      MkT3 d   -> error ...
 435 --
 436 -- So we need to give a completely fresh type to the result record,
 437 -- and then constrain it by the fields that are *not* updated ("p" above).
 438 --
 439 -- Note that because MkT3 doesn't contain all the fields being updated,
 440 -- its RHS is simply an error, so it doesn't impose any type constraints
 441 --
 442 -- All this is done in STEP 4 below.
 443
 444 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 445   = tcAddErrCtxt (recordUpdCtxt expr)           $
 446
 447         -- STEP 0
 448         -- Check that the field names are really field names
 449     ASSERT( not (null rbinds) )
 450     let
 451         field_names = [field_name | (field_name, _, _) <- rbinds]
 452     in
 453     mapNF_Tc tcLookupGlobal_maybe field_names           `thenNF_Tc` \ maybe_sel_ids ->
 454     let
 455         bad_guys = [ addErrTc (notSelector field_name)
 456                    | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 457                       case maybe_sel_id of
 458                         Just (AnId sel_id) -> not (isRecordSelector sel_id)
 459                         other              -> True
 460                    ]
 461     in
 462     checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc)   `thenTc_`
 463
 464         -- STEP 1
 465         -- Figure out the tycon and data cons from the first field name
 466     let
 467         (Just (AnId sel_id) : _)  = maybe_sel_ids
 468         (_, _, tau)               = splitSigmaTy (idType sel_id)        -- Selectors can be overloaded
 469                                                                         -- when the data type has a context
 470         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 471         (tycon, _, data_cons)       = splitAlgTyConApp data_ty
 472         (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
 473     in
 474     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 475
 476         -- STEP 2
 477         -- Check that at least one constructor has all the named fields
 478         -- i.e. has an empty set of bad fields returned by badFields
 479     checkTc (any (null . badFields rbinds) data_cons)
 480             (badFieldsUpd rbinds)               `thenTc_`
 481
 482         -- STEP 3
 483         -- Typecheck the update bindings.
 484         -- (Do this after checking for bad fields in case there's a field that
 485         --  doesn't match the constructor.)
 486     let
 487         result_record_ty = mkTyConApp tycon result_inst_tys
 488     in
 489     unifyTauTy res_ty result_record_ty          `thenTc_`
 490     tcRecordBinds tycon result_inst_tys rbinds  `thenTc` \ (rbinds', rbinds_lie) ->
 491
 492         -- STEP 4
 493         -- Use the un-updated fields to find a vector of booleans saying
 494         -- which type arguments must be the same in updatee and result.
 495         --
 496         -- WARNING: this code assumes that all data_cons in a common tycon
 497         -- have FieldLabels abstracted over the same tyvars.
 498     let
 499         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 500         con_field_lbls_s    = map dataConFieldLabels data_cons
 501
 502                 -- A constructor is only relevant to this process if
 503                 -- it contains all the fields that are being updated
 504         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 505         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 506
 507         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 508         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 509
 510         mk_inst_ty (tyvar, result_inst_ty)
 511           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 512           | otherwise                               = newTyVarTy liftedTypeKind -- Fresh type
 513     in
 514     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 515
 516         -- STEP 5
 517         -- Typecheck the expression to be updated
 518     let
 519         record_ty = mkTyConApp tycon inst_tys
 520     in
 521     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 522
 523         -- STEP 6
 524         -- Figure out the LIE we need.  We have to generate some
 525         -- dictionaries for the data type context, since we are going to
 526         -- do some construction.
 527         --
 528         -- What dictionaries do we need?  For the moment we assume that all
 529         -- data constructors have the same context, and grab it from the first
 530         -- constructor.  If they have varying contexts then we'd have to
 531         -- union the ones that could participate in the update.
 532     let
 533         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 534         inst_env = mkTopTyVarSubst tyvars result_inst_tys
 535         theta'   = 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  = tcSetErrCtxt (exprSigCtxt in_expr)   $
 601    tcHsSigType  poly_ty         `thenTc` \ sig_tc_ty ->
 602
 603    if not (isSigmaTy sig_tc_ty) then
 604         -- Easy case
 605         unifyTauTy sig_tc_ty res_ty     `thenTc_`
 606         tcMonoExpr expr sig_tc_ty
 607
 608    else -- Signature is polymorphic
 609         tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 610
 611             -- Now match the signature type with res_ty.
 612             -- We must not do this earlier, because res_ty might well
 613             -- mention variables free in the environment, and we'd get
 614             -- bogus complaints about not being able to for-all the
 615             -- sig_tyvars
 616         unifyTauTy res_ty expr_ty                       `thenTc_`
 617
 618             -- If everything is ok, return the stuff unchanged, except for
 619             -- the effect of any substutions etc.  We simply discard the
 620             -- result of the tcSimplifyCheck (inside tcPolyExpr), except for any default
 621             -- resolution it may have done, which is recorded in the
 622             -- substitution.
 623         returnTc (expr, lie)
 624 \end{code}
 625
 626 Implicit Parameter bindings.
 627
 628 \begin{code}
 629 tcMonoExpr (HsWith expr binds) res_ty
 630   = tcMonoExpr expr res_ty                      `thenTc` \ (expr', expr_lie) ->
 631     mapAndUnzipTc tcIPBind binds                `thenTc` \ (pairs, bind_lies) ->
 632     tcSimplifyIPs (map fst binds) expr_lie      `thenTc` \ (expr_lie', dict_binds) ->
 633     let
 634         binds' = [(instToId ip, rhs) | (ip,rhs) <- pairs]
 635         expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
 636     in
 637     returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies)
 638
 639 tcIPBind (name, expr)
 640   = newTyVarTy openTypeKind             `thenTc` \ ty ->
 641     tcGetSrcLoc                         `thenTc` \ loc ->
 642     newIPDict (IPBind name) name ty     `thenNF_Tc` \ ip ->
 643     tcMonoExpr expr ty                  `thenTc` \ (expr', lie) ->
 644     returnTc ((ip, expr'), lie)
 645 \end{code}
 646
 647 %************************************************************************
 648 %*                                                                      *
 649 \subsection{@tcApp@ typchecks an application}
 650 %*                                                                      *
 651 %************************************************************************
 652
 653 \begin{code}
 654
 655 tcApp :: RenamedHsExpr -> [RenamedHsExpr]       -- Function and args
 656       -> TcType                                 -- Expected result type of application
 657       -> TcM (TcExpr, [TcExpr],         -- Translated fun and args
 658                 LIE)
 659
 660 tcApp fun args res_ty
 661   =     -- First type-check the function
 662     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 663
 664     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 665         split_fun_ty fun_ty (length args)
 666     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 667
 668         -- Unify with expected result before type-checking the args
 669         -- This is when we might detect a too-few args situation
 670     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 671        unifyTauTy res_ty actual_result_ty
 672     )                                                   `thenTc_`
 673
 674         -- Now typecheck the args
 675     mapAndUnzipTc (tcArg fun)
 676           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 677
 678     -- Check that the result type doesn't have any nested for-alls.
 679     -- For example, a "build" on its own is no good; it must be applied to something.
 680     checkTc (isTauTy actual_result_ty)
 681             (lurkingRank2Err fun actual_result_ty)      `thenTc_`
 682
 683     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 684
 685
 686 -- If an error happens we try to figure out whether the
 687 -- function has been given too many or too few arguments,
 688 -- and say so
 689 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 690   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 691     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 692     let
 693       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 694       (env2, act_ty'') = tidyOpenType env1     act_ty'
 695       (exp_args, _) = splitFunTys exp_ty''
 696       (act_args, _) = splitFunTys act_ty''
 697
 698       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 699               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 700               | otherwise                         = appCtxt fun args
 701     in
 702     returnNF_Tc (env2, message)
 703
 704
 705 split_fun_ty :: TcType          -- The type of the function
 706              -> Int                     -- Number of arguments
 707              -> TcM ([TcType],  -- Function argument types
 708                        TcType)  -- Function result types
 709
 710 split_fun_ty fun_ty 0
 711   = returnTc ([], fun_ty)
 712
 713 split_fun_ty fun_ty n
 714   =     -- Expect the function to have type A->B
 715     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 716     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 717     returnTc (arg_ty:arg_tys, final_res_ty)
 718 \end{code}
 719
 720 \begin{code}
 721 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 722       -> (RenamedHsExpr, TcType, Int)   -- Actual argument and expected arg type
 723       -> TcM (TcExpr, LIE)      -- Resulting argument and LIE
 724
 725 tcArg the_fun (arg, expected_arg_ty, arg_no)
 726   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 727     tcExpr arg expected_arg_ty
 728 \end{code}
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733 \subsection{@tcId@ typchecks an identifier occurrence}
 734 %*                                                                      *
 735 %************************************************************************
 736
 737 \begin{code}
 738 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
 739 tcId name       -- Look up the Id and instantiate its type
 740   = tcLookupId name                     `thenNF_Tc` \ id ->
 741     tcInstId id
 742 \end{code}
 743
 744 Typecheck expression which in most cases will be an Id.
 745
 746 \begin{code}
 747 tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
 748 tcExpr_id (HsVar name) = tcId name
 749 tcExpr_id expr         = newTyVarTy openTypeKind        `thenNF_Tc` \ id_ty ->
 750                          tcMonoExpr expr id_ty  `thenTc`    \ (expr', lie_id) ->
 751                          returnTc (expr', lie_id, id_ty)
 752 \end{code}
 753
 754
 755 %************************************************************************
 756 %*                                                                      *
 757 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 758 %*                                                                      *
 759 %************************************************************************
 760
 761 \begin{code}
 762 tcDoStmts do_or_lc stmts src_loc res_ty
 763   =     -- get the Monad and MonadZero classes
 764         -- create type consisting of a fresh monad tyvar
 765     ASSERT( not (null stmts) )
 766     tcAddSrcLoc src_loc $
 767
 768         -- If it's a comprehension we're dealing with,
 769         -- force it to be a list comprehension.
 770         -- (as of Haskell 98, monad comprehensions are no more.)
 771     (case do_or_lc of
 772        ListComp -> unifyListTy res_ty                   `thenTc` \ elt_ty ->
 773                    returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
 774
 775        _        -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)       `thenNF_Tc` \ m_ty ->
 776                    newTyVarTy liftedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 777                    unifyTauTy res_ty (mkAppTy m_ty elt_ty)                              `thenTc_`
 778                    returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
 779     )                                                   `thenNF_Tc` \ (tc_ty, m_ty) ->
 780
 781     tcStmts do_or_lc m_ty stmts                         `thenTc`   \ (stmts', stmts_lie) ->
 782
 783         -- Build the then and zero methods in case we need them
 784         -- It's important that "then" and "return" appear just once in the final LIE,
 785         -- not only for typechecker efficiency, but also because otherwise during
 786         -- simplification we end up with silly stuff like
 787         --      then = case d of (t,r) -> t
 788         --      then = then
 789         -- where the second "then" sees that it already exists in the "available" stuff.
 790         --
 791     tcLookupGlobalId returnMName                `thenNF_Tc` \ return_sel_id ->
 792     tcLookupGlobalId thenMName                  `thenNF_Tc` \ then_sel_id ->
 793     tcLookupGlobalId failMName                  `thenNF_Tc` \ fail_sel_id ->
 794     newMethod DoOrigin return_sel_id [tc_ty]    `thenNF_Tc` \ return_inst ->
 795     newMethod DoOrigin then_sel_id   [tc_ty]    `thenNF_Tc` \ then_inst ->
 796     newMethod DoOrigin fail_sel_id   [tc_ty]    `thenNF_Tc` \ fail_inst ->
 797     let
 798         monad_lie = mkLIE [return_inst, then_inst, fail_inst]
 799     in
 800     returnTc (HsDoOut do_or_lc stmts'
 801                       (instToId return_inst) (instToId then_inst) (instToId fail_inst)
 802                       res_ty src_loc,
 803               stmts_lie `plusLIE` monad_lie)
 804 \end{code}
 805
 806
 807 %************************************************************************
 808 %*                                                                      *
 809 \subsection{Record bindings}
 810 %*                                                                      *
 811 %************************************************************************
 812
 813 Game plan for record bindings
 814 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 815 1. Find the TyCon for the bindings, from the first field label.
 816
 817 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 818
 819 For each binding field = value
 820
 821 3. Instantiate the field type (from the field label) using the type
 822    envt from step 2.
 823
 824 4  Type check the value using tcArg, passing the field type as
 825    the expected argument type.
 826
 827 This extends OK when the field types are universally quantified.
 828
 829
 830 \begin{code}
 831 tcRecordBinds
 832         :: TyCon                -- Type constructor for the record
 833         -> [TcType]             -- Args of this type constructor
 834         -> RenamedRecordBinds
 835         -> TcM (TcRecordBinds, LIE)
 836
 837 tcRecordBinds tycon ty_args rbinds
 838   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 839     returnTc (rbinds', plusLIEs lies)
 840   where
 841     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 842
 843     do_bind (field_lbl_name, rhs, pun_flag)
 844       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 845         let
 846             field_lbl = recordSelectorFieldLabel sel_id
 847             field_ty  = substTy tenv (fieldLabelType field_lbl)
 848         in
 849         ASSERT( isRecordSelector sel_id )
 850                 -- This lookup and assertion will surely succeed, because
 851                 -- we check that the fields are indeed record selectors
 852                 -- before calling tcRecordBinds
 853         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 854                 -- The caller of tcRecordBinds has already checked
 855                 -- that all the fields come from the same type
 856
 857         tcPolyExpr rhs field_ty         `thenTc` \ (rhs', lie, _, _, _) ->
 858
 859         returnTc ((sel_id, rhs', pun_flag), lie)
 860
 861 badFields rbinds data_con
 862   = [field_name | (field_name, _, _) <- rbinds,
 863                   not (field_name `elem` field_names)
 864     ]
 865   where
 866     field_names = map fieldLabelName (dataConFieldLabels data_con)
 867
 868 missingStrictFields rbinds data_con
 869   = [ fn | fn <- strict_field_names,
 870                  not (fn `elem` field_names_used)
 871     ]
 872   where
 873     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 874     strict_field_names = mapMaybe isStrict field_info
 875
 876     isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
 877     isStrict _                  = Nothing
 878
 879     field_info = zip (dataConFieldLabels data_con)
 880                      (dataConStrictMarks data_con)
 881
 882 missingFields rbinds data_con
 883   = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
 884   where
 885     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 886
 887      -- missing strict fields have already been flagged as
 888      -- being so, so leave them out here.
 889     non_strict_field_names = mapMaybe isn'tStrict field_info
 890
 891     isn'tStrict (fl, MarkedStrict) = Nothing
 892     isn'tStrict (fl, _)            = Just (fieldLabelName fl)
 893
 894     field_info = zip (dataConFieldLabels data_con)
 895                      (dataConStrictMarks data_con)
 896
 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 \begin{code}
 947 pp_nest_hang :: String -> SDoc -> SDoc
 948 pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
 949 \end{code}
 950
 951 Boring and alphabetical:
 952 \begin{code}
 953 arithSeqCtxt expr
 954   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 955
 956 caseCtxt expr
 957   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 958
 959 caseScrutCtxt expr
 960   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 961
 962 exprSigCtxt expr
 963   = hang (ptext SLIT("In an expression with a type signature:"))
 964          4 (ppr expr)
 965
 966 listCtxt expr
 967   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
 968
 969 predCtxt expr
 970   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 971
 972 sectionRAppCtxt expr
 973   = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
 974
 975 sectionLAppCtxt expr
 976   = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
 977
 978 funAppCtxt fun arg arg_no
 979   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
 980                     quotes (ppr fun) <> text ", namely"])
 981          4 (quotes (ppr arg))
 982
 983 wrongArgsCtxt too_many_or_few fun args
 984   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
 985                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
 986                     <+> ptext SLIT("arguments in the call"))
 987          4 (parens (ppr the_app))
 988   where
 989     the_app = foldl HsApp fun args      -- Used in error messages
 990
 991 appCtxt fun args
 992   = ptext SLIT("In the application") <+> quotes (ppr the_app)
 993   where
 994     the_app = foldl HsApp fun args      -- Used in error messages
 995
 996 lurkingRank2Err fun fun_ty
 997   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
 998          4 (vcat [ptext SLIT("It is applied to too few arguments"),
 999                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
1000
1001 badFieldsUpd rbinds
1002   = hang (ptext SLIT("No constructor has all these fields:"))
1003          4 (pprQuotedList fields)
1004   where
1005     fields = [field | (field, _, _) <- rbinds]
1006
1007 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1008 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1009
1010 notSelector field
1011   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1012
1013 missingStrictFieldCon :: Name -> Name -> SDoc
1014 missingStrictFieldCon con field
1015   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1016           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1017
1018 missingFieldCon :: Name -> Name -> SDoc
1019 missingFieldCon con field
1020   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1021           ptext SLIT("is not initialised")]
1022 \end{code}