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