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 res_ty id_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 scrut matches src_loc) res_ty
 310   = tcAddSrcLoc src_loc                 $
 311     tcAddErrCtxt (caseCtxt in_expr)     $
 312
 313         -- Typecheck the case alternatives first.
 314         -- The case patterns tend to give good type info to use
 315         -- when typechecking the scrutinee.  For example
 316         --      case (map f) of
 317         --        (x:xs) -> ...
 318         -- will report that map is applied to too few arguments
 319
 320     tcMatchesCase res_ty matches        `thenTc`    \ (scrut_ty, matches', lie2) ->
 321
 322     tcAddErrCtxt (caseScrutCtxt scrut)  (
 323       tcExpr scrut scrut_ty
 324     )                                   `thenTc`    \ (scrut',lie1) ->
 325
 326     returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 327
 328 tcExpr (HsIf pred b1 b2 src_loc) res_ty
 329   = tcAddSrcLoc src_loc $
 330     tcAddErrCtxt (predCtxt pred) (
 331     tcExpr pred boolTy  )       `thenTc`    \ (pred',lie1) ->
 332
 333     tcExpr b1 res_ty            `thenTc`    \ (b1',lie2) ->
 334     tcExpr b2 res_ty            `thenTc`    \ (b2',lie3) ->
 335     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
 336 \end{code}
 337
 338 \begin{code}
 339 tcExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
 340   = tcDoStmts do_or_lc stmts src_loc res_ty
 341 \end{code}
 342
 343 \begin{code}
 344 tcExpr in_expr@(ExplicitList exprs) res_ty      -- Non-empty list
 345   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 346     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 347     returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
 348   where
 349     tc_elt elt_ty expr
 350       = tcAddErrCtxt (listCtxt expr) $
 351         tcExpr expr elt_ty
 352
 353 tcExpr (ExplicitTuple exprs) res_ty
 354   = unifyTupleTy (length exprs) res_ty          `thenTc` \ arg_tys ->
 355     mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
 356                (exprs `zip` arg_tys) -- we know they're of equal length.
 357                                                                  `thenTc` \ (exprs', lies) ->
 358     returnTc (ExplicitTuple exprs', plusLIEs lies)
 359
 360 tcExpr (RecordCon con_name _ rbinds) res_ty
 361   = tcLookupGlobalValue con_name        `thenNF_Tc` \ con_id ->
 362     tcId con_name                       `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 363     let
 364         (_, record_ty) = splitFunTys con_tau
 365     in
 366         -- Con is syntactically constrained to be a data constructor
 367     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
 368     unifyTauTy res_ty record_ty          `thenTc_`
 369
 370         -- Check that the record bindings match the constructor
 371     let
 372         bad_fields = badFields rbinds con_id
 373     in
 374     checkTc (null bad_fields) (badFieldsCon con_id bad_fields)  `thenTc_`
 375
 376         -- Typecheck the record bindings
 377         -- (Do this after checkRecordFields in case there's a field that
 378         --  doesn't match the constructor.)
 379     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 380
 381     returnTc (RecordCon (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 382
 383
 384 -- The main complication with RecordUpd is that we need to explicitly
 385 -- handle the *non-updated* fields.  Consider:
 386 --
 387 --      data T a b = MkT1 { fa :: a, fb :: b }
 388 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 389 --                 | MkT3 { fd :: a }
 390 --
 391 --      upd :: T a b -> c -> T a c
 392 --      upd t x = t { fb = x}
 393 --
 394 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 395 -- because upd should be equivalent to:
 396 --
 397 --      upd t x = case t of
 398 --                      MkT1 p q -> MkT1 p x
 399 --                      MkT2 a b -> MkT2 p b
 400 --                      MkT3 d   -> error ...
 401 --
 402 -- So we need to give a completely fresh type to the result record,
 403 -- and then constrain it by the fields that are *not* updated ("p" above).
 404 --
 405 -- Note that because MkT3 doesn't contain all the fields being updated,
 406 -- its RHS is simply an error, so it doesn't impose any type constraints
 407 --
 408 -- All this is done in STEP 4 below.
 409
 410 tcExpr (RecordUpd record_expr rbinds) res_ty
 411   = tcAddErrCtxt recordUpdCtxt                  $
 412
 413         -- STEP 1
 414         -- Figure out the tycon and data cons from the first field name
 415     ASSERT( not (null rbinds) )
 416     let
 417         ((first_field_name, _, _) : rest) = rbinds
 418     in
 419     tcLookupGlobalValueMaybe first_field_name   `thenNF_Tc` \ maybe_sel_id ->
 420     (case maybe_sel_id of
 421         Just sel_id | isRecordSelector sel_id -> returnTc sel_id
 422         other                                 -> failWithTc (notSelector first_field_name)
 423     )                                           `thenTc` \ sel_id ->
 424     let
 425         (_, tau)                  = splitForAllTys (idType sel_id)
 426         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 427         (tycon, _, data_cons)     = splitAlgTyConApp data_ty
 428         (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 429     in
 430     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 431
 432         -- STEP 2
 433         -- Check for bad fields
 434     checkTc (any (null . badFields rbinds) data_cons)
 435             (badFieldsUpd rbinds)               `thenTc_`
 436         -- STEP 3
 437         -- Typecheck the update bindings.
 438         -- (Do this after checking for bad fields in case there's a field that
 439         --  doesn't match the constructor.)
 440     let
 441         result_record_ty = mkTyConApp tycon result_inst_tys
 442     in
 443     unifyTauTy res_ty result_record_ty          `thenTc_`
 444     tcRecordBinds result_record_ty rbinds       `thenTc` \ (rbinds', rbinds_lie) ->
 445
 446         -- STEP 4
 447         -- Use the un-updated fields to find a vector of booleans saying
 448         -- which type arguments must be the same in updatee and result.
 449         --
 450         -- WARNING: this code assumes that all data_cons in a common tycon
 451         -- have FieldLabels abstracted over the same tyvars.
 452     let
 453         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
 454         con_field_lbls_s    = map dataConFieldLabels data_cons
 455
 456                 -- A constructor is only relevant to this process if
 457                 -- it contains all the fields that are being updated
 458         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 459         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 460
 461         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 462         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 463
 464         mk_inst_ty (tyvar, result_inst_ty)
 465           | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty        -- Same as result type
 466           | otherwise                               = newTyVarTy mkBoxedTypeKind        -- Fresh type
 467     in
 468     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 469
 470         -- STEP 5
 471         -- Typecheck the expression to be updated
 472     let
 473         record_ty = mkTyConApp tycon inst_tys
 474     in
 475     tcExpr record_expr record_ty                        `thenTc`    \ (record_expr', record_lie) ->
 476
 477         -- STEP 6
 478         -- Figure out the LIE we need.  We have to generate some
 479         -- dictionaries for the data type context, since we are going to
 480         -- do some construction.
 481         --
 482         -- What dictionaries do we need?  For the moment we assume that all
 483         -- data constructors have the same context, and grab it from the first
 484         -- constructor.  If they have varying contexts then we'd have to
 485         -- union the ones that could participate in the update.
 486     let
 487         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 488         inst_env = zipTyVarEnv tyvars result_inst_tys
 489     in
 490     tcInstTheta inst_env theta                  `thenNF_Tc` \ theta' ->
 491     newDicts RecordUpdOrigin theta'             `thenNF_Tc` \ (con_lie, dicts) ->
 492
 493         -- Phew!
 494     returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
 495               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
 496
 497 tcExpr (ArithSeqIn seq@(From expr)) res_ty
 498   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 499     tcExpr expr elt_ty                        `thenTc` \ (expr', lie1) ->
 500
 501     tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
 502     newMethod (ArithSeqOrigin seq)
 503               (RealId sel_id) [elt_ty]          `thenNF_Tc` \ (lie2, enum_from_id) ->
 504
 505     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 506               lie1 `plusLIE` lie2)
 507
 508 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 509   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 510     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 511     tcExpr expr1 elt_ty         `thenTc`    \ (expr1',lie1) ->
 512     tcExpr expr2 elt_ty         `thenTc`    \ (expr2',lie2) ->
 513     tcLookupGlobalValueByKey enumFromThenClassOpKey     `thenNF_Tc` \ sel_id ->
 514     newMethod (ArithSeqOrigin seq)
 515               (RealId sel_id) [elt_ty]                  `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 516
 517     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 518                            (FromThen expr1' expr2'),
 519               lie1 `plusLIE` lie2 `plusLIE` lie3)
 520
 521 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 522   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 523     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 524     tcExpr expr1 elt_ty         `thenTc`    \ (expr1',lie1) ->
 525     tcExpr expr2 elt_ty         `thenTc`    \ (expr2',lie2) ->
 526     tcLookupGlobalValueByKey enumFromToClassOpKey       `thenNF_Tc` \ sel_id ->
 527     newMethod (ArithSeqOrigin seq)
 528               (RealId sel_id) [elt_ty]          `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 529
 530     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 531                           (FromTo expr1' expr2'),
 532               lie1 `plusLIE` lie2 `plusLIE` lie3)
 533
 534 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 535   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 536     unifyListTy  res_ty         `thenTc`    \ elt_ty ->
 537     tcExpr expr1 elt_ty         `thenTc`    \ (expr1',lie1) ->
 538     tcExpr expr2 elt_ty         `thenTc`    \ (expr2',lie2) ->
 539     tcExpr expr3 elt_ty         `thenTc`    \ (expr3',lie3) ->
 540     tcLookupGlobalValueByKey enumFromThenToClassOpKey   `thenNF_Tc` \ sel_id ->
 541     newMethod (ArithSeqOrigin seq)
 542               (RealId sel_id) [elt_ty]                  `thenNF_Tc` \ (lie4, eft_id) ->
 543
 544     returnTc (ArithSeqOut (HsVar eft_id)
 545                            (FromThenTo expr1' expr2' expr3'),
 546               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection{Expressions type signatures}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 \begin{code}
 556 tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 557  = tcSetErrCtxt (exprSigCtxt in_expr)   $
 558    tcHsType  poly_ty            `thenTc` \ sigma_sig ->
 559
 560         -- Check the tau-type part
 561    tcInstSigType sigma_sig              `thenNF_Tc` \ sigma_sig' ->
 562    let
 563         (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
 564    in
 565
 566         -- Type check the expression, expecting the signature type
 567    tcExtendGlobalTyVars sig_tyvars' (
 568            tcExpr expr sig_tau'
 569    )                                            `thenTc` \ (texpr, lie) ->
 570
 571         -- Check the type variables of the signature,
 572         -- *after* typechecking the expression
 573    checkSigTyVars sig_tyvars' sig_tau'          `thenTc` \ zonked_sig_tyvars ->
 574
 575         -- Check overloading constraints
 576    newDicts SignatureOrigin sig_theta'          `thenNF_Tc` \ (sig_dicts, _) ->
 577    tcAddErrCtxtM (sigThetaCtxt sig_dicts)       (
 578      tcSimplifyAndCheck
 579         (text "expr ty sig")
 580         (mkTyVarSet zonked_sig_tyvars)
 581         sig_dicts lie
 582    )                                            `thenTc_`
 583
 584         -- Now match the signature type with res_ty.
 585         -- We must not do this earlier, because res_ty might well
 586         -- mention variables free in the environment, and we'd get
 587         -- bogus complaints about not being able to for-all the
 588         -- sig_tyvars
 589    unifyTauTy sig_tau' res_ty           `thenTc_`
 590
 591         -- If everything is ok, return the stuff unchanged, except for
 592         -- the effect of any substutions etc.  We simply discard the
 593         -- result of the tcSimplifyAndCheck, except for any default
 594         -- resolution it may have done, which is recorded in the
 595         -- substitution.
 596    returnTc (texpr, lie)
 597
 598 \end{code}
 599
 600 Typecheck expression which in most cases will be an Id.
 601
 602 \begin{code}
 603 tcExpr_id :: RenamedHsExpr
 604            -> TcM s (TcExpr s,
 605                      LIE s,
 606                      TcType s)
 607 tcExpr_id id_expr
 608  = case id_expr of
 609         HsVar name -> tcId name                   `thenNF_Tc` \ stuff ->
 610                       returnTc stuff
 611         other      -> newTyVarTy mkTypeKind       `thenNF_Tc` \ id_ty ->
 612                       tcExpr id_expr id_ty        `thenTc`    \ (id_expr', lie_id) ->
 613                       returnTc (id_expr', lie_id, id_ty)
 614 \end{code}
 615
 616 %************************************************************************
 617 %*                                                                      *
 618 \subsection{@tcApp@ typchecks an application}
 619 %*                                                                      *
 620 %************************************************************************
 621
 622 \begin{code}
 623
 624 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 625       -> TcType s                           -- Expected result type of application
 626       -> TcM s (TcExpr s, [TcExpr s],       -- Translated fun and args
 627                 LIE s)
 628
 629 tcApp fun args res_ty
 630   =     -- First type-check the function
 631     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 632
 633     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 634         split_fun_ty fun_ty (length args)
 635     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 636
 637         -- Unify with expected result before type-checking the args
 638         -- This is when we might detect a too-few args situation
 639     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 640        unifyTauTy res_ty actual_result_ty
 641     )                                                   `thenTc_`
 642
 643         -- Now typecheck the args
 644     mapAndUnzipTc (tcArg fun)
 645           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 646
 647     -- Check that the result type doesn't have any nested for-alls.
 648     -- For example, a "build" on its own is no good; it must be applied to something.
 649     checkTc (isTauTy actual_result_ty)
 650             (lurkingRank2Err fun fun_ty)        `thenTc_`
 651
 652     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 653
 654
 655 -- If an error happens we try to figure out whether the
 656 -- function has been given too many or too few arguments,
 657 -- and say so
 658 checkArgsCtxt fun args expected_res_ty actual_res_ty
 659   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 660     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 661     let
 662       (exp_args, _) = splitFunTys exp_ty'
 663       (act_args, _) = splitFunTys act_ty'
 664       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 665               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 666               | otherwise                         = appCtxt fun args
 667     in
 668     returnNF_Tc message
 669
 670
 671 split_fun_ty :: TcType s                -- The type of the function
 672              -> Int                     -- Number of arguments
 673              -> TcM s ([TcType s],      -- Function argument types
 674                        TcType s)        -- Function result types
 675
 676 split_fun_ty fun_ty 0
 677   = returnTc ([], fun_ty)
 678
 679 split_fun_ty fun_ty n
 680   =     -- Expect the function to have type A->B
 681     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 682     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 683     returnTc (arg_ty:arg_tys, final_res_ty)
 684 \end{code}
 685
 686 \begin{code}
 687 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 688       -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
 689       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 690
 691 tcArg the_fun (arg, expected_arg_ty, arg_no)
 692   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 693     tcPolyExpr arg expected_arg_ty
 694
 695
 696 -- tcPolyExpr is like tcExpr, except that the expected type
 697 -- can be a polymorphic one.
 698 tcPolyExpr arg expected_arg_ty
 699   | not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
 700   =     -- The ordinary, non-rank-2 polymorphic case
 701     tcExpr arg expected_arg_ty
 702
 703   | otherwise
 704   =     -- Ha!  The argument type of the function is a for-all type,
 705         -- An example of rank-2 polymorphism.
 706
 707         -- No need to instantiate the argument type... it's must be the result
 708         -- of instantiating a function involving rank-2 polymorphism, so there
 709         -- isn't any danger of using the same tyvars twice
 710         -- The argument type shouldn't be overloaded type (hence ASSERT)
 711
 712         -- To ensure that the forall'd type variables don't get unified with each
 713         -- other or any other types, we make fresh *signature* type variables
 714         -- and unify them with the tyvars.
 715     tcInstSigTcType expected_arg_ty     `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 716     let
 717         (sig_theta, sig_tau) = splitRhoTy sig_rho
 718     in
 719         -- Type-check the arg and unify with expected type
 720     tcExpr arg sig_tau                          `thenTc` \ (arg', lie_arg) ->
 721
 722         -- Check that the arg_tyvars havn't been constrained
 723         -- The interesting bit here is that we must include the free variables
 724         -- of the expected arg ty.  Here's an example:
 725         --       runST (newVar True)
 726         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 727         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 728         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 729         -- So now s' isn't unconstrained because it's linked to a.
 730         -- Conclusion: include the free vars of the expected arg type in the
 731         -- list of "free vars" for the signature check.
 732
 733     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
 734     tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
 735
 736     checkSigTyVars sig_tyvars sig_tau           `thenTc` \ zonked_sig_tyvars ->
 737     newDicts Rank2Origin sig_theta              `thenNF_Tc` \ (sig_dicts, dict_ids) ->
 738         -- ToDo: better origin
 739
 740     tcAddErrCtxtM (sigThetaCtxt sig_dicts) $
 741     tcSimplifyAndCheck (text "rank2")
 742                 (mkTyVarSet zonked_sig_tyvars)
 743                 sig_dicts lie_arg               `thenTc` \ (free_insts, inst_binds) ->
 744
 745             -- This HsLet binds any Insts which came out of the simplification.
 746             -- It's a bit out of place here, but using AbsBind involves inventing
 747             -- a couple of new names which seems worse.
 748     returnTc ( TyLam zonked_sig_tyvars $
 749                    DictLam dict_ids $
 750                    HsLet (MonoBind inst_binds [] Recursive)
 751                    arg'
 752                  , free_insts
 753                  )
 754 \end{code}
 755
 756 %************************************************************************
 757 %*                                                                      *
 758 \subsection{@tcId@ typchecks an identifier occurrence}
 759 %*                                                                      *
 760 %************************************************************************
 761
 762 \begin{code}
 763 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
 764
 765 tcId name
 766   =     -- Look up the Id and instantiate its type
 767     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 768
 769     case maybe_local of
 770       Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
 771
 772       Nothing ->    tcLookupGlobalValue name             `thenNF_Tc` \ id ->
 773                     tcInstType emptyTyVarEnv (idType id) `thenNF_Tc` \ inst_ty ->
 774                     let
 775                         (tyvars, rho) = splitForAllTys inst_ty
 776                     in
 777                     instantiate_it2 (RealId id) tyvars rho
 778
 779   where
 780         -- The instantiate_it loop runs round instantiating the Id.
 781         -- It has to be a loop because we are now prepared to entertain
 782         -- types like
 783         --              f:: forall a. Eq a => forall b. Baz b => tau
 784         -- We want to instantiate this to
 785         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 786     instantiate_it tc_id_occ ty
 787       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 788         instantiate_it2 tc_id_occ tyvars rho
 789
 790     instantiate_it2 tc_id_occ tyvars rho
 791       = tcSplitRhoTy rho                                `thenNF_Tc` \ (theta, tau) ->
 792         if null theta then      -- Is it overloaded?
 793                 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 794         else
 795                 -- Yes, it's overloaded
 796         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 797                              tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
 798         instantiate_it meth_id tau                       `thenNF_Tc` \ (expr, lie2, final_tau) ->
 799         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 800
 801       where
 802         arg_tys       = mkTyVarTys tyvars
 803 \end{code}
 804
 805 %************************************************************************
 806 %*                                                                      *
 807 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 808 %*                                                                      *
 809 %************************************************************************
 810
 811 \begin{code}
 812 tcDoStmts do_or_lc stmts src_loc res_ty
 813   =     -- get the Monad and MonadZero classes
 814         -- create type consisting of a fresh monad tyvar
 815     ASSERT( not (null stmts) )
 816     tcAddSrcLoc src_loc $
 817     newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)    `thenNF_Tc` \ m ->
 818
 819     let
 820       tc_stmts []           = returnTc (([], error "tc_stmts"), emptyLIE)
 821       tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
 822                               tc_stmts stmts
 823
 824       combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
 825       combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
 826       combine_stmts stmt                _         ([], _) = panic "Bad last stmt tcDoStmts"
 827       combine_stmts stmt                _     (stmts, ty) = (stmt:stmts, ty)
 828     in
 829     tc_stmts stmts                      `thenTc`   \ ((stmts', result_ty), final_lie) ->
 830     unifyTauTy result_ty res_ty         `thenTc_`
 831
 832         -- Build the then and zero methods in case we need them
 833         -- It's important that "then" and "return" appear just once in the final LIE,
 834         -- not only for typechecker efficiency, but also because otherwise during
 835         -- simplification we end up with silly stuff like
 836         --      then = case d of (t,r) -> t
 837         --      then = then
 838         -- where the second "then" sees that it already exists in the "available" stuff.
 839         --
 840     tcLookupGlobalValueByKey returnMClassOpKey  `thenNF_Tc` \ return_sel_id ->
 841     tcLookupGlobalValueByKey thenMClassOpKey    `thenNF_Tc` \ then_sel_id ->
 842     tcLookupGlobalValueByKey zeroClassOpKey     `thenNF_Tc` \ zero_sel_id ->
 843     newMethod DoOrigin
 844               (RealId return_sel_id) [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 845     newMethod DoOrigin
 846               (RealId then_sel_id) [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 847     newMethod DoOrigin
 848               (RealId zero_sel_id) [m]          `thenNF_Tc` \ (zero_lie, zero_id) ->
 849     let
 850       monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
 851       perhaps_zero_lie | all failure_free stmts' = emptyLIE
 852                        | otherwise               = zero_lie
 853
 854       failure_free (BindStmt pat _ _) = failureFreePat pat
 855       failure_free (GuardStmt _ _)    = False
 856       failure_free other_stmt         = True
 857     in
 858     returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
 859               final_lie `plusLIE` monad_lie)
 860
 861 \end{code}
 862
 863 \begin{code}
 864 tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s))        -- This is tcExpr
 865                                 -- The sole, disgusting, reason for this parameter
 866                                 -- is to get the effect of polymorphic recursion
 867                                 -- ToDo: rm when booting with Haskell 1.3
 868        -> DoOrListComp
 869        -> (TcType s -> TcType s)                -- Relationship type of pat and rhs in pat <- rhs
 870        -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
 871        -> RenamedStmt
 872        -> TcM s (thing, LIE s)
 873        -> TcM s (thing, LIE s)
 874
 875 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
 876   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 877     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 878         newTyVarTy mkTypeKind                `thenNF_Tc` \ exp_ty ->
 879         tc_expr exp exp_ty                   `thenTc`    \ (exp', exp_lie) ->
 880         returnTc (ReturnStmt exp', exp_lie, m exp_ty)
 881     )                                   `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
 882     do_next                             `thenTc` \ (thing', thing_lie) ->
 883     returnTc (combine stmt' (Just stmt_ty) thing',
 884               stmt_lie `plusLIE` thing_lie)
 885
 886 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
 887   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 888     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 889     tcAddSrcLoc src_loc                 (
 890     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 891         tc_expr exp boolTy              `thenTc`    \ (exp', exp_lie) ->
 892         returnTc (GuardStmt exp' src_loc, exp_lie)
 893     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 894     do_next                             `thenTc` \ (thing', thing_lie) ->
 895     returnTc (combine stmt' Nothing thing',
 896               stmt_lie `plusLIE` thing_lie)
 897
 898 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
 899   = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
 900     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 901     tcAddSrcLoc src_loc                 (
 902     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 903         newTyVarTy mkTypeKind           `thenNF_Tc` \ tau ->
 904         let
 905             -- exp has type (m tau) for some tau (doesn't matter what)
 906             exp_ty = m tau
 907         in
 908         tc_expr exp exp_ty              `thenTc`    \ (exp', exp_lie) ->
 909         returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
 910     ))                                  `thenTc` \ (stmt',  stmt_lie, stmt_ty) ->
 911     do_next                             `thenTc` \ (thing', thing_lie) ->
 912     returnTc (combine stmt' (Just stmt_ty) thing',
 913               stmt_lie `plusLIE` thing_lie)
 914
 915 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
 916   = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 917     tcAddSrcLoc src_loc         (
 918     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 919         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 920         tc_expr exp (m pat_ty)          `thenTc`    \ (exp', exp_lie) ->
 921
 922         -- NB: the environment has been extended with the new binders
 923         -- which the rhs can't "see", but the renamer should have made
 924         -- sure that everything is distinct by now, so there's no problem.
 925         -- Putting the tcExpr before the newMonoIds messes up the nesting
 926         -- of error contexts, so I didn't  bother
 927
 928         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
 929     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 930     do_next                             `thenTc` \ (thing', thing_lie) ->
 931     returnTc (combine stmt' Nothing thing',
 932               stmt_lie `plusLIE` thing_lie)
 933
 934 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
 935      = tcBindsAndThen           -- No error context, but a binding group is
 936         combine'                -- rather a large thing for an error context anyway
 937         binds
 938         do_next
 939      where
 940         combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
 941 \end{code}
 942
 943 %************************************************************************
 944 %*                                                                      *
 945 \subsection{Record bindings}
 946 %*                                                                      *
 947 %************************************************************************
 948
 949 Game plan for record bindings
 950 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 951 For each binding
 952         field = value
 953 1. look up "field", to find its selector Id, which must have type
 954         forall a1..an. T a1 .. an -> tau
 955    where tau is the type of the field.
 956
 957 2. Instantiate this type
 958
 959 3. Unify the (T a1 .. an) part with the "expected result type", which
 960    is passed in.  This checks that all the field labels come from the
 961    same type.
 962
 963 4. Type check the value using tcArg, passing tau as the expected
 964    argument type.
 965
 966 This extends OK when the field types are universally quantified.
 967
 968 Actually, to save excessive creation of fresh type variables,
 969 we
 970
 971 \begin{code}
 972 tcRecordBinds
 973         :: TcType s             -- Expected type of whole record
 974         -> RenamedRecordBinds
 975         -> TcM s (TcRecordBinds s, LIE s)
 976
 977 tcRecordBinds expected_record_ty rbinds
 978   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 979     returnTc (rbinds', plusLIEs lies)
 980   where
 981     do_bind (field_label, rhs, pun_flag)
 982       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 983         ASSERT( isRecordSelector sel_id )
 984                 -- This lookup and assertion will surely succeed, because
 985                 -- we check that the fields are indeed record selectors
 986                 -- before calling tcRecordBinds
 987
 988         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 989
 990                 -- Record selectors all have type
 991                 --      forall a1..an.  T a1 .. an -> tau
 992         ASSERT( maybeToBool (splitFunTy_maybe tau) )
 993         let
 994                 -- Selector must have type RecordType -> FieldType
 995           Just (record_ty, field_ty) = splitFunTy_maybe tau
 996         in
 997         unifyTauTy expected_record_ty record_ty         `thenTc_`
 998         tcPolyExpr rhs field_ty                         `thenTc` \ (rhs', lie) ->
 999         returnTc ((RealId sel_id, rhs', pun_flag), lie)
1000
1001 badFields rbinds data_con
1002   = [field_name | (field_name, _, _) <- rbinds,
1003                   not (field_name `elem` field_names)
1004     ]
1005   where
1006     field_names = map fieldLabelName (dataConFieldLabels data_con)
1007 \end{code}
1008
1009 %************************************************************************
1010 %*                                                                      *
1011 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
1012 %*                                                                      *
1013 %************************************************************************
1014
1015 \begin{code}
1016 tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
1017
1018 tcExprs [] [] = returnTc ([], emptyLIE)
1019 tcExprs (expr:exprs) (ty:tys)
1020  = tcExpr  expr  ty             `thenTc` \ (expr',  lie1) ->
1021    tcExprs 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 label stuff = nest 2 (hang (text label) 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 stmtCtxt do_or_lc stmt
1070   = hang (ptext SLIT("In a") <+> whatever <> colon)
1071          4 (ppr stmt)
1072   where
1073     whatever = case do_or_lc of
1074                  ListComp -> ptext SLIT("list-comprehension qualifier")
1075                  DoStmt   -> ptext SLIT("do statement")
1076                  Guard    -> ptext SLIT("guard")
1077
1078 wrongArgsCtxt too_many_or_few fun args
1079   = hang (ptext SLIT("Probable cause:") <+> ppr fun
1080                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1081                     <+> ptext SLIT("arguments in the call"))
1082          4 (ppr the_app)
1083   where
1084     the_app = foldl HsApp fun args      -- Used in error messages
1085
1086 appCtxt fun args
1087   = ptext SLIT("In the application") <+> (ppr the_app)
1088   where
1089     the_app = foldl HsApp fun args      -- Used in error messages
1090
1091 lurkingRank2Err fun fun_ty
1092   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1093          4 (vcat [ptext SLIT("It is applied to too few arguments"),
1094                   ptext SLIT("so that the result type has for-alls in it")])
1095
1096 rank2ArgCtxt arg expected_arg_ty
1097   = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1098
1099 badFieldsUpd rbinds
1100   = hang (ptext SLIT("No constructor has all these fields:"))
1101          4 (pprQuotedList fields)
1102   where
1103     fields = [field | (field, _, _) <- rbinds]
1104
1105 recordUpdCtxt = ptext SLIT("In a record update construct")
1106
1107 badFieldsCon con fields
1108   = hsep [ptext SLIT("Constructor"),            ppr con,
1109            ptext SLIT("does not have field(s):"), pprQuotedList fields]
1110
1111 notSelector field
1112   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1113 \end{code}