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