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