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