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