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