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