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 import Ubiq
  12
  13 import HsSyn            ( HsExpr(..), Qual(..), Stmt(..),
  14                           HsBinds(..), Bind(..), MonoBinds(..),
  15                           ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
  16                           Match, Fake, InPat, OutPat, PolyType,
  17                           irrefutablePat, collectPatBinders )
  18 import RnHsSyn          ( RenamedHsExpr(..), RenamedQual(..),
  19                           RenamedStmt(..), RenamedRecordBinds(..),
  20                           RnName{-instance Outputable-}
  21                         )
  22 import TcHsSyn          ( TcExpr(..), TcQual(..), TcStmt(..),
  23                           TcIdOcc(..), TcRecordBinds(..),
  24                           mkHsTyApp
  25                         )
  26
  27 import TcMonad
  28 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  29                           LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
  30                           newMethod, newMethodWithGivenTy, newDicts )
  31 import TcBinds          ( tcBindsAndThen )
  32 import TcEnv            ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
  33                           tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
  34                           tcGlobalOcc
  35                         )
  36 import TcMatches        ( tcMatchesCase, tcMatch )
  37 import TcMonoType       ( tcPolyType )
  38 import TcPat            ( tcPat )
  39 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyRank2 )
  40 import TcType           ( TcType(..), TcMaybe(..),
  41                           tcInstType, tcInstTcType, tcInstTyVars,
  42                           newTyVarTy, zonkTcTyVars, zonkTcType )
  43 import TcKind           ( TcKind )
  44
  45 import Class            ( Class(..), getClassSig )
  46 import FieldLabel       ( fieldLabelName )
  47 import Id               ( Id(..), GenId, idType, dataConFieldLabels )
  48 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
  49 import GenSpecEtc       ( checkSigTyVars, checkSigTyVarsGivenGlobals )
  50 import Name             ( Name{-instance Eq-} )
  51 import PrelInfo         ( intPrimTy, charPrimTy, doublePrimTy,
  52                           floatPrimTy, addrPrimTy, addrTy,
  53                           boolTy, charTy, stringTy, mkListTy,
  54                           mkTupleTy, mkPrimIoTy )
  55 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
  56                           getTyVar_maybe, getFunTy_maybe,
  57                           splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
  58                           isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
  59                           maybeAppDataTyCon
  60                         )
  61 import TyVar            ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
  62 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
  63 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey,
  64                           enumFromClassOpKey, enumFromThenClassOpKey,
  65                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  66                           monadClassKey, monadZeroClassKey )
  67
  68 --import Name           ( Name )                -- Instance
  69 import Outputable       ( interpp'SP )
  70 import PprType          ( GenType, GenTyVar )   -- Instances
  71 import Maybes           ( maybeToBool )
  72 import Pretty
  73 import Util
  74 \end{code}
  75
  76 \begin{code}
  77 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{The TAUT rules for variables}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 tcExpr (HsVar name)
  88   = tcId name           `thenTc` \ (expr', lie, res_ty) ->
  89
  90     -- Check that the result type doesn't have any nested for-alls.
  91     -- For example, a "build" on its own is no good; it must be
  92     -- applied to something.
  93     checkTc (isTauTy res_ty)
  94             (lurkingRank2Err name res_ty) `thenTc_`
  95
  96     returnTc (expr', lie, res_ty)
  97 \end{code}
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection{Literals}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 Overloaded literals.
 106
 107 \begin{code}
 108 tcExpr (HsLit (HsInt i))
 109   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 110
 111     newOverloadedLit (LiteralOrigin (HsInt i))
 112                      (OverloadedIntegral i)
 113                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 114
 115     returnTc (HsVar over_lit_id, lie, ty)
 116
 117 tcExpr (HsLit (HsFrac f))
 118   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 119
 120     newOverloadedLit (LiteralOrigin (HsFrac f))
 121                      (OverloadedFractional f)
 122                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 123
 124     returnTc (HsVar over_lit_id, lie, ty)
 125
 126 tcExpr (HsLit lit@(HsLitLit s))
 127   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 128     newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ ty ->
 129     newDicts (LitLitOrigin (_UNPK_ s))
 130              [(cCallableClass, ty)]                     `thenNF_Tc` \ (dicts, _) ->
 131     returnTc (HsLitOut lit ty, dicts, ty)
 132 \end{code}
 133
 134 Primitive literals:
 135
 136 \begin{code}
 137 tcExpr (HsLit lit@(HsCharPrim c))
 138   = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
 139
 140 tcExpr (HsLit lit@(HsStringPrim s))
 141   = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
 142
 143 tcExpr (HsLit lit@(HsIntPrim i))
 144   = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
 145
 146 tcExpr (HsLit lit@(HsFloatPrim f))
 147   = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
 148
 149 tcExpr (HsLit lit@(HsDoublePrim d))
 150   = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
 151 \end{code}
 152
 153 Unoverloaded literals:
 154
 155 \begin{code}
 156 tcExpr (HsLit lit@(HsChar c))
 157   = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
 158
 159 tcExpr (HsLit lit@(HsString str))
 160   = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
 161 \end{code}
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsection{Other expression forms}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 \begin{code}
 170 tcExpr (HsLam match)
 171   = tcMatch match       `thenTc` \ (match',lie,ty) ->
 172     returnTc (HsLam match', lie, ty)
 173
 174 tcExpr (HsApp e1 e2) = accum e1 [e2]
 175   where
 176     accum (HsApp e1 e2) args = accum e1 (e2:args)
 177     accum fun args
 178       = tcApp fun args  `thenTc` \ (fun', args', lie, res_ty) ->
 179         returnTc (foldl HsApp fun' args', lie, res_ty)
 180
 181 -- equivalent to (op e1) e2:
 182 tcExpr (OpApp arg1 op arg2)
 183   = tcApp op [arg1,arg2]        `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
 184     returnTc (OpApp arg1' op' arg2', lie, res_ty)
 185 \end{code}
 186
 187 Note that the operators in sections are expected to be binary, and
 188 a type error will occur if they aren't.
 189
 190 \begin{code}
 191 -- Left sections, equivalent to
 192 --      \ x -> e op x,
 193 -- or
 194 --      \ x -> op e x,
 195 -- or just
 196 --      op e
 197
 198 tcExpr in_expr@(SectionL arg op)
 199   = tcApp op [arg]              `thenTc` \ (op', [arg'], lie, res_ty) ->
 200
 201         -- Check that res_ty is a function type
 202         -- Without this check we barf in the desugarer on
 203         --      f op = (3 `op`)
 204         -- because it tries to desugar to
 205         --      f op = \r -> 3 op r
 206         -- so (3 `op`) had better be a function!
 207     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty1 ->
 208     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty2 ->
 209     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 210     unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
 211
 212     returnTc (SectionL arg' op', lie, res_ty)
 213
 214 -- Right sections, equivalent to \ x -> x op expr, or
 215 --      \ x -> op x expr
 216
 217 tcExpr in_expr@(SectionR op expr)
 218   = tcExpr op                   `thenTc`    \ (op',  lie1, op_ty) ->
 219     tcExpr expr                 `thenTc`    \ (expr',lie2, expr_ty) ->
 220
 221     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty1 ->
 222     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty2 ->
 223     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 224     unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
 225
 226     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 227 \end{code}
 228
 229 The interesting thing about @ccall@ is that it is just a template
 230 which we instantiate by filling in details about the types of its
 231 argument and result (ie minimal typechecking is performed).  So, the
 232 basic story is that we allocate a load of type variables (to hold the
 233 arg/result types); unify them with the args/result; and store them for
 234 later use.
 235
 236 \begin{code}
 237 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
 238   =     -- Get the callable and returnable classes.
 239     tcLookupClassByKey cCallableClassKey        `thenNF_Tc` \ cCallableClass ->
 240     tcLookupClassByKey cReturnableClassKey      `thenNF_Tc` \ cReturnableClass ->
 241
 242     let
 243         new_arg_dict (arg, arg_ty)
 244           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 245                      [(cCallableClass, arg_ty)]         `thenNF_Tc` \ (arg_dicts, _) ->
 246             returnNF_Tc arg_dicts       -- Actually a singleton bag
 247
 248         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 249     in
 250
 251         -- Arguments
 252     tcExprs args                        `thenTc` \ (args', args_lie, arg_tys) ->
 253
 254         -- The argument types can be unboxed or boxed; the result
 255         -- type must, however, be boxed since it's an argument to the PrimIO
 256         -- type constructor.
 257     newTyVarTy mkBoxedTypeKind                  `thenNF_Tc` \ result_ty ->
 258
 259         -- Construct the extra insts, which encode the
 260         -- constraints on the argument and result types.
 261     mapNF_Tc new_arg_dict (args `zip` arg_tys)                  `thenNF_Tc` \ ccarg_dicts_s ->
 262     newDicts result_origin [(cReturnableClass, result_ty)]      `thenNF_Tc` \ (ccres_dict, _) ->
 263
 264     returnTc (CCall lbl args' may_gc is_asm result_ty,
 265               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
 266               mkPrimIoTy result_ty)
 267 \end{code}
 268
 269 \begin{code}
 270 tcExpr (HsSCC label expr)
 271   = tcExpr expr         `thenTc` \ (expr', lie, expr_ty) ->
 272          -- No unification. Give SCC the type of expr
 273     returnTc (HsSCC label expr', lie, expr_ty)
 274
 275 tcExpr (HsLet binds expr)
 276   = tcBindsAndThen
 277         HsLet                   -- The combiner
 278         binds                   -- Bindings to check
 279         (tcExpr expr)           -- Typechecker for the expression
 280
 281 tcExpr in_expr@(HsCase expr matches src_loc)
 282   = tcAddSrcLoc src_loc $
 283     tcExpr expr                 `thenTc`    \ (expr',lie1,expr_ty) ->
 284     newTyVarTy mkTypeKind       `thenNF_Tc` \ result_ty ->
 285
 286     tcAddErrCtxt (caseCtxt in_expr) $
 287     tcMatchesCase (mkFunTy expr_ty result_ty) matches
 288                                 `thenTc`    \ (matches',lie2) ->
 289
 290     returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
 291
 292 tcExpr (HsIf pred b1 b2 src_loc)
 293   = tcAddSrcLoc src_loc $
 294     tcExpr pred                 `thenTc`    \ (pred',lie1,predTy) ->
 295
 296     tcAddErrCtxt (predCtxt pred) (
 297       unifyTauTy predTy boolTy
 298     )                           `thenTc_`
 299
 300     tcExpr b1                   `thenTc`    \ (b1',lie2,result_ty) ->
 301     tcExpr b2                   `thenTc`    \ (b2',lie3,b2Ty) ->
 302
 303     tcAddErrCtxt (branchCtxt b1 b2) $
 304     unifyTauTy result_ty b2Ty                           `thenTc_`
 305
 306     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 307
 308 tcExpr (ListComp expr quals)
 309   = tcListComp expr quals       `thenTc` \ ((expr',quals'), lie, ty) ->
 310     returnTc (ListComp expr' quals', lie, ty)
 311 \end{code}
 312
 313 \begin{code}
 314 tcExpr (HsDo stmts src_loc)
 315   =     -- get the Monad and MonadZero classes
 316         -- create type consisting of a fresh monad tyvar
 317     tcAddSrcLoc src_loc $
 318     newTyVarTy monadKind        `thenNF_Tc` \ m ->
 319     tcDoStmts False m stmts     `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
 320
 321         -- create dictionaries for monad and possibly monadzero
 322     (if monad then
 323         tcLookupClassByKey monadClassKey                `thenNF_Tc` \ monadClass ->
 324         newDicts DoOrigin [(monadClass, m)]
 325     else
 326         returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
 327     )                                           `thenNF_Tc` \ (m_lie,  [m_id])  ->
 328     (if mzero then
 329         tcLookupClassByKey monadZeroClassKey    `thenNF_Tc` \ monadZeroClass ->
 330         newDicts DoOrigin [(monadZeroClass, m)]
 331      else
 332         returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
 333     )                                           `thenNF_Tc` \ (mz_lie, [mz_id]) ->
 334
 335     returnTc (HsDoOut stmts' m_id mz_id src_loc,
 336               lie `plusLIE` m_lie `plusLIE` mz_lie,
 337               do_ty)
 338   where
 339     monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
 340 \end{code}
 341
 342 \begin{code}
 343 tcExpr (ExplicitList [])
 344   = newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
 345     returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
 346
 347
 348 tcExpr in_expr@(ExplicitList exprs)     -- Non-empty list
 349   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
 350     tcAddErrCtxt (listCtxt in_expr) $
 351     unifyTauTyList tys                  `thenTc_`
 352     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 353
 354 tcExpr (ExplicitTuple exprs)
 355   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys) ->
 356     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 357
 358 tcExpr (RecordCon (HsVar con) rbinds)
 359   = tcGlobalOcc con             `thenNF_Tc` \ (con_id, arg_tys, con_rho) ->
 360     let
 361         (con_theta, con_tau) = splitRhoTy con_rho
 362         (_, record_ty)       = splitFunTy con_tau
 363         con_expr             = mkHsTyApp (HsVar (RealId con_id)) arg_tys
 364     in
 365         -- TEMPORARY ASSERT
 366     ASSERT( null con_theta )
 367
 368         -- Con is syntactically constrained to be a data constructor
 369     ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
 370
 371     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 372
 373     checkTc (checkRecordFields rbinds con_id)
 374             (badFieldsCon con rbinds)           `thenTc_`
 375
 376     returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty)
 377
 378 tcExpr (RecordUpd record_expr rbinds)
 379   = tcExpr record_expr                  `thenTc` \ (record_expr', record_lie, record_ty) ->
 380     tcRecordBinds record_ty rbinds      `thenTc` \ (rbinds', rbinds_lie) ->
 381
 382         -- Check that the field names are plausible
 383     zonkTcType record_ty                `thenNF_Tc` \ record_ty' ->
 384     let
 385         maybe_tycon_stuff = maybeAppDataTyCon record_ty'
 386         Just (tycon, args_tys, data_cons) = maybe_tycon_stuff
 387     in
 388     checkTc (maybeToBool maybe_tycon_stuff)
 389             (panic "TcExpr:Records:mystery error message") `thenTc_`
 390     checkTc (any (checkRecordFields rbinds) data_cons)
 391             (badFieldsUpd rbinds)               `thenTc_`
 392     returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, 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    tcInstType [] 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
 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     let
 572         (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
 573     in
 574     ASSERT( null expected_theta )       -- And expected_tyvars are all DontBind things
 575
 576         -- Type-check the arg and unify with expected type
 577     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 578     unifyTauTy expected_tau actual_arg_ty       `thenTc_`  (
 579
 580         -- Check that the arg_tyvars havn't been constrained
 581         -- The interesting bit here is that we must include the free variables
 582         -- of the expected arg ty.  Here's an example:
 583         --       runST (newVar True)
 584         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 585         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 586         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 587         -- So now s' isn't unconstrained because it's linked to a.
 588         -- Conclusion: include the free vars of the expected arg type in the
 589         -- list of "free vars" for the signature check.
 590     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
 591     tcGetGlobalTyVars                                           `thenNF_Tc` \ env_tyvars ->
 592     zonkTcTyVars (tyVarsOfType expected_arg_ty)                 `thenNF_Tc` \ free_tyvars ->
 593     checkSigTyVarsGivenGlobals
 594         (env_tyvars `unionTyVarSets` free_tyvars)
 595         expected_tyvars expected_tau                            `thenTc_`
 596
 597         -- Check that there's no overloading involved
 598         -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
 599         -- but which, on simplification, don't actually need a dictionary involving
 600         -- the tyvar.  So we have to do a proper simplification right here.
 601     tcSimplifyRank2 (mkTyVarSet expected_tyvars)
 602                     lie_arg                             `thenTc` \ (free_insts, inst_binds) ->
 603
 604         -- This HsLet binds any Insts which came out of the simplification.
 605         -- It's a bit out of place here, but using AbsBind involves inventing
 606         -- a couple of new names which seems worse.
 607     returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
 608     )
 609   where
 610
 611     mk_binds []
 612         = EmptyBinds
 613     mk_binds ((inst,rhs):inst_binds)
 614         = (SingleBind (NonRecBind (VarMonoBind inst rhs)))
 615                 `ThenBinds`
 616           mk_binds inst_binds
 617 \end{code}
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{@tcId@ typchecks an identifier occurrence}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626 tcId :: RnName -> TcM s (TcExpr s, LIE s, TcType s)
 627
 628 tcId name
 629   =     -- Look up the Id and instantiate its type
 630     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 631
 632     (case maybe_local of
 633         Just tc_id -> let
 634                         (tyvars, rho) = splitForAllTy (idType tc_id)
 635                       in
 636                       tcInstTyVars tyvars               `thenNF_Tc` \ (tyvars', arg_tys', tenv)  ->
 637                       tcInstTcType tenv rho             `thenNF_Tc` \ rho' ->
 638                       returnNF_Tc (TcId tc_id, arg_tys', rho')
 639
 640         Nothing ->    tcGlobalOcc name                  `thenNF_Tc` \ (id, arg_tys, rho) ->
 641                       returnNF_Tc (RealId id, arg_tys, rho)
 642
 643     )                                   `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
 644
 645         -- Is it overloaded?
 646     case splitRhoTy rho of
 647       ([], tau)    ->   -- Not overloaded, so just make a type application
 648                         returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 649
 650       (theta, tau) ->   -- Overloaded, so make a Method inst
 651                         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 652                                 tc_id_occ arg_tys rho           `thenNF_Tc` \ (lie, meth_id) ->
 653                         returnTc (HsVar meth_id, lie, tau)
 654 \end{code}
 655
 656
 657
 658 %************************************************************************
 659 %*                                                                      *
 660 \subsection{@tcQuals@ typchecks list comprehension qualifiers}
 661 %*                                                                      *
 662 %************************************************************************
 663
 664 \begin{code}
 665 tcListComp expr []
 666   = tcExpr expr         `thenTc` \ (expr', lie, ty) ->
 667     returnTc ((expr',[]), lie, mkListTy ty)
 668
 669 tcListComp expr (qual@(FilterQual filter) : quals)
 670   = tcAddErrCtxt (qualCtxt qual) (
 671         tcExpr filter                   `thenTc` \ (filter', filter_lie, filter_ty) ->
 672         unifyTauTy boolTy filter_ty     `thenTc_`
 673         returnTc (FilterQual filter', filter_lie)
 674     )                                   `thenTc` \ (qual', qual_lie) ->
 675
 676     tcListComp expr quals       `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
 677
 678     returnTc ((expr', qual' : quals'),
 679               qual_lie `plusLIE` rest_lie,
 680               res_ty)
 681
 682 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
 683   = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
 684
 685       tcAddErrCtxt (qualCtxt qual) (
 686         tcPat pat                               `thenTc` \ (pat',  lie_pat,  pat_ty)  ->
 687         tcExpr rhs                              `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
 688         unifyTauTy (mkListTy pat_ty) rhs_ty     `thenTc_`
 689         returnTc (GeneratorQual pat' rhs',
 690                   lie_pat `plusLIE` lie_rhs)
 691       )                                         `thenTc` \ (qual', lie_qual) ->
 692
 693       tcListComp expr quals                     `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
 694
 695       returnTc ((expr', qual' : quals'),
 696                 lie_qual `plusLIE` lie_rest,
 697                 res_ty)
 698     )
 699   where
 700     binder_names = collectPatBinders pat
 701
 702 tcListComp expr (LetQual binds : quals)
 703   = tcBindsAndThen              -- No error context, but a binding group is
 704         combine                 -- rather a large thing for an error context anyway
 705         binds
 706         (tcListComp expr quals)
 707   where
 708     combine binds' (expr',quals') = (expr', LetQual binds' : quals')
 709 \end{code}
 710
 711
 712 %************************************************************************
 713 %*                                                                      *
 714 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 715 %*                                                                      *
 716 %************************************************************************
 717
 718 \begin{code}
 719 tcDoStmts :: Bool                       -- True => require a monad
 720           -> TcType s                   -- m
 721           -> [RenamedStmt]
 722           -> TcM s (([TcStmt s],
 723                      Bool,              -- True => Monad
 724                      Bool),             -- True => MonadZero
 725                     LIE s,
 726                     TcType s)
 727
 728 tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
 729   = tcAddSrcLoc src_loc $
 730     tcSetErrCtxt (stmtCtxt stmt) $
 731     tcExpr exp                          `thenTc`    \ (exp', exp_lie, exp_ty) ->
 732     (if monad then
 733         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 734         unifyTauTy (mkAppTy m a) exp_ty
 735      else
 736         returnTc ()
 737     )                                   `thenTc_`
 738     returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
 739
 740 tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
 741   = tcAddSrcLoc src_loc                 (
 742     tcSetErrCtxt (stmtCtxt stmt)        (
 743         tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 744         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 745         unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
 746         returnTc (ExprStmt exp' src_loc, exp_lie)
 747     ))                                  `thenTc` \ (stmt',  stmt_lie) ->
 748     tcDoStmts True m stmts              `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
 749     returnTc ((stmt':stmts', True, mzero),
 750               stmt_lie `plusLIE` stmts_lie,
 751               stmts_ty)
 752
 753 tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
 754   = tcAddSrcLoc src_loc                 (
 755     tcSetErrCtxt (stmtCtxt stmt)        (
 756         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 757         tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 758         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 759         unifyTauTy a pat_ty             `thenTc_`
 760         unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
 761         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
 762     ))                                  `thenTc` \ (stmt', stmt_lie, failure_free) ->
 763     tcDoStmts True m stmts              `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
 764     returnTc ((stmt':stmts', True, mzero || not failure_free),
 765               stmt_lie `plusLIE` stmts_lie,
 766               stmts_ty)
 767
 768 tcDoStmts monad m (LetStmt binds : stmts)
 769    = tcBindsAndThen             -- No error context, but a binding group is
 770         combine                 -- rather a large thing for an error context anyway
 771         binds
 772         (tcDoStmts monad m stmts)
 773    where
 774      combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
 775
 776 \end{code}
 777
 778 Game plan for record bindings
 779 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 780 For each binding
 781         field = value
 782 1. look up "field", to find its selector Id, which must have type
 783         forall a1..an. T a1 .. an -> tau
 784    where tau is the type of the field.
 785
 786 2. Instantiate this type
 787
 788 3. Unify the (T a1 .. an) part with the "expected result type", which
 789    is passed in.  This checks that all the field labels come from the
 790    same type.
 791
 792 4. Type check the value using tcArg, passing tau as the expected
 793    argument type.
 794
 795 This extends OK when the field types are universally quantified.
 796
 797 Actually, to save excessive creation of fresh type variables,
 798 we
 799
 800 \begin{code}
 801 tcRecordBinds
 802         :: TcType s             -- Expected type of whole record
 803         -> RenamedRecordBinds
 804         -> TcM s (TcRecordBinds s, LIE s)
 805
 806 tcRecordBinds expected_record_ty rbinds
 807   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 808     returnTc (rbinds', plusLIEs lies)
 809   where
 810     do_bind (field_label, rhs, pun_flag)
 811       = tcGlobalOcc field_label         `thenNF_Tc` \ (sel_id, _, tau) ->
 812
 813                 -- Record selectors all have type
 814                 --      forall a1..an.  T a1 .. an -> tau
 815         ASSERT( maybeToBool (getFunTy_maybe tau) )
 816         let
 817                 -- Selector must have type RecordType -> FieldType
 818           Just (record_ty, field_ty) = getFunTy_maybe tau
 819         in
 820         unifyTauTy expected_record_ty record_ty         `thenTc_`
 821         tcArg field_ty rhs                              `thenTc` \ (rhs', lie) ->
 822         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 823
 824 checkRecordFields :: RenamedRecordBinds -> Id -> Bool   -- True iff all the fields in
 825                                                         -- RecordBinds are field of the
 826                                                         -- specified constructor
 827 checkRecordFields rbinds data_con
 828   = all ok rbinds
 829   where
 830     data_con_fields = dataConFieldLabels data_con
 831
 832     ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
 833
 834     match field_name field_label = field_name == fieldLabelName field_label
 835 \end{code}
 836
 837 %************************************************************************
 838 %*                                                                      *
 839 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 840 %*                                                                      *
 841 %************************************************************************
 842
 843 \begin{code}
 844 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
 845
 846 tcExprs [] = returnTc ([], emptyLIE, [])
 847 tcExprs (expr:exprs)
 848  = tcExpr  expr                 `thenTc` \ (expr',  lie1, ty) ->
 849    tcExprs exprs                `thenTc` \ (exprs', lie2, tys) ->
 850    returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
 851 \end{code}
 852
 853
 854 % =================================================
 855
 856 Errors and contexts
 857 ~~~~~~~~~~~~~~~~~~~
 858
 859 Mini-utils:
 860 \begin{code}
 861 pp_nest_hang :: String -> Pretty -> Pretty
 862 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 863 \end{code}
 864
 865 Boring and alphabetical:
 866 \begin{code}
 867 arithSeqCtxt expr sty
 868   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 869
 870 branchCtxt b1 b2 sty
 871   = ppSep [ppStr "In the branches of a conditional:",
 872            pp_nest_hang "`then' branch:" (ppr sty b1),
 873            pp_nest_hang "`else' branch:" (ppr sty b2)]
 874
 875 caseCtxt expr sty
 876   = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
 877
 878 exprSigCtxt expr sty
 879   = ppHang (ppStr "In an expression with a type signature:")
 880          4 (ppr sty expr)
 881
 882 listCtxt expr sty
 883   = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
 884
 885 predCtxt expr sty
 886   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
 887
 888 sectionRAppCtxt expr sty
 889   = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
 890
 891 sectionLAppCtxt expr sty
 892   = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
 893
 894 funAppCtxt fun arg_no arg sty
 895   = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
 896          4 (ppCat [ppStr "namely", ppr sty arg])
 897
 898 qualCtxt qual sty
 899   = ppHang (ppStr "In a list-comprehension qualifer:")
 900          4 (ppr sty qual)
 901
 902 stmtCtxt stmt sty
 903   = ppHang (ppStr "In a do statement:")
 904          4 (ppr sty stmt)
 905
 906 tooManyArgsCtxt f sty
 907   = ppHang (ppStr "Too many arguments in an application of the function")
 908          4 (ppr sty f)
 909
 910 lurkingRank2Err fun fun_ty sty
 911   = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
 912          4 (ppAboves [ppStr "It is applied to too few arguments,",
 913                       ppStr "so that the result type has for-alls in it"])
 914
 915 rank2ArgCtxt arg expected_arg_ty sty
 916   = ppHang (ppStr "In a polymorphic function argument:")
 917          4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
 918                    ppr sty expected_arg_ty])
 919
 920 badFieldsUpd rbinds sty
 921   = ppHang (ppStr "In a record update construct, no constructor has all these fields:")
 922          4 (interpp'SP sty fields)
 923   where
 924     fields = [field | (field, _, _) <- rbinds]
 925
 926 badFieldsCon con rbinds sty
 927   = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
 928          4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
 929   where
 930     fields = [field | (field, _, _) <- rbinds]
 931 \end{code}