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