ghc/compiler/typecheck/TcExpr.lhs

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