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