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