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 fun)
 622           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 623
 624     -- Check that the result type doesn't have any nested for-alls.
 625     -- For example, a "build" on its own is no good; it must be applied to something.
 626     checkTc (isTauTy actual_result_ty)
 627             (lurkingRank2Err fun fun_ty)        `thenTc_`
 628
 629     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 630
 631
 632 split_fun_ty :: TcType s                -- The type of the function
 633              -> Int                     -- Number of arguments
 634              -> TcM s ([TcType s],      -- Function argument types
 635                        TcType s)        -- Function result types
 636
 637 split_fun_ty fun_ty 0
 638   = returnTc ([], fun_ty)
 639
 640 split_fun_ty fun_ty n
 641   =     -- Expect the function to have type A->B
 642     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 643     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 644     returnTc (arg_ty:arg_tys, final_res_ty)
 645 \end{code}
 646
 647 \begin{code}
 648 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 649       -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
 650       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 651 tcArg the_fun (arg, expected_arg_ty, arg_no)
 652   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 653     tcPolyExpr arg expected_arg_ty
 654
 655
 656 -- tcPolyExpr is like tcExpr, except that the expected type
 657 -- can be a polymorphic one.
 658 tcPolyExpr arg expected_arg_ty
 659   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
 660   =     -- The ordinary, non-rank-2 polymorphic case
 661     tcExpr arg expected_arg_ty
 662
 663   | otherwise
 664   =     -- Ha!  The argument type of the function is a for-all type,
 665         -- An example of rank-2 polymorphism.
 666
 667         -- No need to instantiate the argument type... it's must be the result
 668         -- of instantiating a function involving rank-2 polymorphism, so there
 669         -- isn't any danger of using the same tyvars twice
 670         -- The argument type shouldn't be overloaded type (hence ASSERT)
 671
 672         -- To ensure that the forall'd type variables don't get unified with each
 673         -- other or any other types, we make fresh *signature* type variables
 674         -- and unify them with the tyvars.
 675     tcInstSigTcType expected_arg_ty     `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 676     let
 677         (sig_theta, sig_tau) = splitRhoTy sig_rho
 678     in
 679
 680         -- Type-check the arg and unify with expected type
 681     tcExpr arg sig_tau                          `thenTc` \ (arg', lie_arg) ->
 682
 683         -- Check that the arg_tyvars havn't been constrained
 684         -- The interesting bit here is that we must include the free variables
 685         -- of the expected arg ty.  Here's an example:
 686         --       runST (newVar True)
 687         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 688         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 689         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 690         -- So now s' isn't unconstrained because it's linked to a.
 691         -- Conclusion: include the free vars of the expected arg type in the
 692         -- list of "free vars" for the signature check.
 693
 694     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
 695     tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
 696
 697     checkSigTyVars sig_tyvars sig_tau           `thenTc_`
 698     newDicts Rank2Origin sig_theta              `thenNF_Tc` \ (sig_dicts, dict_ids) ->
 699         -- ToDo: better origin
 700     tcSimplifyAndCheck
 701                 (mkTyVarSet sig_tyvars)         -- No need to zonk the tyvars because
 702                                                 -- they won't be bound to anything
 703                 sig_dicts lie_arg               `thenTc` \ (lie', inst_binds) ->
 704
 705             -- This HsLet binds any Insts which came out of the simplification.
 706             -- It's a bit out of place here, but using AbsBind involves inventing
 707             -- a couple of new names which seems worse.
 708      returnTc ( TyLam sig_tyvars $
 709                 DictLam dict_ids $
 710                 HsLet (mk_binds inst_binds) arg'
 711               , lie')
 712   where
 713     mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
 714 \end{code}
 715
 716 %************************************************************************
 717 %*                                                                      *
 718 \subsection{@tcId@ typchecks an identifier occurrence}
 719 %*                                                                      *
 720 %************************************************************************
 721
 722 \begin{code}
 723 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
 724
 725 tcId name
 726   =     -- Look up the Id and instantiate its type
 727     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 728
 729     case maybe_local of
 730       Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
 731
 732       Nothing ->    tcLookupGlobalValue name    `thenNF_Tc` \ id ->
 733                     tcInstType [] (idType id)   `thenNF_Tc` \ inst_ty ->
 734                     let
 735                         (tyvars, rho) = splitForAllTy inst_ty
 736                     in
 737                     instantiate_it2 (RealId id) tyvars rho
 738
 739   where
 740         -- The instantiate_it loop runs round instantiating the Id.
 741         -- It has to be a loop because we are now prepared to entertain
 742         -- types like
 743         --              f:: forall a. Eq a => forall b. Baz b => tau
 744         -- We want to instantiate this to
 745         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 746     instantiate_it tc_id_occ ty
 747       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 748         instantiate_it2 tc_id_occ tyvars rho
 749
 750     instantiate_it2 tc_id_occ tyvars rho
 751       = tcSplitRhoTy rho                                `thenNF_Tc` \ (theta, tau) ->
 752         if null theta then      -- Is it overloaded?
 753                 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 754         else
 755                 -- Yes, it's overloaded
 756         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 757                              tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
 758         instantiate_it meth_id tau                       `thenNF_Tc` \ (expr, lie2, final_tau) ->
 759         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 760
 761       where
 762         arg_tys       = mkTyVarTys tyvars
 763 \end{code}
 764
 765 %************************************************************************
 766 %*                                                                      *
 767 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 768 %*                                                                      *
 769 %************************************************************************
 770
 771 \begin{code}
 772 tcDoStmts do_or_lc stmts src_loc res_ty
 773   =     -- get the Monad and MonadZero classes
 774         -- create type consisting of a fresh monad tyvar
 775     ASSERT( not (null stmts) )
 776     tcAddSrcLoc src_loc $
 777     newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)    `thenNF_Tc` \ m ->
 778
 779     let
 780       tc_stmts []           = returnTc (([], error "tc_stmts"), emptyLIE)
 781       tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
 782                               tc_stmts stmts
 783
 784       combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
 785       combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
 786       combine_stmts stmt                _         ([], _) = panic "Bad last stmt tcDoStmts"
 787       combine_stmts stmt                _     (stmts, ty) = (stmt:stmts, ty)
 788     in
 789     tc_stmts stmts                      `thenTc`   \ ((stmts', result_ty), final_lie) ->
 790     unifyTauTy result_ty res_ty         `thenTc_`
 791
 792         -- Build the then and zero methods in case we need them
 793         -- It's important that "then" and "return" appear just once in the final LIE,
 794         -- not only for typechecker efficiency, but also because otherwise during
 795         -- simplification we end up with silly stuff like
 796         --      then = case d of (t,r) -> t
 797         --      then = then
 798         -- where the second "then" sees that it already exists in the "available" stuff.
 799         --
 800     tcLookupGlobalValueByKey returnMClassOpKey  `thenNF_Tc` \ return_sel_id ->
 801     tcLookupGlobalValueByKey thenMClassOpKey    `thenNF_Tc` \ then_sel_id ->
 802     tcLookupGlobalValueByKey zeroClassOpKey     `thenNF_Tc` \ zero_sel_id ->
 803     newMethod DoOrigin
 804               (RealId return_sel_id) [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 805     newMethod DoOrigin
 806               (RealId then_sel_id) [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 807     newMethod DoOrigin
 808               (RealId zero_sel_id) [m]          `thenNF_Tc` \ (zero_lie, zero_id) ->
 809     let
 810       monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
 811       perhaps_zero_lie | all failure_free stmts' = emptyLIE
 812                        | otherwise               = zero_lie
 813
 814       failure_free (BindStmt pat _ _) = failureFreePat pat
 815       failure_free (GuardStmt _ _)    = False
 816       failure_free other_stmt         = True
 817     in
 818     returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
 819               final_lie `plusLIE` monad_lie)
 820
 821 \end{code}
 822
 823 \begin{code}
 824 tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s))        -- This is tcExpr
 825                                 -- The sole, disgusting, reason for this parameter
 826                                 -- is to get the effect of polymorphic recursion
 827                                 -- ToDo: rm when booting with Haskell 1.3
 828        -> DoOrListComp
 829        -> (TcType s -> TcType s)                -- Relationship type of pat and rhs in pat <- rhs
 830        -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
 831        -> RenamedStmt
 832        -> TcM s (thing, LIE s)
 833        -> TcM s (thing, LIE s)
 834
 835 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
 836   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 837     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 838         newTyVarTy mkTypeKind                `thenNF_Tc` \ exp_ty ->
 839         tc_expr exp exp_ty                   `thenTc`    \ (exp', exp_lie) ->
 840         returnTc (ReturnStmt exp', exp_lie, m exp_ty)
 841     )                                   `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
 842     do_next                             `thenTc` \ (thing', thing_lie) ->
 843     returnTc (combine stmt' (Just stmt_ty) thing',
 844               stmt_lie `plusLIE` thing_lie)
 845
 846 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
 847   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 848     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 849     tcAddSrcLoc src_loc                 (
 850     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 851         tc_expr exp boolTy              `thenTc`    \ (exp', exp_lie) ->
 852         returnTc (GuardStmt exp' src_loc, exp_lie)
 853     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 854     do_next                             `thenTc` \ (thing', thing_lie) ->
 855     returnTc (combine stmt' Nothing thing',
 856               stmt_lie `plusLIE` thing_lie)
 857
 858 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
 859   = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
 860     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 861     tcAddSrcLoc src_loc                 (
 862     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 863         newTyVarTy mkTypeKind           `thenNF_Tc` \ tau ->
 864         let
 865             -- exp has type (m tau) for some tau (doesn't matter what)
 866             exp_ty = m tau
 867         in
 868         tc_expr exp exp_ty              `thenTc`    \ (exp', exp_lie) ->
 869         returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
 870     ))                                  `thenTc` \ (stmt',  stmt_lie, stmt_ty) ->
 871     do_next                             `thenTc` \ (thing', thing_lie) ->
 872     returnTc (combine stmt' (Just stmt_ty) thing',
 873               stmt_lie `plusLIE` thing_lie)
 874
 875 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
 876   = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 877     tcAddSrcLoc src_loc         (
 878     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 879         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 880         tc_expr exp (m pat_ty)          `thenTc`    \ (exp', exp_lie) ->
 881
 882         -- NB: the environment has been extended with the new binders
 883         -- which the rhs can't "see", but the renamer should have made
 884         -- sure that everything is distinct by now, so there's no problem.
 885         -- Putting the tcExpr before the newMonoIds messes up the nesting
 886         -- of error contexts, so I didn't  bother
 887
 888         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
 889     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 890     do_next                             `thenTc` \ (thing', thing_lie) ->
 891     returnTc (combine stmt' Nothing thing',
 892               stmt_lie `plusLIE` thing_lie)
 893
 894 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
 895      = tcBindsAndThen           -- No error context, but a binding group is
 896         combine'                -- rather a large thing for an error context anyway
 897         binds
 898         do_next
 899      where
 900         combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
 901 \end{code}
 902
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection{Record bindings}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 Game plan for record bindings
 910 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 911 For each binding
 912         field = value
 913 1. look up "field", to find its selector Id, which must have type
 914         forall a1..an. T a1 .. an -> tau
 915    where tau is the type of the field.
 916
 917 2. Instantiate this type
 918
 919 3. Unify the (T a1 .. an) part with the "expected result type", which
 920    is passed in.  This checks that all the field labels come from the
 921    same type.
 922
 923 4. Type check the value using tcArg, passing tau as the expected
 924    argument type.
 925
 926 This extends OK when the field types are universally quantified.
 927
 928 Actually, to save excessive creation of fresh type variables,
 929 we
 930
 931 \begin{code}
 932 tcRecordBinds
 933         :: TcType s             -- Expected type of whole record
 934         -> RenamedRecordBinds
 935         -> TcM s (TcRecordBinds s, LIE s)
 936
 937 tcRecordBinds expected_record_ty rbinds
 938   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 939     returnTc (rbinds', plusLIEs lies)
 940   where
 941     do_bind (field_label, rhs, pun_flag)
 942       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 943         ASSERT( isRecordSelector sel_id )
 944                 -- This lookup and assertion will surely succeed, because
 945                 -- we check that the fields are indeed record selectors
 946                 -- before calling tcRecordBinds
 947
 948         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 949
 950                 -- Record selectors all have type
 951                 --      forall a1..an.  T a1 .. an -> tau
 952         ASSERT( maybeToBool (getFunTy_maybe tau) )
 953         let
 954                 -- Selector must have type RecordType -> FieldType
 955           Just (record_ty, field_ty) = getFunTy_maybe tau
 956         in
 957         unifyTauTy expected_record_ty record_ty         `thenTc_`
 958         tcPolyExpr rhs field_ty                         `thenTc` \ (rhs', lie) ->
 959         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 960
 961 badFields rbinds data_con
 962   = [field_name | (field_name, _, _) <- rbinds,
 963                   not (field_name `elem` field_names)
 964     ]
 965   where
 966     field_names = map fieldLabelName (dataConFieldLabels data_con)
 967 \end{code}
 968
 969 %************************************************************************
 970 %*                                                                      *
 971 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 972 %*                                                                      *
 973 %************************************************************************
 974
 975 \begin{code}
 976 tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
 977
 978 tcExprs [] [] = returnTc ([], emptyLIE)
 979 tcExprs (expr:exprs) (ty:tys)
 980  = tcExpr  expr  ty             `thenTc` \ (expr',  lie1) ->
 981    tcExprs exprs tys            `thenTc` \ (exprs', lie2) ->
 982    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 983 \end{code}
 984
 985
 986 % =================================================
 987
 988 Errors and contexts
 989 ~~~~~~~~~~~~~~~~~~~
 990
 991 Mini-utils:
 992 \begin{code}
 993 pp_nest_hang :: String -> Doc -> Doc
 994 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
 995 \end{code}
 996
 997 Boring and alphabetical:
 998 \begin{code}
 999 arithSeqCtxt expr sty
1000   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
1001
1002 branchCtxt b1 b2 sty
1003   = sep [ptext SLIT("In the branches of a conditional:"),
1004            pp_nest_hang "`then' branch:" (ppr sty b1),
1005            pp_nest_hang "`else' branch:" (ppr sty b2)]
1006
1007 caseCtxt expr sty
1008   = hang (ptext SLIT("In the case expression")) 4 (ppr sty expr)
1009
1010 exprSigCtxt expr sty
1011   = hang (ptext SLIT("In an expression with a type signature:"))
1012          4 (ppr sty expr)
1013
1014 listCtxt expr sty
1015   = hang (ptext SLIT("In the list element")) 4 (ppr sty expr)
1016
1017 predCtxt expr sty
1018   = hang (ptext SLIT("In the predicate expression")) 4 (ppr sty expr)
1019
1020 sectionRAppCtxt expr sty
1021   = hang (ptext SLIT("In the right section")) 4 (ppr sty expr)
1022
1023 sectionLAppCtxt expr sty
1024   = hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
1025
1026 stmtCtxt do_or_lc stmt sty
1027   = hang (ptext SLIT("In a") <+> whatever <> colon)
1028          4 (ppr sty stmt)
1029   where
1030     whatever = case do_or_lc of
1031                  ListComp -> ptext SLIT("list-comprehension qualifier")
1032                  DoStmt   -> ptext SLIT("do statement")
1033                  Guard    -> ptext SLIT("guard")
1034
1035 tooManyArgsCtxt f sty
1036   = hang (ptext SLIT("Too many arguments in an application of the function"))
1037          4 (ppr sty f)
1038
1039 funAppCtxt fun arg arg_no sty
1040   = hang (hsep [ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1041                 ppr sty fun <> text ", namely"])
1042          4 (ppr sty arg)
1043
1044 lurkingRank2Err fun fun_ty sty
1045   = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
1046          4 (vcat [text "It is applied to too few arguments,",
1047                       ptext SLIT("so that the result type has for-alls in it")])
1048
1049 rank2ArgCtxt arg expected_arg_ty sty
1050   = ptext SLIT("In a polymorphic function argument") <+> ppr sty arg
1051
1052 badFieldsUpd rbinds sty
1053   = hang (ptext SLIT("No constructor has all these fields:"))
1054          4 (interpp'SP sty fields)
1055   where
1056     fields = [field | (field, _, _) <- rbinds]
1057
1058 recordUpdCtxt sty = ptext SLIT("In a record update construct")
1059
1060 badFieldsCon con fields sty
1061   = hsep [ptext SLIT("Constructor"),            ppr sty con,
1062            ptext SLIT("does not have field(s)"), interpp'SP sty fields]
1063
1064 notSelector field sty
1065   = hsep [ppr sty field, ptext SLIT("is not a record selector")]
1066 \end{code}