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(..), 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-}
22 import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
23 TcIdOcc(..), SYN_IE(TcRecordBinds),
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,
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 )
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
59 import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
60 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
61 floatPrimTy, addrPrimTy, realWorldTy
63 import TysWiredIn ( addrTy,
64 boolTy, charTy, stringTy, mkListTy,
65 mkTupleTy, mkPrimIoTy, stDataCon
67 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
68 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
69 enumFromClassOpKey, enumFromThenClassOpKey,
70 enumFromToClassOpKey, enumFromThenToClassOpKey,
71 thenMClassOpKey, zeroClassOpKey
73 import Outputable ( interpp'SP )
74 import PprType ( GenType, GenTyVar ) -- Instances
75 import Maybes ( maybeToBool )
81 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
84 %************************************************************************
86 \subsection{The TAUT rules for variables}
88 %************************************************************************
92 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
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_`
100 returnTc (expr', lie, res_ty)
103 %************************************************************************
105 \subsection{Literals}
107 %************************************************************************
112 tcExpr (HsLit (HsInt i))
113 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
115 newOverloadedLit (LiteralOrigin (HsInt i))
116 (OverloadedIntegral i)
117 ty `thenNF_Tc` \ (lie, over_lit_id) ->
119 returnTc (HsVar over_lit_id, lie, ty)
121 tcExpr (HsLit (HsFrac f))
122 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
124 newOverloadedLit (LiteralOrigin (HsFrac f))
125 (OverloadedFractional f)
126 ty `thenNF_Tc` \ (lie, over_lit_id) ->
128 returnTc (HsVar over_lit_id, lie, ty)
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)
141 tcExpr (HsLit lit@(HsCharPrim c))
142 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
144 tcExpr (HsLit lit@(HsStringPrim s))
145 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
147 tcExpr (HsLit lit@(HsIntPrim i))
148 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
150 tcExpr (HsLit lit@(HsFloatPrim f))
151 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
153 tcExpr (HsLit lit@(HsDoublePrim d))
154 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
157 Unoverloaded literals:
160 tcExpr (HsLit lit@(HsChar c))
161 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
163 tcExpr (HsLit lit@(HsString str))
164 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
167 %************************************************************************
169 \subsection{Other expression forms}
171 %************************************************************************
174 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
177 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
180 = tcMatch match `thenTc` \ (match',lie,ty) ->
181 returnTc (HsLam match', lie, ty)
183 tcExpr (HsApp e1 e2) = accum e1 [e2]
185 accum (HsApp e1 e2) args = accum e1 (e2:args)
187 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
188 returnTc (foldl HsApp fun' args', lie, res_ty)
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)
196 Note that the operators in sections are expected to be binary, and
197 a type error will occur if they aren't.
200 -- Left sections, equivalent to
207 tcExpr in_expr@(SectionL arg op)
208 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
210 -- Check that res_ty is a function type
211 -- Without this check we barf in the desugarer on
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_`
221 returnTc (SectionL arg' op', lie, res_ty)
223 -- Right sections, equivalent to \ x -> x op expr, or
226 tcExpr in_expr@(SectionR op expr)
227 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
228 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
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_`
235 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
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
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 ->
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
257 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
261 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
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
266 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
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, _) ->
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)
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)
285 tcExpr (HsLet binds expr)
287 HsLet -- The combiner
288 binds -- Bindings to check
289 (tcExpr expr) -- Typechecker for the expression
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 ->
296 tcAddErrCtxt (caseCtxt in_expr) $
297 tcMatchesCase (mkFunTy expr_ty result_ty) matches
298 `thenTc` \ (matches',lie2) ->
300 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
302 tcExpr (HsIf pred b1 b2 src_loc)
303 = tcAddSrcLoc src_loc $
304 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
306 tcAddErrCtxt (predCtxt pred) (
307 unifyTauTy boolTy predTy
310 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
311 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
313 tcAddErrCtxt (branchCtxt b1 b2) $
314 unifyTauTy result_ty b2Ty `thenTc_`
316 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
318 tcExpr (ListComp expr quals)
319 = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
320 returnTc (ListComp expr' quals', lie, ty)
324 tcExpr expr@(HsDo stmts src_loc)
325 = tcDoStmts stmts src_loc
329 tcExpr (ExplicitList [])
330 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
331 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
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)
340 tcExpr (ExplicitTuple exprs)
341 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
342 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
344 tcExpr (RecordCon (HsVar con) rbinds)
345 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
347 (_, record_ty) = splitFunTy con_tau
349 -- Con is syntactically constrained to be a data constructor
350 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
352 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
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_`
359 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
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.
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.
370 tcExpr (RecordUpd record_expr rbinds)
371 = ASSERT( not (null rbinds) )
372 tcAddErrCtxt recordUpdCtxt $
374 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
375 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
377 -- Check that the field names are plausible
378 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
380 (tycon, inst_tys, data_cons) = trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
381 -- The record binds are non-empty (syntax); so at least one field
382 -- label will have been unified with record_ty by tcRecordBinds;
383 -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
384 (tyvars, theta, _, _) = dataConSig (head data_cons)
386 tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
387 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
388 checkTc (any (checkRecordFields rbinds) data_cons)
389 (badFieldsUpd rbinds) `thenTc_`
391 returnTc (RecordUpdOut record_expr' dicts rbinds',
392 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
395 tcExpr (ArithSeqIn seq@(From expr))
396 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
398 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
399 newMethod (ArithSeqOrigin seq)
400 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
402 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
406 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
407 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
408 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
410 tcAddErrCtxt (arithSeqCtxt in_expr) $
411 unifyTauTyList [ty1, ty2] `thenTc_`
413 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
414 newMethod (ArithSeqOrigin seq)
415 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
417 returnTc (ArithSeqOut (HsVar enum_from_then_id)
418 (FromThen expr1' expr2'),
419 lie1 `plusLIE` lie2 `plusLIE` lie3,
422 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
423 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
424 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
426 tcAddErrCtxt (arithSeqCtxt in_expr) $
427 unifyTauTyList [ty1,ty2] `thenTc_`
429 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
430 newMethod (ArithSeqOrigin seq)
431 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
433 returnTc (ArithSeqOut (HsVar enum_from_to_id)
434 (FromTo expr1' expr2'),
435 lie1 `plusLIE` lie2 `plusLIE` lie3,
438 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
439 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
440 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
441 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
443 tcAddErrCtxt (arithSeqCtxt in_expr) $
444 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
446 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
447 newMethod (ArithSeqOrigin seq)
448 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
450 returnTc (ArithSeqOut (HsVar eft_id)
451 (FromThenTo expr1' expr2' expr3'),
452 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
456 %************************************************************************
458 \subsection{Expressions type signatures}
460 %************************************************************************
463 tcExpr in_expr@(ExprWithTySig expr poly_ty)
464 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
465 tcPolyType poly_ty `thenTc` \ sigma_sig ->
467 -- Check the tau-type part
468 tcSetErrCtxt (exprSigCtxt in_expr) $
469 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
471 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
473 unifyTauTy sig_tau' tau_ty `thenTc_`
475 -- Check the type variables of the signature
476 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
478 -- Check overloading constraints
479 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
481 (mkTyVarSet sig_tyvars')
482 sig_dicts lie `thenTc_`
484 -- If everything is ok, return the stuff unchanged, except for
485 -- the effect of any substutions etc. We simply discard the
486 -- result of the tcSimplifyAndCheck, except for any default
487 -- resolution it may have done, which is recorded in the
489 returnTc (texpr, lie, tau_ty)
492 %************************************************************************
494 \subsection{@tcApp@ typchecks an application}
496 %************************************************************************
499 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
500 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
502 TcType s) -- Type of the application
505 = -- First type-check the function
506 -- In the HsVar case we go straight to tcId to avoid hitting the
507 -- rank-2 check, which we check later here anyway
509 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
511 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
513 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
515 -- Check that the result type doesn't have any nested for-alls.
516 -- For example, a "build" on its own is no good; it must be applied to something.
517 checkTc (isTauTy res_ty)
518 (lurkingRank2Err fun fun_ty) `thenTc_`
520 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
523 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
524 -> TcType s -- The type of the function
525 -> [RenamedHsExpr] -- Arguments
526 -> TcM s ([TcExpr s], -- Typechecked args
528 TcType s) -- Result type of the application
530 tcApp_help orig_fun arg_no fun_ty []
531 = returnTc ([], emptyLIE, fun_ty)
533 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
534 = -- Expect the function to have type A->B
535 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
537 ) `thenTc` \ (expected_arg_ty, result_ty) ->
539 -- Type check the argument
540 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
541 tcArg expected_arg_ty arg
542 ) `thenTc` \ (arg', lie_arg) ->
545 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
548 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
553 tcArg :: TcType s -- Expected arg type
554 -> RenamedHsExpr -- Actual argument
555 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
557 tcArg expected_arg_ty arg
558 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
559 = -- The ordinary, non-rank-2 polymorphic case
560 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
561 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
562 returnTc (arg', lie_arg)
565 = -- Ha! The argument type of the function is a for-all type,
566 -- An example of rank-2 polymorphism.
568 -- No need to instantiate the argument type... it's must be the result
569 -- of instantiating a function involving rank-2 polymorphism, so there
570 -- isn't any danger of using the same tyvars twice
571 -- The argument type shouldn't be overloaded type (hence ASSERT)
573 -- To ensure that the forall'd type variables don't get unified with each
574 -- other or any other types, we make fresh *signature* type variables
575 -- and unify them with the tyvars.
576 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
578 (sig_theta, sig_tau) = splitRhoTy sig_rho
580 ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
582 -- Type-check the arg and unify with expected type
583 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
584 unifyTauTy sig_tau actual_arg_ty `thenTc_`
586 -- Check that the arg_tyvars havn't been constrained
587 -- The interesting bit here is that we must include the free variables
588 -- of the expected arg ty. Here's an example:
589 -- runST (newVar True)
590 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
591 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
592 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
593 -- So now s' isn't unconstrained because it's linked to a.
594 -- Conclusion: include the free vars of the expected arg type in the
595 -- list of "free vars" for the signature check.
597 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
598 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
599 checkSigTyVars sig_tyvars sig_tau
602 -- Check that there's no overloading involved
603 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
604 -- but which, on simplification, don't actually need a dictionary involving
605 -- the tyvar. So we have to do a proper simplification right here.
606 tcSimplifyRank2 (mkTyVarSet sig_tyvars)
607 lie_arg `thenTc` \ (free_insts, inst_binds) ->
609 -- This HsLet binds any Insts which came out of the simplification.
610 -- It's a bit out of place here, but using AbsBind involves inventing
611 -- a couple of new names which seems worse.
612 returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
616 mk_binds [] = EmptyBinds
617 mk_binds ((inst,rhs):inst_binds)
618 = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
622 %************************************************************************
624 \subsection{@tcId@ typchecks an identifier occurrence}
626 %************************************************************************
629 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
632 = -- Look up the Id and instantiate its type
633 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
636 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
638 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
639 tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
641 (tyvars, rho) = splitForAllTy inst_ty
643 instantiate_it2 (RealId id) tyvars rho
646 -- The instantiate_it loop runs round instantiating the Id.
647 -- It has to be a loop because we are now prepared to entertain
649 -- f:: forall a. Eq a => forall b. Baz b => tau
650 -- We want to instantiate this to
651 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
652 instantiate_it tc_id_occ ty
653 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
654 instantiate_it2 tc_id_occ tyvars rho
656 instantiate_it2 tc_id_occ tyvars rho
657 | null theta -- Is it overloaded?
658 = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
660 | otherwise -- Yes, it's overloaded
661 = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
662 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
663 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
664 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
667 (theta, tau) = splitRhoTy rho
668 arg_tys = mkTyVarTys tyvars
671 %************************************************************************
673 \subsection{@tcQuals@ typechecks list-comprehension qualifiers}
675 %************************************************************************
679 = tcExpr expr `thenTc` \ (expr', lie, ty) ->
680 returnTc ((expr',[]), lie, mkListTy ty)
682 tcListComp expr (qual@(FilterQual filter) : quals)
683 = tcAddErrCtxt (qualCtxt qual) (
684 tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) ->
685 unifyTauTy boolTy filter_ty `thenTc_`
686 returnTc (FilterQual filter', filter_lie)
687 ) `thenTc` \ (qual', qual_lie) ->
689 tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
691 returnTc ((expr', qual' : quals'),
692 qual_lie `plusLIE` rest_lie,
695 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
696 = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
698 tcAddErrCtxt (qualCtxt qual) (
699 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
700 tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
701 -- NB: the environment has been extended with the new binders
702 -- which the rhs can't "see", but the renamer should have made
703 -- sure that everything is distinct by now, so there's no problem.
704 -- Putting the tcExpr before the newMonoIds messes up the nesting
705 -- of error contexts, so I didn't bother
707 unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
708 returnTc (GeneratorQual pat' rhs',
709 lie_pat `plusLIE` lie_rhs)
710 ) `thenTc` \ (qual', lie_qual) ->
712 tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
714 returnTc ((expr', qual' : quals'),
715 lie_qual `plusLIE` lie_rest,
719 binder_names = collectPatBinders pat
721 tcListComp expr (LetQual binds : quals)
722 = tcBindsAndThen -- No error context, but a binding group is
723 combine -- rather a large thing for an error context anyway
725 (tcListComp expr quals)
727 combine binds' (expr',quals') = (expr', LetQual binds' : quals')
731 %************************************************************************
733 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
735 %************************************************************************
738 tcDoStmts stmts src_loc
739 = -- get the Monad and MonadZero classes
740 -- create type consisting of a fresh monad tyvar
741 tcAddSrcLoc src_loc $
742 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
745 -- Build the then and zero methods in case we need them
746 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
747 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
749 (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
751 (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
755 = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
756 unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
759 go [stmt@(ExprStmt exp src_loc)]
760 = tcAddSrcLoc src_loc $
761 tcSetErrCtxt (stmtCtxt stmt) $
762 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
763 returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
765 go (stmt@(ExprStmt exp src_loc) : stmts)
766 = tcAddSrcLoc src_loc (
767 tcSetErrCtxt (stmtCtxt stmt) (
768 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
769 get_m_arg exp_ty `thenTc` \ a ->
770 returnTc (a, exp', exp_lie)
771 )) `thenTc` \ (a, exp', exp_lie) ->
772 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
773 get_m_arg stmts_ty `thenTc` \ b ->
774 returnTc (ExprStmtOut exp' src_loc a b : stmts',
775 exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
778 go (stmt@(BindStmt pat exp src_loc) : stmts)
779 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
780 tcAddSrcLoc src_loc (
781 tcSetErrCtxt (stmtCtxt stmt) (
782 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
783 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
784 -- See comments with tcListComp on GeneratorQual
786 get_m_arg exp_ty `thenTc` \ a ->
787 unifyTauTy pat_ty a `thenTc_`
788 returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
789 )) `thenTc` \ (a, pat', exp', stmt_lie) ->
790 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
791 get_m_arg stmts_ty `thenTc` \ b ->
792 returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
793 stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
794 (if failureFreePat pat' then emptyLIE else mz_lie),
797 go (LetStmt binds : stmts)
798 = tcBindsAndThen -- No error context, but a binding group is
799 combine -- rather a large thing for an error context anyway
803 combine binds' stmts' = LetStmt binds' : stmts'
806 go stmts `thenTc` \ (stmts', final_lie, final_ty) ->
807 returnTc (HsDoOut stmts' then_id zero_id src_loc,
812 Game plan for record bindings
813 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
816 1. look up "field", to find its selector Id, which must have type
817 forall a1..an. T a1 .. an -> tau
818 where tau is the type of the field.
820 2. Instantiate this type
822 3. Unify the (T a1 .. an) part with the "expected result type", which
823 is passed in. This checks that all the field labels come from the
826 4. Type check the value using tcArg, passing tau as the expected
829 This extends OK when the field types are universally quantified.
831 Actually, to save excessive creation of fresh type variables,
836 :: TcType s -- Expected type of whole record
837 -> RenamedRecordBinds
838 -> TcM s (TcRecordBinds s, LIE s)
840 tcRecordBinds expected_record_ty rbinds
841 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
842 returnTc (rbinds', plusLIEs lies)
844 do_bind (field_label, rhs, pun_flag)
845 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
846 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
848 -- Record selectors all have type
849 -- forall a1..an. T a1 .. an -> tau
850 ASSERT( maybeToBool (getFunTy_maybe tau) )
852 -- Selector must have type RecordType -> FieldType
853 Just (record_ty, field_ty) = getFunTy_maybe tau
855 unifyTauTy expected_record_ty record_ty `thenTc_`
856 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
857 returnTc ((RealId sel_id, rhs', pun_flag), lie)
859 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
860 -- RecordBinds are field of the
861 -- specified constructor
862 checkRecordFields rbinds data_con
865 data_con_fields = dataConFieldLabels data_con
867 ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
869 match field_name field_label = field_name == fieldLabelName field_label
872 %************************************************************************
874 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
876 %************************************************************************
879 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
881 tcExprs [] = returnTc ([], emptyLIE, [])
883 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
884 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
885 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
889 % =================================================
896 pp_nest_hang :: String -> Pretty -> Pretty
897 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
900 Boring and alphabetical:
902 arithSeqCtxt expr sty
903 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
906 = ppSep [ppStr "In the branches of a conditional:",
907 pp_nest_hang "`then' branch:" (ppr sty b1),
908 pp_nest_hang "`else' branch:" (ppr sty b2)]
911 = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
914 = ppHang (ppStr "In an expression with a type signature:")
918 = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
921 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
923 sectionRAppCtxt expr sty
924 = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
926 sectionLAppCtxt expr sty
927 = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
929 funAppCtxt fun arg_no arg sty
930 = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
931 4 (ppCat [ppStr "namely", ppr sty arg])
934 = ppHang (ppStr "In a list-comprehension qualifer:")
938 = ppHang (ppStr "In a do statement:")
941 tooManyArgsCtxt f sty
942 = ppHang (ppStr "Too many arguments in an application of the function")
945 lurkingRank2Err fun fun_ty sty
946 = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
947 4 (ppAboves [ppStr "It is applied to too few arguments,",
948 ppStr "so that the result type has for-alls in it"])
950 rank2ArgCtxt arg expected_arg_ty sty
951 = ppHang (ppStr "In a polymorphic function argument:")
952 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
953 ppr sty expected_arg_ty])
955 badFieldsUpd rbinds sty
956 = ppHang (ppStr "No constructor has all these fields:")
957 4 (interpp'SP sty fields)
959 fields = [field | (field, _, _) <- rbinds]
961 recordUpdCtxt sty = ppStr "In a record update construct"
963 badFieldsCon con rbinds sty
964 = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
965 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
967 fields = [field | (field, _, _) <- rbinds]