2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcExpr]{Typecheck an expression}
7 #include "HsVersions.h"
9 module TcExpr ( tcExpr ) where
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-}
22 import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
23 TcIdOcc(..), TcRecordBinds(..),
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
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 )
44 import Class ( Class(..), classSig )
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
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 )
67 --import Name ( Name ) -- Instance
68 import Outputable ( interpp'SP )
69 import PprType ( GenType, GenTyVar ) -- Instances
70 import Maybes ( maybeToBool )
76 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
79 %************************************************************************
81 \subsection{The TAUT rules for variables}
83 %************************************************************************
87 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
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_`
95 returnTc (expr', lie, res_ty)
98 %************************************************************************
100 \subsection{Literals}
102 %************************************************************************
107 tcExpr (HsLit (HsInt i))
108 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
110 newOverloadedLit (LiteralOrigin (HsInt i))
111 (OverloadedIntegral i)
112 ty `thenNF_Tc` \ (lie, over_lit_id) ->
114 returnTc (HsVar over_lit_id, lie, ty)
116 tcExpr (HsLit (HsFrac f))
117 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
119 newOverloadedLit (LiteralOrigin (HsFrac f))
120 (OverloadedFractional f)
121 ty `thenNF_Tc` \ (lie, over_lit_id) ->
123 returnTc (HsVar over_lit_id, lie, ty)
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)
136 tcExpr (HsLit lit@(HsCharPrim c))
137 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
139 tcExpr (HsLit lit@(HsStringPrim s))
140 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
142 tcExpr (HsLit lit@(HsIntPrim i))
143 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
145 tcExpr (HsLit lit@(HsFloatPrim f))
146 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
148 tcExpr (HsLit lit@(HsDoublePrim d))
149 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
152 Unoverloaded literals:
155 tcExpr (HsLit lit@(HsChar c))
156 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
158 tcExpr (HsLit lit@(HsString str))
159 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
162 %************************************************************************
164 \subsection{Other expression forms}
166 %************************************************************************
169 tcExpr (HsPar expr) = tcExpr expr
171 tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr)
174 = tcMatch match `thenTc` \ (match',lie,ty) ->
175 returnTc (HsLam match', lie, ty)
177 tcExpr (HsApp e1 e2) = accum e1 [e2]
179 accum (HsApp e1 e2) args = accum e1 (e2:args)
181 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
182 returnTc (foldl HsApp fun' args', lie, res_ty)
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)
190 Note that the operators in sections are expected to be binary, and
191 a type error will occur if they aren't.
194 -- Left sections, equivalent to
201 tcExpr in_expr@(SectionL arg op)
202 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
204 -- Check that res_ty is a function type
205 -- Without this check we barf in the desugarer on
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_`
215 returnTc (SectionL arg' op', lie, res_ty)
217 -- Right sections, equivalent to \ x -> x op expr, or
220 tcExpr in_expr@(SectionR op expr)
221 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
222 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
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_`
229 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
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
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 ->
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
251 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
255 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
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
260 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
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, _) ->
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)
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)
278 tcExpr (HsLet binds expr)
280 HsLet -- The combiner
281 binds -- Bindings to check
282 (tcExpr expr) -- Typechecker for the expression
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 ->
289 tcAddErrCtxt (caseCtxt in_expr) $
290 tcMatchesCase (mkFunTy expr_ty result_ty) matches
291 `thenTc` \ (matches',lie2) ->
293 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
295 tcExpr (HsIf pred b1 b2 src_loc)
296 = tcAddSrcLoc src_loc $
297 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
299 tcAddErrCtxt (predCtxt pred) (
300 unifyTauTy predTy boolTy
303 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
304 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
306 tcAddErrCtxt (branchCtxt b1 b2) $
307 unifyTauTy result_ty b2Ty `thenTc_`
309 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
311 tcExpr (ListComp expr quals)
312 = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
313 returnTc (ListComp expr' quals', lie, ty)
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) ->
324 -- create dictionaries for monad and possibly monadzero
326 tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
327 newDicts DoOrigin [(monadClass, m)]
329 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
330 ) `thenNF_Tc` \ (m_lie, [m_id]) ->
332 tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
333 newDicts DoOrigin [(monadZeroClass, m)]
335 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
336 ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
338 returnTc (HsDoOut stmts' m_id mz_id src_loc,
339 lie `plusLIE` m_lie `plusLIE` mz_lie,
342 monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
346 tcExpr (ExplicitList [])
347 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
348 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
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)
357 tcExpr (ExplicitTuple exprs)
358 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
359 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
361 tcExpr (RecordCon (HsVar con) rbinds)
362 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
364 (_, record_ty) = splitFunTy con_tau
366 -- Con is syntactically constrained to be a data constructor
367 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
369 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
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_`
376 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
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.
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.
387 tcExpr (RecordUpd record_expr rbinds)
388 = ASSERT( not (null rbinds) )
389 tcAddErrCtxt recordUpdCtxt $
391 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
392 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
394 -- Check that the field names are plausible
395 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
397 (tycon, inst_tys, data_cons) = _trace "getAppDataTyCon.TcExpr" $ 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)
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_`
408 returnTc (RecordUpdOut record_expr' dicts rbinds',
409 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
412 tcExpr (ArithSeqIn seq@(From expr))
413 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
415 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
416 newMethod (ArithSeqOrigin seq)
417 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
419 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
423 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
424 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
425 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
427 tcAddErrCtxt (arithSeqCtxt in_expr) $
428 unifyTauTyList [ty1, ty2] `thenTc_`
430 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
431 newMethod (ArithSeqOrigin seq)
432 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
434 returnTc (ArithSeqOut (HsVar enum_from_then_id)
435 (FromThen expr1' expr2'),
436 lie1 `plusLIE` lie2 `plusLIE` lie3,
439 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
440 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
441 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
443 tcAddErrCtxt (arithSeqCtxt in_expr) $
444 unifyTauTyList [ty1,ty2] `thenTc_`
446 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
447 newMethod (ArithSeqOrigin seq)
448 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
450 returnTc (ArithSeqOut (HsVar enum_from_to_id)
451 (FromTo expr1' expr2'),
452 lie1 `plusLIE` lie2 `plusLIE` lie3,
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) ->
460 tcAddErrCtxt (arithSeqCtxt in_expr) $
461 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
463 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
464 newMethod (ArithSeqOrigin seq)
465 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
467 returnTc (ArithSeqOut (HsVar eft_id)
468 (FromThenTo expr1' expr2' expr3'),
469 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
473 %************************************************************************
475 \subsection{Expressions type signatures}
477 %************************************************************************
480 tcExpr in_expr@(ExprWithTySig expr poly_ty)
481 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
482 tcPolyType poly_ty `thenTc` \ sigma_sig ->
484 -- Check the tau-type part
485 tcSetErrCtxt (exprSigCtxt in_expr) $
486 tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
488 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
490 unifyTauTy tau_ty sig_tau' `thenTc_`
492 -- Check the type variables of the signature
493 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
495 -- Check overloading constraints
496 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
498 (mkTyVarSet sig_tyvars')
499 sig_dicts lie `thenTc_`
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
506 returnTc (texpr, lie, tau_ty)
509 %************************************************************************
511 \subsection{@tcApp@ typchecks an application}
513 %************************************************************************
516 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
517 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
519 TcType s) -- Type of the application
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
526 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
528 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
530 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
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_`
537 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
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
545 TcType s) -- Result type of the application
547 tcApp_help orig_fun arg_no fun_ty []
548 = returnTc ([], emptyLIE, fun_ty)
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) (
554 ) `thenTc` \ (expected_arg_ty, result_ty) ->
556 -- Type check the argument
557 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
558 tcArg expected_arg_ty arg
559 ) `thenTc` \ (arg', lie_arg) ->
562 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
565 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
570 tcArg :: TcType s -- Expected arg type
571 -> RenamedHsExpr -- Actual argument
572 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
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)
582 = -- Ha! The argument type of the function is a for-all type,
583 -- An example of rank-2 polymorphism.
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)
590 (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
592 ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
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_` (
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_`
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) ->
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)
631 mk_binds ((inst,rhs):inst_binds)
632 = (SingleBind (NonRecBind (VarMonoBind inst rhs)))
637 %************************************************************************
639 \subsection{@tcId@ typchecks an identifier occurrence}
641 %************************************************************************
644 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
647 = -- Look up the Id and instantiate its type
648 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
652 (tyvars, rho) = splitForAllTy (idType tc_id)
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')
658 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
660 (tyvars, rho) = splitForAllTy (idType id)
662 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
663 tcInstType tenv rho `thenNF_Tc` \ rho' ->
664 returnNF_Tc (RealId id, arg_tys, rho')
666 ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
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)
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)
681 %************************************************************************
683 \subsection{@tcQuals@ typchecks list comprehension qualifiers}
685 %************************************************************************
689 = tcExpr expr `thenTc` \ (expr', lie, ty) ->
690 returnTc ((expr',[]), lie, mkListTy ty)
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) ->
699 tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
701 returnTc ((expr', qual' : quals'),
702 qual_lie `plusLIE` rest_lie,
705 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
706 = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
708 tcAddErrCtxt (qualCtxt qual) (
709 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
710 tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
711 -- NB: the environment has been extended with the new binders
712 -- which the rhs can't "see", but the renamer should have made
713 -- sure that everything is distinct by now, so there's no problem.
714 -- Putting the tcExpr before the newMonoIds messes up the nesting
715 -- of error contexts, so I didn't bother
717 unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
718 returnTc (GeneratorQual pat' rhs',
719 lie_pat `plusLIE` lie_rhs)
720 ) `thenTc` \ (qual', lie_qual) ->
722 tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
724 returnTc ((expr', qual' : quals'),
725 lie_qual `plusLIE` lie_rest,
729 binder_names = collectPatBinders pat
731 tcListComp expr (LetQual binds : quals)
732 = tcBindsAndThen -- No error context, but a binding group is
733 combine -- rather a large thing for an error context anyway
735 (tcListComp expr quals)
737 combine binds' (expr',quals') = (expr', LetQual binds' : quals')
741 %************************************************************************
743 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
745 %************************************************************************
748 tcDoStmts :: Bool -- True => require a monad
751 -> TcM s (([TcStmt s],
752 Bool, -- True => Monad
753 Bool), -- True => MonadZero
757 tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
758 = tcAddSrcLoc src_loc $
759 tcSetErrCtxt (stmtCtxt stmt) $
760 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
762 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
763 unifyTauTy (mkAppTy m a) exp_ty
767 returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
769 tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
770 = tcAddSrcLoc src_loc (
771 tcSetErrCtxt (stmtCtxt stmt) (
772 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
773 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
774 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
775 returnTc (ExprStmt exp' src_loc, exp_lie)
776 )) `thenTc` \ (stmt', stmt_lie) ->
777 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
778 returnTc ((stmt':stmts', True, mzero),
779 stmt_lie `plusLIE` stmts_lie,
782 tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
783 = tcAddSrcLoc src_loc (
784 tcSetErrCtxt (stmtCtxt stmt) (
785 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
786 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
787 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
788 unifyTauTy a pat_ty `thenTc_`
789 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
790 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
791 )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
792 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
793 returnTc ((stmt':stmts', True, mzero || not failure_free),
794 stmt_lie `plusLIE` stmts_lie,
797 tcDoStmts monad m (LetStmt binds : stmts)
798 = tcBindsAndThen -- No error context, but a binding group is
799 combine -- rather a large thing for an error context anyway
801 (tcDoStmts monad m stmts)
803 combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
807 Game plan for record bindings
808 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
811 1. look up "field", to find its selector Id, which must have type
812 forall a1..an. T a1 .. an -> tau
813 where tau is the type of the field.
815 2. Instantiate this type
817 3. Unify the (T a1 .. an) part with the "expected result type", which
818 is passed in. This checks that all the field labels come from the
821 4. Type check the value using tcArg, passing tau as the expected
824 This extends OK when the field types are universally quantified.
826 Actually, to save excessive creation of fresh type variables,
831 :: TcType s -- Expected type of whole record
832 -> RenamedRecordBinds
833 -> TcM s (TcRecordBinds s, LIE s)
835 tcRecordBinds expected_record_ty rbinds
836 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
837 returnTc (rbinds', plusLIEs lies)
839 do_bind (field_label, rhs, pun_flag)
840 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
841 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
843 -- Record selectors all have type
844 -- forall a1..an. T a1 .. an -> tau
845 ASSERT( maybeToBool (getFunTy_maybe tau) )
847 -- Selector must have type RecordType -> FieldType
848 Just (record_ty, field_ty) = getFunTy_maybe tau
850 unifyTauTy expected_record_ty record_ty `thenTc_`
851 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
852 returnTc ((RealId sel_id, rhs', pun_flag), lie)
854 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
855 -- RecordBinds are field of the
856 -- specified constructor
857 checkRecordFields rbinds data_con
860 data_con_fields = dataConFieldLabels data_con
862 ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
864 match field_name field_label = field_name == fieldLabelName field_label
867 %************************************************************************
869 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
871 %************************************************************************
874 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
876 tcExprs [] = returnTc ([], emptyLIE, [])
878 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
879 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
880 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
884 % =================================================
891 pp_nest_hang :: String -> Pretty -> Pretty
892 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
895 Boring and alphabetical:
897 arithSeqCtxt expr sty
898 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
901 = ppSep [ppStr "In the branches of a conditional:",
902 pp_nest_hang "`then' branch:" (ppr sty b1),
903 pp_nest_hang "`else' branch:" (ppr sty b2)]
906 = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
909 = ppHang (ppStr "In an expression with a type signature:")
913 = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
916 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
918 sectionRAppCtxt expr sty
919 = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
921 sectionLAppCtxt expr sty
922 = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
924 funAppCtxt fun arg_no arg sty
925 = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
926 4 (ppCat [ppStr "namely", ppr sty arg])
929 = ppHang (ppStr "In a list-comprehension qualifer:")
933 = ppHang (ppStr "In a do statement:")
936 tooManyArgsCtxt f sty
937 = ppHang (ppStr "Too many arguments in an application of the function")
940 lurkingRank2Err fun fun_ty sty
941 = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
942 4 (ppAboves [ppStr "It is applied to too few arguments,",
943 ppStr "so that the result type has for-alls in it"])
945 rank2ArgCtxt arg expected_arg_ty sty
946 = ppHang (ppStr "In a polymorphic function argument:")
947 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
948 ppr sty expected_arg_ty])
950 badFieldsUpd rbinds sty
951 = ppHang (ppStr "No constructor has all these fields:")
952 4 (interpp'SP sty fields)
954 fields = [field | (field, _, _) <- rbinds]
956 recordUpdCtxt sty = ppStr "In a record update construct"
958 badFieldsCon con rbinds sty
959 = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
960 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
962 fields = [field | (field, _, _) <- rbinds]