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 ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( HsExpr(..), Qualifier(..), Stmt(..),
  14                           HsBinds(..), Bind(..), MonoBinds(..),
  15                           ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
  16                           Match, Fake, InPat, OutPat, PolyType,
  17                           failureFreePat, collectPatBinders )
  18 import RnHsSyn          ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
  19                           SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
  20                           RnName{-instance Outputable-}
  21                         )
  22 import TcHsSyn          ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
  23                           TcIdOcc(..), SYN_IE(TcRecordBinds),
  24                           mkHsTyApp
  25                         )
  26
  27 import TcMonad          hiding ( rnMtoTcM )
  28 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  29                           SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
  30                           newMethod, newMethodWithGivenTy, newDicts )
  31 import TcBinds          ( tcBindsAndThen )
  32 import TcEnv            ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
  33                           tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
  34                           tcExtendGlobalTyVars
  35                         )
  36 import TcMatches        ( tcMatchesCase, tcMatch )
  37 import TcMonoType       ( tcPolyType )
  38 import TcPat            ( tcPat )
  39 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyRank2 )
  40 import TcType           ( SYN_IE(TcType), TcMaybe(..),
  41                           tcInstId, tcInstType, tcInstSigTcType,
  42                           tcInstSigType, tcInstTcType, tcInstTheta,
  43                           newTyVarTy, zonkTcTyVars, zonkTcType )
  44 import TcKind           ( TcKind )
  45
  46 import Class            ( SYN_IE(Class), classSig )
  47 import FieldLabel       ( fieldLabelName )
  48 import Id               ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId )
  49 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
  50 import GenSpecEtc       ( checkSigTyVars )
  51 import Name             ( Name{-instance Eq-} )
  52 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
  53                           getTyVar_maybe, getFunTy_maybe, instantiateTy,
  54                           splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
  55                           isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
  56                           getAppDataTyCon, maybeAppDataTyCon
  57                         )
  58 import TyVar            ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
  59 import TysPrim          ( intPrimTy, charPrimTy, doublePrimTy,
  60                           floatPrimTy, addrPrimTy, realWorldTy
  61                         )
  62 import TysWiredIn       ( addrTy,
  63                           boolTy, charTy, stringTy, mkListTy,
  64                           mkTupleTy, mkPrimIoTy, stDataCon
  65                         )
  66 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
  67 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey,
  68                           enumFromClassOpKey, enumFromThenClassOpKey,
  69                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  70                           thenMClassOpKey, zeroClassOpKey
  71                         )
  72 import Outputable       ( interpp'SP )
  73 import PprType          ( GenType, GenTyVar )   -- Instances
  74 import Maybes           ( maybeToBool )
  75 import Pretty
  76 import Util
  77 \end{code}
  78
  79 \begin{code}
  80 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection{The TAUT rules for variables}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 \begin{code}
  90 tcExpr (HsVar name)
  91   = tcId name           `thenNF_Tc` \ (expr', lie, res_ty) ->
  92
  93     -- Check that the result type doesn't have any nested for-alls.
  94     -- For example, a "build" on its own is no good; it must be
  95     -- applied to something.
  96     checkTc (isTauTy res_ty)
  97             (lurkingRank2Err name res_ty) `thenTc_`
  98
  99     returnTc (expr', lie, res_ty)
 100 \end{code}
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection{Literals}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 Overloaded literals.
 109
 110 \begin{code}
 111 tcExpr (HsLit (HsInt i))
 112   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 113
 114     newOverloadedLit (LiteralOrigin (HsInt i))
 115                      (OverloadedIntegral i)
 116                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 117
 118     returnTc (HsVar over_lit_id, lie, ty)
 119
 120 tcExpr (HsLit (HsFrac f))
 121   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 122
 123     newOverloadedLit (LiteralOrigin (HsFrac f))
 124                      (OverloadedFractional f)
 125                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 126
 127     returnTc (HsVar over_lit_id, lie, ty)
 128
 129 tcExpr (HsLit lit@(HsLitLit s))
 130   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 131     newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ ty ->
 132     newDicts (LitLitOrigin (_UNPK_ s))
 133              [(cCallableClass, ty)]                     `thenNF_Tc` \ (dicts, _) ->
 134     returnTc (HsLitOut lit ty, dicts, ty)
 135 \end{code}
 136
 137 Primitive literals:
 138
 139 \begin{code}
 140 tcExpr (HsLit lit@(HsCharPrim c))
 141   = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
 142
 143 tcExpr (HsLit lit@(HsStringPrim s))
 144   = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
 145
 146 tcExpr (HsLit lit@(HsIntPrim i))
 147   = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
 148
 149 tcExpr (HsLit lit@(HsFloatPrim f))
 150   = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
 151
 152 tcExpr (HsLit lit@(HsDoublePrim d))
 153   = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
 154 \end{code}
 155
 156 Unoverloaded literals:
 157
 158 \begin{code}
 159 tcExpr (HsLit lit@(HsChar c))
 160   = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
 161
 162 tcExpr (HsLit lit@(HsString str))
 163   = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
 164 \end{code}
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection{Other expression forms}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 \begin{code}
 173 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
 174   = tcExpr expr
 175
 176 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
 177
 178 tcExpr (HsLam match)
 179   = tcMatch match       `thenTc` \ (match',lie,ty) ->
 180     returnTc (HsLam match', lie, ty)
 181
 182 tcExpr (HsApp e1 e2) = accum e1 [e2]
 183   where
 184     accum (HsApp e1 e2) args = accum e1 (e2:args)
 185     accum fun args
 186       = tcApp fun args  `thenTc` \ (fun', args', lie, res_ty) ->
 187         returnTc (foldl HsApp fun' args', lie, res_ty)
 188
 189 -- equivalent to (op e1) e2:
 190 tcExpr (OpApp arg1 op arg2)
 191   = tcApp op [arg1,arg2]        `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
 192     returnTc (OpApp arg1' op' arg2', lie, res_ty)
 193 \end{code}
 194
 195 Note that the operators in sections are expected to be binary, and
 196 a type error will occur if they aren't.
 197
 198 \begin{code}
 199 -- Left sections, equivalent to
 200 --      \ x -> e op x,
 201 -- or
 202 --      \ x -> op e x,
 203 -- or just
 204 --      op e
 205
 206 tcExpr in_expr@(SectionL arg op)
 207   = tcApp op [arg]              `thenTc` \ (op', [arg'], lie, res_ty) ->
 208
 209         -- Check that res_ty is a function type
 210         -- Without this check we barf in the desugarer on
 211         --      f op = (3 `op`)
 212         -- because it tries to desugar to
 213         --      f op = \r -> 3 op r
 214         -- so (3 `op`) had better be a function!
 215     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty1 ->
 216     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty2 ->
 217     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 218     unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
 219
 220     returnTc (SectionL arg' op', lie, res_ty)
 221
 222 -- Right sections, equivalent to \ x -> x op expr, or
 223 --      \ x -> op x expr
 224
 225 tcExpr in_expr@(SectionR op expr)
 226   = tcExpr op                   `thenTc`    \ (op',  lie1, op_ty) ->
 227     tcExpr expr                 `thenTc`    \ (expr',lie2, expr_ty) ->
 228
 229     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty1 ->
 230     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty2 ->
 231     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 232     unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
 233
 234     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 235 \end{code}
 236
 237 The interesting thing about @ccall@ is that it is just a template
 238 which we instantiate by filling in details about the types of its
 239 argument and result (ie minimal typechecking is performed).  So, the
 240 basic story is that we allocate a load of type variables (to hold the
 241 arg/result types); unify them with the args/result; and store them for
 242 later use.
 243
 244 \begin{code}
 245 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
 246   =     -- Get the callable and returnable classes.
 247     tcLookupClassByKey cCallableClassKey        `thenNF_Tc` \ cCallableClass ->
 248     tcLookupClassByKey cReturnableClassKey      `thenNF_Tc` \ cReturnableClass ->
 249
 250     let
 251         new_arg_dict (arg, arg_ty)
 252           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 253                      [(cCallableClass, arg_ty)]         `thenNF_Tc` \ (arg_dicts, _) ->
 254             returnNF_Tc arg_dicts       -- Actually a singleton bag
 255
 256         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 257     in
 258
 259         -- Arguments
 260     tcExprs args                        `thenTc` \ (args', args_lie, arg_tys) ->
 261
 262         -- The argument types can be unboxed or boxed; the result
 263         -- type must, however, be boxed since it's an argument to the PrimIO
 264         -- type constructor.
 265     newTyVarTy mkBoxedTypeKind                  `thenNF_Tc` \ result_ty ->
 266
 267         -- Construct the extra insts, which encode the
 268         -- constraints on the argument and result types.
 269     mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 270     newDicts result_origin [(cReturnableClass, result_ty)]          `thenNF_Tc` \ (ccres_dict, _) ->
 271
 272     returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty],
 273               -- do the wrapping in the newtype constructor here
 274               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
 275               mkPrimIoTy result_ty)
 276 \end{code}
 277
 278 \begin{code}
 279 tcExpr (HsSCC label expr)
 280   = tcExpr expr         `thenTc` \ (expr', lie, expr_ty) ->
 281          -- No unification. Give SCC the type of expr
 282     returnTc (HsSCC label expr', lie, expr_ty)
 283
 284 tcExpr (HsLet binds expr)
 285   = tcBindsAndThen
 286         HsLet                   -- The combiner
 287         binds                   -- Bindings to check
 288         (tcExpr expr)           -- Typechecker for the expression
 289
 290 tcExpr in_expr@(HsCase expr matches src_loc)
 291   = tcAddSrcLoc src_loc $
 292     tcExpr expr                 `thenTc`    \ (expr',lie1,expr_ty) ->
 293     newTyVarTy mkTypeKind       `thenNF_Tc` \ result_ty ->
 294
 295     tcAddErrCtxt (caseCtxt in_expr) $
 296     tcMatchesCase (mkFunTy expr_ty result_ty) matches
 297                                 `thenTc`    \ (matches',lie2) ->
 298
 299     returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
 300
 301 tcExpr (HsIf pred b1 b2 src_loc)
 302   = tcAddSrcLoc src_loc $
 303     tcExpr pred                 `thenTc`    \ (pred',lie1,predTy) ->
 304
 305     tcAddErrCtxt (predCtxt pred) (
 306       unifyTauTy predTy boolTy
 307     )                           `thenTc_`
 308
 309     tcExpr b1                   `thenTc`    \ (b1',lie2,result_ty) ->
 310     tcExpr b2                   `thenTc`    \ (b2',lie3,b2Ty) ->
 311
 312     tcAddErrCtxt (branchCtxt b1 b2) $
 313     unifyTauTy result_ty b2Ty                           `thenTc_`
 314
 315     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 316
 317 tcExpr (ListComp expr quals)
 318   = tcListComp expr quals       `thenTc` \ ((expr',quals'), lie, ty) ->
 319     returnTc (ListComp expr' quals', lie, ty)
 320 \end{code}
 321
 322 \begin{code}
 323 tcExpr expr@(HsDo stmts src_loc)
 324   = tcDoStmts stmts src_loc
 325 \end{code}
 326
 327 \begin{code}
 328 tcExpr (ExplicitList [])
 329   = newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
 330     returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
 331
 332
 333 tcExpr in_expr@(ExplicitList exprs)     -- Non-empty list
 334   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
 335     tcAddErrCtxt (listCtxt in_expr) $
 336     unifyTauTyList tys                  `thenTc_`
 337     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 338
 339 tcExpr (ExplicitTuple exprs)
 340   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys) ->
 341     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 342
 343 tcExpr (RecordCon (HsVar con) rbinds)
 344   = tcId con                            `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 345     let
 346         (_, record_ty) = splitFunTy con_tau
 347     in
 348         -- Con is syntactically constrained to be a data constructor
 349     ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
 350
 351     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 352
 353         -- Check that the record bindings match the constructor
 354     tcLookupGlobalValue con                     `thenNF_Tc` \ con_id ->
 355     checkTc (checkRecordFields rbinds con_id)
 356             (badFieldsCon con rbinds)           `thenTc_`
 357
 358     returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
 359
 360 -- One small complication in RecordUpd is that we have to generate some
 361 -- dictionaries for the data type context, since we are going to
 362 -- do some construction.
 363 --
 364 -- What dictionaries do we need?  For the moment we assume that all
 365 -- data constructors have the same context, and grab it from the first
 366 -- constructor.  If they have varying contexts then we'd have to
 367 -- union the ones that could participate in the update.
 368
 369 tcExpr (RecordUpd record_expr rbinds)
 370   = ASSERT( not (null rbinds) )
 371     tcAddErrCtxt recordUpdCtxt                  $
 372
 373     tcExpr record_expr                  `thenTc` \ (record_expr', record_lie, record_ty) ->
 374     tcRecordBinds record_ty rbinds      `thenTc` \ (rbinds', rbinds_lie) ->
 375
 376         -- Check that the field names are plausible
 377     zonkTcType record_ty                `thenNF_Tc` \ record_ty' ->
 378     let
 379         (tycon, inst_tys, data_cons) = trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
 380         -- The record binds are non-empty (syntax); so at least one field
 381         -- label will have been unified with record_ty by tcRecordBinds;
 382         -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
 383         (tyvars, theta, _, _) = dataConSig (head data_cons)
 384     in
 385     tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
 386     newDicts RecordUpdOrigin theta'                                 `thenNF_Tc` \ (con_lie, dicts) ->
 387     checkTc (any (checkRecordFields rbinds) data_cons)
 388             (badFieldsUpd rbinds)               `thenTc_`
 389
 390     returnTc (RecordUpdOut record_expr' dicts rbinds',
 391               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
 392               record_ty)
 393
 394 tcExpr (ArithSeqIn seq@(From expr))
 395   = tcExpr expr                                 `thenTc`    \ (expr', lie1, ty) ->
 396
 397     tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
 398     newMethod (ArithSeqOrigin seq)
 399               (RealId sel_id) [ty]              `thenNF_Tc` \ (lie2, enum_from_id) ->
 400
 401     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 402               lie1 `plusLIE` lie2,
 403               mkListTy ty)
 404
 405 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
 406   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 407     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 408
 409     tcAddErrCtxt (arithSeqCtxt in_expr) $
 410     unifyTauTyList [ty1, ty2]                           `thenTc_`
 411
 412     tcLookupGlobalValueByKey enumFromThenClassOpKey     `thenNF_Tc` \ sel_id ->
 413     newMethod (ArithSeqOrigin seq)
 414               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 415
 416     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 417                            (FromThen expr1' expr2'),
 418               lie1 `plusLIE` lie2 `plusLIE` lie3,
 419               mkListTy ty1)
 420
 421 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
 422   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 423     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 424
 425     tcAddErrCtxt (arithSeqCtxt in_expr) $
 426     unifyTauTyList [ty1,ty2]    `thenTc_`
 427
 428     tcLookupGlobalValueByKey enumFromToClassOpKey       `thenNF_Tc` \ sel_id ->
 429     newMethod (ArithSeqOrigin seq)
 430               (RealId sel_id) [ty1]             `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 431
 432     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 433                           (FromTo expr1' expr2'),
 434               lie1 `plusLIE` lie2 `plusLIE` lie3,
 435                mkListTy ty1)
 436
 437 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 438   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 439     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 440     tcExpr expr3                `thenTc`    \ (expr3',lie3,ty3) ->
 441
 442     tcAddErrCtxt  (arithSeqCtxt in_expr) $
 443     unifyTauTyList [ty1,ty2,ty3]                        `thenTc_`
 444
 445     tcLookupGlobalValueByKey enumFromThenToClassOpKey   `thenNF_Tc` \ sel_id ->
 446     newMethod (ArithSeqOrigin seq)
 447               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie4, eft_id) ->
 448
 449     returnTc (ArithSeqOut (HsVar eft_id)
 450                            (FromThenTo expr1' expr2' expr3'),
 451               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
 452               mkListTy ty1)
 453 \end{code}
 454
 455 %************************************************************************
 456 %*                                                                      *
 457 \subsection{Expressions type signatures}
 458 %*                                                                      *
 459 %************************************************************************
 460
 461 \begin{code}
 462 tcExpr in_expr@(ExprWithTySig expr poly_ty)
 463  = tcExpr expr                  `thenTc` \ (texpr, lie, tau_ty) ->
 464    tcPolyType  poly_ty          `thenTc` \ sigma_sig ->
 465
 466         -- Check the tau-type part
 467    tcSetErrCtxt (exprSigCtxt in_expr)   $
 468    tcInstSigType sigma_sig              `thenNF_Tc` \ sigma_sig' ->
 469    let
 470         (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
 471    in
 472    unifyTauTy tau_ty sig_tau'           `thenTc_`
 473
 474         -- Check the type variables of the signature
 475    checkSigTyVars sig_tyvars' sig_tau'  `thenTc_`
 476
 477         -- Check overloading constraints
 478    newDicts SignatureOrigin sig_theta'          `thenNF_Tc` \ (sig_dicts, _) ->
 479    tcSimplifyAndCheck
 480         (mkTyVarSet sig_tyvars')
 481         sig_dicts lie                           `thenTc_`
 482
 483         -- If everything is ok, return the stuff unchanged, except for
 484         -- the effect of any substutions etc.  We simply discard the
 485         -- result of the tcSimplifyAndCheck, except for any default
 486         -- resolution it may have done, which is recorded in the
 487         -- substitution.
 488    returnTc (texpr, lie, tau_ty)
 489 \end{code}
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsection{@tcApp@ typchecks an application}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 499       -> TcM s (TcExpr s, [TcExpr s],       -- Translated fun and args
 500                 LIE s,
 501                 TcType s)                   -- Type of the application
 502
 503 tcApp fun args
 504   =     -- First type-check the function
 505         -- In the HsVar case we go straight to tcId to avoid hitting the
 506         -- rank-2 check, which we check later here anyway
 507     (case fun of
 508         HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
 509         other      -> tcExpr fun
 510     )                                   `thenTc` \ (fun', lie_fun, fun_ty) ->
 511
 512     tcApp_help fun 1 fun_ty args        `thenTc` \ (args', lie_args, res_ty) ->
 513
 514     -- Check that the result type doesn't have any nested for-alls.
 515     -- For example, a "build" on its own is no good; it must be applied to something.
 516     checkTc (isTauTy res_ty)
 517             (lurkingRank2Err fun fun_ty) `thenTc_`
 518
 519     returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
 520
 521
 522 tcApp_help :: RenamedHsExpr -> Int      -- Function and arg position, used in error message(s)
 523            -> TcType s                  -- The type of the function
 524            -> [RenamedHsExpr]           -- Arguments
 525            -> TcM s ([TcExpr s],                -- Typechecked args
 526                      LIE s,
 527                      TcType s)          -- Result type of the application
 528
 529 tcApp_help orig_fun arg_no fun_ty []
 530   = returnTc ([], emptyLIE, fun_ty)
 531
 532 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
 533   =     -- Expect the function to have type A->B
 534     tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
 535             unifyFunTy fun_ty
 536     )                                                   `thenTc` \ (expected_arg_ty, result_ty) ->
 537
 538         -- Type check the argument
 539     tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
 540                 tcArg expected_arg_ty arg
 541     )                                                   `thenTc` \ (arg', lie_arg) ->
 542
 543         -- Do the other args
 544     tcApp_help orig_fun (arg_no+1) result_ty args       `thenTc` \ (args', lie_args, res_ty) ->
 545
 546         -- Done
 547     returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
 548
 549 \end{code}
 550
 551 \begin{code}
 552 tcArg :: TcType s                       -- Expected arg type
 553       -> RenamedHsExpr                  -- Actual argument
 554       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 555
 556 tcArg expected_arg_ty arg
 557   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
 558   =     -- The ordinary, non-rank-2 polymorphic case
 559     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 560     unifyTauTy expected_arg_ty actual_arg_ty    `thenTc_`
 561     returnTc (arg', lie_arg)
 562
 563   | otherwise
 564   =     -- Ha!  The argument type of the function is a for-all type,
 565         -- An example of rank-2 polymorphism.
 566
 567         -- No need to instantiate the argument type... it's must be the result
 568         -- of instantiating a function involving rank-2 polymorphism, so there
 569         -- isn't any danger of using the same tyvars twice
 570         -- The argument type shouldn't be overloaded type (hence ASSERT)
 571
 572         -- To ensure that the forall'd type variables don't get unified with each
 573         -- other or any other types, we make fresh *signature* type variables
 574         -- and unify them with the tyvars.
 575     tcInstSigTcType expected_arg_ty     `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 576     let
 577         (sig_theta, sig_tau) = splitRhoTy sig_rho
 578     in
 579     ASSERT( null sig_theta )    -- And expected_tyvars are all DontBind things
 580
 581         -- Type-check the arg and unify with expected type
 582     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 583     unifyTauTy sig_tau actual_arg_ty            `thenTc_`
 584
 585         -- Check that the arg_tyvars havn't been constrained
 586         -- The interesting bit here is that we must include the free variables
 587         -- of the expected arg ty.  Here's an example:
 588         --       runST (newVar True)
 589         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 590         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 591         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 592         -- So now s' isn't unconstrained because it's linked to a.
 593         -- Conclusion: include the free vars of the expected arg type in the
 594         -- list of "free vars" for the signature check.
 595
 596     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
 597         tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
 598                 checkSigTyVars sig_tyvars sig_tau
 599         )                                               `thenTc_`
 600
 601             -- Check that there's no overloading involved
 602             -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
 603             -- but which, on simplification, don't actually need a dictionary involving
 604             -- the tyvar.  So we have to do a proper simplification right here.
 605         tcSimplifyRank2 (mkTyVarSet sig_tyvars)
 606                         lie_arg                         `thenTc` \ (free_insts, inst_binds) ->
 607
 608             -- This HsLet binds any Insts which came out of the simplification.
 609             -- It's a bit out of place here, but using AbsBind involves inventing
 610             -- a couple of new names which seems worse.
 611         returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
 612     )
 613   where
 614
 615     mk_binds [] = EmptyBinds
 616     mk_binds ((inst,rhs):inst_binds)
 617         = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
 618           mk_binds inst_binds
 619 \end{code}
 620
 621 %************************************************************************
 622 %*                                                                      *
 623 \subsection{@tcId@ typchecks an identifier occurrence}
 624 %*                                                                      *
 625 %************************************************************************
 626
 627 \begin{code}
 628 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
 629
 630 tcId name
 631   =     -- Look up the Id and instantiate its type
 632     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 633
 634     case maybe_local of
 635       Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
 636
 637       Nothing ->    tcLookupGlobalValue name    `thenNF_Tc` \ id ->
 638                     tcInstType [] (idType id)   `thenNF_Tc` \ inst_ty ->
 639                     let
 640                         (tyvars, rho) = splitForAllTy inst_ty
 641                     in
 642                     instantiate_it2 (RealId id) tyvars rho
 643
 644   where
 645         -- The instantiate_it loop runs round instantiating the Id.
 646         -- It has to be a loop because we are now prepared to entertain
 647         -- types like
 648         --              f:: forall a. Eq a => forall b. Baz b => tau
 649         -- We want to instantiate this to
 650         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 651     instantiate_it tc_id_occ ty
 652       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 653         instantiate_it2 tc_id_occ tyvars rho
 654
 655     instantiate_it2 tc_id_occ tyvars rho
 656       | null theta      -- Is it overloaded?
 657       = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 658
 659       | otherwise       -- Yes, it's overloaded
 660       = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 661                              tc_id_occ arg_tys rho      `thenNF_Tc` \ (lie1, meth_id) ->
 662         instantiate_it meth_id tau                      `thenNF_Tc` \ (expr, lie2, final_tau) ->
 663         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 664
 665       where
 666         (theta,  tau) = splitRhoTy   rho
 667         arg_tys       = mkTyVarTys tyvars
 668 \end{code}
 669
 670 %************************************************************************
 671 %*                                                                      *
 672 \subsection{@tcQuals@ typechecks list-comprehension qualifiers}
 673 %*                                                                      *
 674 %************************************************************************
 675
 676 \begin{code}
 677 tcListComp expr []
 678   = tcExpr expr         `thenTc` \ (expr', lie, ty) ->
 679     returnTc ((expr',[]), lie, mkListTy ty)
 680
 681 tcListComp expr (qual@(FilterQual filter) : quals)
 682   = tcAddErrCtxt (qualCtxt qual) (
 683         tcExpr filter                   `thenTc` \ (filter', filter_lie, filter_ty) ->
 684         unifyTauTy boolTy filter_ty     `thenTc_`
 685         returnTc (FilterQual filter', filter_lie)
 686     )                                   `thenTc` \ (qual', qual_lie) ->
 687
 688     tcListComp expr quals       `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
 689
 690     returnTc ((expr', qual' : quals'),
 691               qual_lie `plusLIE` rest_lie,
 692               res_ty)
 693
 694 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
 695   = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
 696
 697       tcAddErrCtxt (qualCtxt qual) (
 698         tcPat pat                               `thenTc` \ (pat',  lie_pat,  pat_ty)  ->
 699         tcExpr rhs                              `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
 700                 -- NB: the environment has been extended with the new binders
 701                 -- which the rhs can't "see", but the renamer should have made
 702                 -- sure that everything is distinct by now, so there's no problem.
 703                 -- Putting the tcExpr before the newMonoIds messes up the nesting
 704                 -- of error contexts, so I didn't  bother
 705
 706         unifyTauTy (mkListTy pat_ty) rhs_ty     `thenTc_`
 707         returnTc (GeneratorQual pat' rhs',
 708                   lie_pat `plusLIE` lie_rhs)
 709       )                                         `thenTc` \ (qual', lie_qual) ->
 710
 711       tcListComp expr quals                     `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
 712
 713       returnTc ((expr', qual' : quals'),
 714                 lie_qual `plusLIE` lie_rest,
 715                 res_ty)
 716     )
 717   where
 718     binder_names = collectPatBinders pat
 719
 720 tcListComp expr (LetQual binds : quals)
 721   = tcBindsAndThen              -- No error context, but a binding group is
 722         combine                 -- rather a large thing for an error context anyway
 723         binds
 724         (tcListComp expr quals)
 725   where
 726     combine binds' (expr',quals') = (expr', LetQual binds' : quals')
 727 \end{code}
 728
 729
 730 %************************************************************************
 731 %*                                                                      *
 732 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 733 %*                                                                      *
 734 %************************************************************************
 735
 736 \begin{code}
 737 tcDoStmts stmts src_loc
 738   =     -- get the Monad and MonadZero classes
 739         -- create type consisting of a fresh monad tyvar
 740     tcAddSrcLoc src_loc $
 741     newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)    `thenNF_Tc` \ m ->
 742
 743
 744         -- Build the then and zero methods in case we need them
 745     tcLookupGlobalValueByKey thenMClassOpKey    `thenNF_Tc` \ then_sel_id ->
 746     tcLookupGlobalValueByKey zeroClassOpKey     `thenNF_Tc` \ zero_sel_id ->
 747     newMethod DoOrigin
 748               (RealId then_sel_id) [m]          `thenNF_Tc` \ (m_lie, then_id) ->
 749     newMethod DoOrigin
 750               (RealId zero_sel_id) [m]          `thenNF_Tc` \ (mz_lie, zero_id) ->
 751
 752     let
 753       get_m_arg ty
 754         = newTyVarTy mkTypeKind                 `thenNF_Tc` \ arg_ty ->
 755           unifyTauTy (mkAppTy m arg_ty) ty      `thenTc_`
 756           returnTc arg_ty
 757
 758       go [stmt@(ExprStmt exp src_loc)]
 759         = tcAddSrcLoc src_loc $
 760           tcSetErrCtxt (stmtCtxt stmt) $
 761           tcExpr exp                            `thenTc`    \ (exp', exp_lie, exp_ty) ->
 762           returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
 763
 764       go (stmt@(ExprStmt exp src_loc) : stmts)
 765         = tcAddSrcLoc src_loc           (
 766           tcSetErrCtxt (stmtCtxt stmt)  (
 767                 tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 768                 get_m_arg exp_ty                `thenTc` \ a ->
 769                 returnTc (a, exp', exp_lie)
 770           ))                                    `thenTc` \ (a, exp',  exp_lie) ->
 771           go stmts                              `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
 772           get_m_arg stmts_ty                    `thenTc` \ b ->
 773           returnTc (ExprStmtOut exp' src_loc a b : stmts',
 774                     exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
 775                     stmts_ty)
 776
 777       go (stmt@(BindStmt pat exp src_loc) : stmts)
 778         = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 779           tcAddSrcLoc src_loc           (
 780           tcSetErrCtxt (stmtCtxt stmt)  (
 781                 tcPat pat               `thenTc`    \ (pat', pat_lie, pat_ty) ->
 782                 tcExpr exp              `thenTc`    \ (exp', exp_lie, exp_ty) ->
 783                 -- See comments with tcListComp on GeneratorQual
 784
 785                 get_m_arg exp_ty        `thenTc` \ a ->
 786                 unifyTauTy a pat_ty     `thenTc_`
 787                 returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
 788           ))                            `thenTc` \ (a, pat', exp', stmt_lie) ->
 789           go stmts                      `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
 790           get_m_arg stmts_ty            `thenTc` \ b ->
 791           returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
 792                     stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
 793                         (if failureFreePat pat' then emptyLIE else mz_lie),
 794                     stmts_ty)
 795
 796       go (LetStmt binds : stmts)
 797            = tcBindsAndThen             -- No error context, but a binding group is
 798                 combine                 -- rather a large thing for an error context anyway
 799                 binds
 800                 (go stmts)
 801            where
 802              combine binds' stmts' = LetStmt binds' : stmts'
 803     in
 804
 805     go stmts            `thenTc` \ (stmts', final_lie, final_ty) ->
 806     returnTc (HsDoOut stmts' then_id zero_id src_loc,
 807               final_lie,
 808               final_ty)
 809 \end{code}
 810
 811 Game plan for record bindings
 812 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 813 For each binding
 814         field = value
 815 1. look up "field", to find its selector Id, which must have type
 816         forall a1..an. T a1 .. an -> tau
 817    where tau is the type of the field.
 818
 819 2. Instantiate this type
 820
 821 3. Unify the (T a1 .. an) part with the "expected result type", which
 822    is passed in.  This checks that all the field labels come from the
 823    same type.
 824
 825 4. Type check the value using tcArg, passing tau as the expected
 826    argument type.
 827
 828 This extends OK when the field types are universally quantified.
 829
 830 Actually, to save excessive creation of fresh type variables,
 831 we
 832
 833 \begin{code}
 834 tcRecordBinds
 835         :: TcType s             -- Expected type of whole record
 836         -> RenamedRecordBinds
 837         -> TcM s (TcRecordBinds s, LIE s)
 838
 839 tcRecordBinds expected_record_ty rbinds
 840   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 841     returnTc (rbinds', plusLIEs lies)
 842   where
 843     do_bind (field_label, rhs, pun_flag)
 844       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 845         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 846
 847                 -- Record selectors all have type
 848                 --      forall a1..an.  T a1 .. an -> tau
 849         ASSERT( maybeToBool (getFunTy_maybe tau) )
 850         let
 851                 -- Selector must have type RecordType -> FieldType
 852           Just (record_ty, field_ty) = getFunTy_maybe tau
 853         in
 854         unifyTauTy expected_record_ty record_ty         `thenTc_`
 855         tcArg field_ty rhs                              `thenTc` \ (rhs', lie) ->
 856         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 857
 858 checkRecordFields :: RenamedRecordBinds -> Id -> Bool   -- True iff all the fields in
 859                                                         -- RecordBinds are field of the
 860                                                         -- specified constructor
 861 checkRecordFields rbinds data_con
 862   = all ok rbinds
 863   where
 864     data_con_fields = dataConFieldLabels data_con
 865
 866     ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
 867
 868     match field_name field_label = field_name == fieldLabelName field_label
 869 \end{code}
 870
 871 %************************************************************************
 872 %*                                                                      *
 873 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
 879
 880 tcExprs [] = returnTc ([], emptyLIE, [])
 881 tcExprs (expr:exprs)
 882  = tcExpr  expr                 `thenTc` \ (expr',  lie1, ty) ->
 883    tcExprs exprs                `thenTc` \ (exprs', lie2, tys) ->
 884    returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
 885 \end{code}
 886
 887
 888 % =================================================
 889
 890 Errors and contexts
 891 ~~~~~~~~~~~~~~~~~~~
 892
 893 Mini-utils:
 894 \begin{code}
 895 pp_nest_hang :: String -> Pretty -> Pretty
 896 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 897 \end{code}
 898
 899 Boring and alphabetical:
 900 \begin{code}
 901 arithSeqCtxt expr sty
 902   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 903
 904 branchCtxt b1 b2 sty
 905   = ppSep [ppStr "In the branches of a conditional:",
 906            pp_nest_hang "`then' branch:" (ppr sty b1),
 907            pp_nest_hang "`else' branch:" (ppr sty b2)]
 908
 909 caseCtxt expr sty
 910   = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
 911
 912 exprSigCtxt expr sty
 913   = ppHang (ppStr "In an expression with a type signature:")
 914          4 (ppr sty expr)
 915
 916 listCtxt expr sty
 917   = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
 918
 919 predCtxt expr sty
 920   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
 921
 922 sectionRAppCtxt expr sty
 923   = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
 924
 925 sectionLAppCtxt expr sty
 926   = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
 927
 928 funAppCtxt fun arg_no arg sty
 929   = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
 930          4 (ppCat [ppStr "namely", ppr sty arg])
 931
 932 qualCtxt qual sty
 933   = ppHang (ppStr "In a list-comprehension qualifer:")
 934          4 (ppr sty qual)
 935
 936 stmtCtxt stmt sty
 937   = ppHang (ppStr "In a do statement:")
 938          4 (ppr sty stmt)
 939
 940 tooManyArgsCtxt f sty
 941   = ppHang (ppStr "Too many arguments in an application of the function")
 942          4 (ppr sty f)
 943
 944 lurkingRank2Err fun fun_ty sty
 945   = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
 946          4 (ppAboves [ppStr "It is applied to too few arguments,",
 947                       ppStr "so that the result type has for-alls in it"])
 948
 949 rank2ArgCtxt arg expected_arg_ty sty
 950   = ppHang (ppStr "In a polymorphic function argument:")
 951          4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
 952                    ppr sty expected_arg_ty])
 953
 954 badFieldsUpd rbinds sty
 955   = ppHang (ppStr "No constructor has all these fields:")
 956          4 (interpp'SP sty fields)
 957   where
 958     fields = [field | (field, _, _) <- rbinds]
 959
 960 recordUpdCtxt sty = ppStr "In a record update construct"
 961
 962 badFieldsCon con rbinds sty
 963   = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
 964          4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
 965   where
 966     fields = [field | (field, _, _) <- rbinds]
 967 \end{code}