ghc/compiler/typecheck/TcExpr.lhs

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