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