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" $
 381                                        getAppDataTyCon record_ty'
 382         -- The record binds are non-empty (syntax); so at least one field
 383         -- label will have been unified with record_ty by tcRecordBinds;
 384         -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
 385         (tyvars, theta, _, _) = dataConSig (head data_cons)
 386     in
 387     tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
 388     newDicts RecordUpdOrigin theta'                                 `thenNF_Tc` \ (con_lie, dicts) ->
 389     checkTc (any (checkRecordFields rbinds) data_cons)
 390             (badFieldsUpd rbinds)               `thenTc_`
 391
 392     returnTc (RecordUpdOut record_expr' dicts rbinds',
 393               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
 394               record_ty)
 395
 396 tcExpr (ArithSeqIn seq@(From expr))
 397   = tcExpr expr                                 `thenTc`    \ (expr', lie1, ty) ->
 398
 399     tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
 400     newMethod (ArithSeqOrigin seq)
 401               (RealId sel_id) [ty]              `thenNF_Tc` \ (lie2, enum_from_id) ->
 402
 403     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 404               lie1 `plusLIE` lie2,
 405               mkListTy ty)
 406
 407 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
 408   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 409     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 410
 411     tcAddErrCtxt (arithSeqCtxt in_expr) $
 412     unifyTauTyList [ty1, ty2]                           `thenTc_`
 413
 414     tcLookupGlobalValueByKey enumFromThenClassOpKey     `thenNF_Tc` \ sel_id ->
 415     newMethod (ArithSeqOrigin seq)
 416               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 417
 418     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 419                            (FromThen expr1' expr2'),
 420               lie1 `plusLIE` lie2 `plusLIE` lie3,
 421               mkListTy ty1)
 422
 423 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
 424   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 425     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 426
 427     tcAddErrCtxt (arithSeqCtxt in_expr) $
 428     unifyTauTyList [ty1,ty2]    `thenTc_`
 429
 430     tcLookupGlobalValueByKey enumFromToClassOpKey       `thenNF_Tc` \ sel_id ->
 431     newMethod (ArithSeqOrigin seq)
 432               (RealId sel_id) [ty1]             `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 433
 434     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 435                           (FromTo expr1' expr2'),
 436               lie1 `plusLIE` lie2 `plusLIE` lie3,
 437                mkListTy ty1)
 438
 439 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 440   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 441     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 442     tcExpr expr3                `thenTc`    \ (expr3',lie3,ty3) ->
 443
 444     tcAddErrCtxt  (arithSeqCtxt in_expr) $
 445     unifyTauTyList [ty1,ty2,ty3]                        `thenTc_`
 446
 447     tcLookupGlobalValueByKey enumFromThenToClassOpKey   `thenNF_Tc` \ sel_id ->
 448     newMethod (ArithSeqOrigin seq)
 449               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie4, eft_id) ->
 450
 451     returnTc (ArithSeqOut (HsVar eft_id)
 452                            (FromThenTo expr1' expr2' expr3'),
 453               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
 454               mkListTy ty1)
 455 \end{code}
 456
 457 %************************************************************************
 458 %*                                                                      *
 459 \subsection{Expressions type signatures}
 460 %*                                                                      *
 461 %************************************************************************
 462
 463 \begin{code}
 464 tcExpr in_expr@(ExprWithTySig expr poly_ty)
 465  = tcExpr expr                  `thenTc` \ (texpr, lie, tau_ty) ->
 466    tcPolyType  poly_ty          `thenTc` \ sigma_sig ->
 467
 468         -- Check the tau-type part
 469    tcSetErrCtxt (exprSigCtxt in_expr)   $
 470    tcInstSigType sigma_sig              `thenNF_Tc` \ sigma_sig' ->
 471    let
 472         (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
 473    in
 474    unifyTauTy sig_tau' tau_ty           `thenTc_`
 475
 476         -- Check the type variables of the signature
 477    checkSigTyVars sig_tyvars' sig_tau'  `thenTc_`
 478
 479         -- Check overloading constraints
 480    newDicts SignatureOrigin sig_theta'          `thenNF_Tc` \ (sig_dicts, _) ->
 481    tcSimplifyAndCheck
 482         (mkTyVarSet sig_tyvars')
 483         sig_dicts lie                           `thenTc_`
 484
 485         -- If everything is ok, return the stuff unchanged, except for
 486         -- the effect of any substutions etc.  We simply discard the
 487         -- result of the tcSimplifyAndCheck, except for any default
 488         -- resolution it may have done, which is recorded in the
 489         -- substitution.
 490    returnTc (texpr, lie, tau_ty)
 491 \end{code}
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection{@tcApp@ typchecks an application}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 \begin{code}
 500 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 501       -> TcM s (TcExpr s, [TcExpr s],       -- Translated fun and args
 502                 LIE s,
 503                 TcType s)                   -- Type of the application
 504
 505 tcApp fun args
 506   =     -- First type-check the function
 507         -- In the HsVar case we go straight to tcId to avoid hitting the
 508         -- rank-2 check, which we check later here anyway
 509     (case fun of
 510         HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
 511         other      -> tcExpr fun
 512     )                                   `thenTc` \ (fun', lie_fun, fun_ty) ->
 513
 514     tcApp_help fun 1 fun_ty args        `thenTc` \ (args', lie_args, res_ty) ->
 515
 516     -- Check that the result type doesn't have any nested for-alls.
 517     -- For example, a "build" on its own is no good; it must be applied to something.
 518     checkTc (isTauTy res_ty)
 519             (lurkingRank2Err fun fun_ty) `thenTc_`
 520
 521     returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
 522
 523
 524 tcApp_help :: RenamedHsExpr -> Int      -- Function and arg position, used in error message(s)
 525            -> TcType s                  -- The type of the function
 526            -> [RenamedHsExpr]           -- Arguments
 527            -> TcM s ([TcExpr s],                -- Typechecked args
 528                      LIE s,
 529                      TcType s)          -- Result type of the application
 530
 531 tcApp_help orig_fun arg_no fun_ty []
 532   = returnTc ([], emptyLIE, fun_ty)
 533
 534 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
 535   =     -- Expect the function to have type A->B
 536     tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
 537             unifyFunTy fun_ty
 538     )                                                   `thenTc` \ (expected_arg_ty, result_ty) ->
 539
 540         -- Type check the argument
 541     tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
 542                 tcArg expected_arg_ty arg
 543     )                                                   `thenTc` \ (arg', lie_arg) ->
 544
 545         -- Do the other args
 546     tcApp_help orig_fun (arg_no+1) result_ty args       `thenTc` \ (args', lie_args, res_ty) ->
 547
 548         -- Done
 549     returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
 550
 551 \end{code}
 552
 553 \begin{code}
 554 tcArg :: TcType s                       -- Expected arg type
 555       -> RenamedHsExpr                  -- Actual argument
 556       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 557
 558 tcArg expected_arg_ty arg
 559   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
 560   =     -- The ordinary, non-rank-2 polymorphic case
 561     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 562     unifyTauTy expected_arg_ty actual_arg_ty    `thenTc_`
 563     returnTc (arg', lie_arg)
 564
 565   | otherwise
 566   =     -- Ha!  The argument type of the function is a for-all type,
 567         -- An example of rank-2 polymorphism.
 568
 569         -- No need to instantiate the argument type... it's must be the result
 570         -- of instantiating a function involving rank-2 polymorphism, so there
 571         -- isn't any danger of using the same tyvars twice
 572         -- The argument type shouldn't be overloaded type (hence ASSERT)
 573
 574         -- To ensure that the forall'd type variables don't get unified with each
 575         -- other or any other types, we make fresh *signature* type variables
 576         -- and unify them with the tyvars.
 577     tcInstSigTcType expected_arg_ty     `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 578     let
 579         (sig_theta, sig_tau) = splitRhoTy sig_rho
 580     in
 581     ASSERT( null sig_theta )    -- And expected_tyvars are all DontBind things
 582
 583         -- Type-check the arg and unify with expected type
 584     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 585     unifyTauTy sig_tau actual_arg_ty            `thenTc_`
 586
 587         -- Check that the arg_tyvars havn't been constrained
 588         -- The interesting bit here is that we must include the free variables
 589         -- of the expected arg ty.  Here's an example:
 590         --       runST (newVar True)
 591         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 592         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 593         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 594         -- So now s' isn't unconstrained because it's linked to a.
 595         -- Conclusion: include the free vars of the expected arg type in the
 596         -- list of "free vars" for the signature check.
 597
 598     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
 599         tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
 600                 checkSigTyVars sig_tyvars sig_tau
 601         )                                               `thenTc_`
 602
 603             -- Check that there's no overloading involved
 604             -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
 605             -- but which, on simplification, don't actually need a dictionary involving
 606             -- the tyvar.  So we have to do a proper simplification right here.
 607         tcSimplifyRank2 (mkTyVarSet sig_tyvars)
 608                         lie_arg                         `thenTc` \ (free_insts, inst_binds) ->
 609
 610             -- This HsLet binds any Insts which came out of the simplification.
 611             -- It's a bit out of place here, but using AbsBind involves inventing
 612             -- a couple of new names which seems worse.
 613         returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
 614     )
 615   where
 616
 617     mk_binds [] = EmptyBinds
 618     mk_binds ((inst,rhs):inst_binds)
 619         = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
 620           mk_binds inst_binds
 621 \end{code}
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsection{@tcId@ typchecks an identifier occurrence}
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
 631
 632 tcId name
 633   =     -- Look up the Id and instantiate its type
 634     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 635
 636     case maybe_local of
 637       Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
 638
 639       Nothing ->    tcLookupGlobalValue name    `thenNF_Tc` \ id ->
 640                     tcInstType [] (idType id)   `thenNF_Tc` \ inst_ty ->
 641                     let
 642                         (tyvars, rho) = splitForAllTy inst_ty
 643                     in
 644                     instantiate_it2 (RealId id) tyvars rho
 645
 646   where
 647         -- The instantiate_it loop runs round instantiating the Id.
 648         -- It has to be a loop because we are now prepared to entertain
 649         -- types like
 650         --              f:: forall a. Eq a => forall b. Baz b => tau
 651         -- We want to instantiate this to
 652         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 653     instantiate_it tc_id_occ ty
 654       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 655         instantiate_it2 tc_id_occ tyvars rho
 656
 657     instantiate_it2 tc_id_occ tyvars rho
 658       | null theta      -- Is it overloaded?
 659       = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 660
 661       | otherwise       -- Yes, it's overloaded
 662       = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 663                              tc_id_occ arg_tys rho      `thenNF_Tc` \ (lie1, meth_id) ->
 664         instantiate_it meth_id tau                      `thenNF_Tc` \ (expr, lie2, final_tau) ->
 665         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 666
 667       where
 668         (theta,  tau) = splitRhoTy   rho
 669         arg_tys       = mkTyVarTys tyvars
 670 \end{code}
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{@tcQuals@ typechecks list-comprehension qualifiers}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 \begin{code}
 679 tcListComp expr []
 680   = tcExpr expr         `thenTc` \ (expr', lie, ty) ->
 681     returnTc ((expr',[]), lie, mkListTy ty)
 682
 683 tcListComp expr (qual@(FilterQual filter) : quals)
 684   = tcAddErrCtxt (qualCtxt qual) (
 685         tcExpr filter                   `thenTc` \ (filter', filter_lie, filter_ty) ->
 686         unifyTauTy boolTy filter_ty     `thenTc_`
 687         returnTc (FilterQual filter', filter_lie)
 688     )                                   `thenTc` \ (qual', qual_lie) ->
 689
 690     tcListComp expr quals       `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
 691
 692     returnTc ((expr', qual' : quals'),
 693               qual_lie `plusLIE` rest_lie,
 694               res_ty)
 695
 696 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
 697   = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
 698
 699       tcAddErrCtxt (qualCtxt qual) (
 700         tcPat pat                               `thenTc` \ (pat',  lie_pat,  pat_ty)  ->
 701         tcExpr rhs                              `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
 702                 -- NB: the environment has been extended with the new binders
 703                 -- which the rhs can't "see", but the renamer should have made
 704                 -- sure that everything is distinct by now, so there's no problem.
 705                 -- Putting the tcExpr before the newMonoIds messes up the nesting
 706                 -- of error contexts, so I didn't  bother
 707
 708         unifyTauTy (mkListTy pat_ty) rhs_ty     `thenTc_`
 709         returnTc (GeneratorQual pat' rhs',
 710                   lie_pat `plusLIE` lie_rhs)
 711       )                                         `thenTc` \ (qual', lie_qual) ->
 712
 713       tcListComp expr quals                     `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
 714
 715       returnTc ((expr', qual' : quals'),
 716                 lie_qual `plusLIE` lie_rest,
 717                 res_ty)
 718     )
 719   where
 720     binder_names = collectPatBinders pat
 721
 722 tcListComp expr (LetQual binds : quals)
 723   = tcBindsAndThen              -- No error context, but a binding group is
 724         combine                 -- rather a large thing for an error context anyway
 725         binds
 726         (tcListComp expr quals)
 727   where
 728     combine binds' (expr',quals') = (expr', LetQual binds' : quals')
 729 \end{code}
 730
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 \begin{code}
 739 tcDoStmts stmts src_loc
 740   =     -- get the Monad and MonadZero classes
 741         -- create type consisting of a fresh monad tyvar
 742     tcAddSrcLoc src_loc $
 743     newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)    `thenNF_Tc` \ m ->
 744
 745
 746         -- Build the then and zero methods in case we need them
 747     tcLookupGlobalValueByKey thenMClassOpKey    `thenNF_Tc` \ then_sel_id ->
 748     tcLookupGlobalValueByKey zeroClassOpKey     `thenNF_Tc` \ zero_sel_id ->
 749     newMethod DoOrigin
 750               (RealId then_sel_id) [m]          `thenNF_Tc` \ (m_lie, then_id) ->
 751     newMethod DoOrigin
 752               (RealId zero_sel_id) [m]          `thenNF_Tc` \ (mz_lie, zero_id) ->
 753
 754     let
 755       get_m_arg ty
 756         = newTyVarTy mkTypeKind                 `thenNF_Tc` \ arg_ty ->
 757           unifyTauTy (mkAppTy m arg_ty) ty      `thenTc_`
 758           returnTc arg_ty
 759
 760       go [stmt@(ExprStmt exp src_loc)]
 761         = tcAddSrcLoc src_loc $
 762           tcSetErrCtxt (stmtCtxt stmt) $
 763           tcExpr exp                            `thenTc`    \ (exp', exp_lie, exp_ty) ->
 764           returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
 765
 766       go (stmt@(ExprStmt exp src_loc) : stmts)
 767         = tcAddSrcLoc src_loc           (
 768           tcSetErrCtxt (stmtCtxt stmt)  (
 769                 tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 770                 get_m_arg exp_ty                `thenTc` \ a ->
 771                 returnTc (a, exp', exp_lie)
 772           ))                                    `thenTc` \ (a, exp',  exp_lie) ->
 773           go stmts                              `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
 774           get_m_arg stmts_ty                    `thenTc` \ b ->
 775           returnTc (ExprStmtOut exp' src_loc a b : stmts',
 776                     exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
 777                     stmts_ty)
 778
 779       go (stmt@(BindStmt pat exp src_loc) : stmts)
 780         = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 781           tcAddSrcLoc src_loc           (
 782           tcSetErrCtxt (stmtCtxt stmt)  (
 783                 tcPat pat               `thenTc`    \ (pat', pat_lie, pat_ty) ->
 784                 tcExpr exp              `thenTc`    \ (exp', exp_lie, exp_ty) ->
 785                 -- See comments with tcListComp on GeneratorQual
 786
 787                 get_m_arg exp_ty        `thenTc` \ a ->
 788                 unifyTauTy pat_ty a     `thenTc_`
 789                 returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
 790           ))                            `thenTc` \ (a, pat', exp', stmt_lie) ->
 791           go stmts                      `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
 792           get_m_arg stmts_ty            `thenTc` \ b ->
 793           returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
 794                     stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
 795                         (if failureFreePat pat' then emptyLIE else mz_lie),
 796                     stmts_ty)
 797
 798       go (LetStmt binds : stmts)
 799            = tcBindsAndThen             -- No error context, but a binding group is
 800                 combine                 -- rather a large thing for an error context anyway
 801                 binds
 802                 (go stmts)
 803            where
 804              combine binds' stmts' = LetStmt binds' : stmts'
 805     in
 806
 807     go stmts            `thenTc` \ (stmts', final_lie, final_ty) ->
 808     returnTc (HsDoOut stmts' then_id zero_id src_loc,
 809               final_lie,
 810               final_ty)
 811 \end{code}
 812
 813 Game plan for record bindings
 814 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 815 For each binding
 816         field = value
 817 1. look up "field", to find its selector Id, which must have type
 818         forall a1..an. T a1 .. an -> tau
 819    where tau is the type of the field.
 820
 821 2. Instantiate this type
 822
 823 3. Unify the (T a1 .. an) part with the "expected result type", which
 824    is passed in.  This checks that all the field labels come from the
 825    same type.
 826
 827 4. Type check the value using tcArg, passing tau as the expected
 828    argument type.
 829
 830 This extends OK when the field types are universally quantified.
 831
 832 Actually, to save excessive creation of fresh type variables,
 833 we
 834
 835 \begin{code}
 836 tcRecordBinds
 837         :: TcType s             -- Expected type of whole record
 838         -> RenamedRecordBinds
 839         -> TcM s (TcRecordBinds s, LIE s)
 840
 841 tcRecordBinds expected_record_ty rbinds
 842   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 843     returnTc (rbinds', plusLIEs lies)
 844   where
 845     do_bind (field_label, rhs, pun_flag)
 846       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 847         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 848
 849                 -- Record selectors all have type
 850                 --      forall a1..an.  T a1 .. an -> tau
 851         ASSERT( maybeToBool (getFunTy_maybe tau) )
 852         let
 853                 -- Selector must have type RecordType -> FieldType
 854           Just (record_ty, field_ty) = getFunTy_maybe tau
 855         in
 856         unifyTauTy expected_record_ty record_ty         `thenTc_`
 857         tcArg field_ty rhs                              `thenTc` \ (rhs', lie) ->
 858         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 859
 860 checkRecordFields :: RenamedRecordBinds -> Id -> Bool   -- True iff all the fields in
 861                                                         -- RecordBinds are field of the
 862                                                         -- specified constructor
 863 checkRecordFields rbinds data_con
 864   = all ok rbinds
 865   where
 866     data_con_fields = dataConFieldLabels data_con
 867
 868     ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
 869
 870     match field_name field_label = field_name == fieldLabelName field_label
 871 \end{code}
 872
 873 %************************************************************************
 874 %*                                                                      *
 875 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 876 %*                                                                      *
 877 %************************************************************************
 878
 879 \begin{code}
 880 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
 881
 882 tcExprs [] = returnTc ([], emptyLIE, [])
 883 tcExprs (expr:exprs)
 884  = tcExpr  expr                 `thenTc` \ (expr',  lie1, ty) ->
 885    tcExprs exprs                `thenTc` \ (exprs', lie2, tys) ->
 886    returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
 887 \end{code}
 888
 889
 890 % =================================================
 891
 892 Errors and contexts
 893 ~~~~~~~~~~~~~~~~~~~
 894
 895 Mini-utils:
 896 \begin{code}
 897 pp_nest_hang :: String -> Pretty -> Pretty
 898 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 899 \end{code}
 900
 901 Boring and alphabetical:
 902 \begin{code}
 903 arithSeqCtxt expr sty
 904   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 905
 906 branchCtxt b1 b2 sty
 907   = ppSep [ppStr "In the branches of a conditional:",
 908            pp_nest_hang "`then' branch:" (ppr sty b1),
 909            pp_nest_hang "`else' branch:" (ppr sty b2)]
 910
 911 caseCtxt expr sty
 912   = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
 913
 914 exprSigCtxt expr sty
 915   = ppHang (ppStr "In an expression with a type signature:")
 916          4 (ppr sty expr)
 917
 918 listCtxt expr sty
 919   = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
 920
 921 predCtxt expr sty
 922   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
 923
 924 sectionRAppCtxt expr sty
 925   = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
 926
 927 sectionLAppCtxt expr sty
 928   = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
 929
 930 funAppCtxt fun arg_no arg sty
 931   = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
 932          4 (ppCat [ppStr "namely", ppr sty arg])
 933
 934 qualCtxt qual sty
 935   = ppHang (ppStr "In a list-comprehension qualifer:")
 936          4 (ppr sty qual)
 937
 938 stmtCtxt stmt sty
 939   = ppHang (ppStr "In a do statement:")
 940          4 (ppr sty stmt)
 941
 942 tooManyArgsCtxt f sty
 943   = ppHang (ppStr "Too many arguments in an application of the function")
 944          4 (ppr sty f)
 945
 946 lurkingRank2Err fun fun_ty sty
 947   = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
 948          4 (ppAboves [ppStr "It is applied to too few arguments,",
 949                       ppStr "so that the result type has for-alls in it"])
 950
 951 rank2ArgCtxt arg expected_arg_ty sty
 952   = ppHang (ppStr "In a polymorphic function argument:")
 953          4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
 954                    ppr sty expected_arg_ty])
 955
 956 badFieldsUpd rbinds sty
 957   = ppHang (ppStr "No constructor has all these fields:")
 958          4 (interpp'SP sty fields)
 959   where
 960     fields = [field | (field, _, _) <- rbinds]
 961
 962 recordUpdCtxt sty = ppStr "In a record update construct"
 963
 964 badFieldsCon con rbinds sty
 965   = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
 966          4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
 967   where
 968     fields = [field | (field, _, _) <- rbinds]
 969 \end{code}