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