2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcExpr]{Typecheck an expression}
7 module TcExpr ( tcExpr, tcStmt, tcId ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
12 HsBinds(..), Stmt(..), DoOrListComp(..),
13 failureFreePat, collectPatBinders
15 import RnHsSyn ( RenamedHsExpr,
16 RenamedStmt, RenamedRecordBinds
18 import TcHsSyn ( TcExpr, TcStmt,
24 import BasicTypes ( RecFlag(..) )
26 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
27 LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
28 newMethod, newMethodWithGivenTy, newDicts )
29 import TcBinds ( tcBindsAndThen, checkSigTyVars )
30 import TcEnv ( TcIdOcc(..), tcInstId,
31 tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
32 tcLookupGlobalValueByKey, newMonoIds,
33 tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
36 import TcMatches ( tcMatchesCase, tcMatchExpected )
37 import TcMonoType ( tcHsType )
38 import TcPat ( tcPat )
39 import TcSimplify ( tcSimplifyAndCheck )
40 import TcType ( TcType, TcMaybe(..),
41 tcInstType, tcInstSigTcType, tcInstTyVars,
42 tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
43 newTyVarTy, newTyVarTys, zonkTcType )
44 import TcKind ( TcKind )
46 import Class ( Class )
47 import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
48 import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
52 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
53 import Name ( Name{-instance Eq-} )
54 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
55 splitFunTy_maybe, splitFunTys,
57 splitForAllTys, splitRhoTy, splitSigmaTy,
58 isTauTy, tyVarsOfType, tyVarsOfTypes,
59 splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe
61 import TyVar ( emptyTyVarEnv, zipTyVarEnv,
62 elementOfTyVarSet, mkTyVarSet, tyVarSetToList
64 import TyCon ( tyConDataCons )
65 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
66 floatPrimTy, addrPrimTy
68 import TysWiredIn ( boolTy, charTy, stringTy )
69 import PrelInfo ( ioTyCon_NAME )
70 import Unify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
71 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
72 enumFromClassOpKey, enumFromThenClassOpKey,
73 enumFromToClassOpKey, enumFromThenToClassOpKey,
74 thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
77 import PprType ( GenType, GenTyVar ) -- Instances
78 import Maybes ( maybeToBool )
79 import ListSetOps ( minusList )
84 tcExpr :: RenamedHsExpr -- Expession to type check
85 -> TcType s -- Expected type (could be a type variable)
86 -> TcM s (TcExpr s, LIE s)
89 %************************************************************************
91 \subsection{The TAUT rules for variables}
93 %************************************************************************
96 tcExpr (HsVar name) res_ty
97 = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
98 unifyTauTy res_ty id_ty `thenTc_`
100 -- Check that the result type doesn't have any nested for-alls.
101 -- For example, a "build" on its own is no good; it must be
102 -- applied to something.
103 checkTc (isTauTy id_ty)
104 (lurkingRank2Err name id_ty) `thenTc_`
106 returnTc (expr', lie)
109 %************************************************************************
111 \subsection{Literals}
113 %************************************************************************
118 tcExpr (HsLit (HsInt i)) res_ty
119 = newOverloadedLit (LiteralOrigin (HsInt i))
120 (OverloadedIntegral i)
121 res_ty `thenNF_Tc` \ stuff ->
124 tcExpr (HsLit (HsFrac f)) res_ty
125 = newOverloadedLit (LiteralOrigin (HsFrac f))
126 (OverloadedFractional f)
127 res_ty `thenNF_Tc` \ stuff ->
131 tcExpr (HsLit lit@(HsLitLit s)) res_ty
132 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
133 newDicts (LitLitOrigin (_UNPK_ s))
134 [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
135 returnTc (HsLitOut lit res_ty, dicts)
141 tcExpr (HsLit lit@(HsCharPrim c)) res_ty
142 = unifyTauTy res_ty charPrimTy `thenTc_`
143 returnTc (HsLitOut lit charPrimTy, emptyLIE)
145 tcExpr (HsLit lit@(HsStringPrim s)) res_ty
146 = unifyTauTy res_ty addrPrimTy `thenTc_`
147 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
149 tcExpr (HsLit lit@(HsIntPrim i)) res_ty
150 = unifyTauTy res_ty intPrimTy `thenTc_`
151 returnTc (HsLitOut lit intPrimTy, emptyLIE)
153 tcExpr (HsLit lit@(HsFloatPrim f)) res_ty
154 = unifyTauTy res_ty floatPrimTy `thenTc_`
155 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
157 tcExpr (HsLit lit@(HsDoublePrim d)) res_ty
158 = unifyTauTy res_ty doublePrimTy `thenTc_`
159 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
162 Unoverloaded literals:
165 tcExpr (HsLit lit@(HsChar c)) res_ty
166 = unifyTauTy res_ty charTy `thenTc_`
167 returnTc (HsLitOut lit charTy, emptyLIE)
169 tcExpr (HsLit lit@(HsString str)) res_ty
170 = unifyTauTy res_ty stringTy `thenTc_`
171 returnTc (HsLitOut lit stringTy, emptyLIE)
174 %************************************************************************
176 \subsection{Other expression forms}
178 %************************************************************************
181 tcExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
184 -- perform the negate *before* overloading the integer, since the case
185 -- of minBound on Ints fails otherwise. Could be done elsewhere, but
186 -- convenient to do it here.
188 tcExpr (NegApp (HsLit (HsInt i)) neg) res_ty
189 = tcExpr (HsLit (HsInt (-i))) res_ty
191 tcExpr (NegApp expr neg) res_ty
192 = tcExpr (HsApp neg expr) res_ty
194 tcExpr (HsLam match) res_ty
195 = tcMatchExpected [] res_ty match `thenTc` \ (match',lie) ->
196 returnTc (HsLam match', lie)
198 tcExpr (HsApp e1 e2) res_ty = accum e1 [e2]
200 accum (HsApp e1 e2) args = accum e1 (e2:args)
202 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
203 returnTc (foldl HsApp fun' args', lie)
205 -- equivalent to (op e1) e2:
206 tcExpr (OpApp arg1 op fix arg2) res_ty
207 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
208 returnTc (OpApp arg1' op' fix arg2', lie)
211 Note that the operators in sections are expected to be binary, and
212 a type error will occur if they aren't.
215 -- Left sections, equivalent to
222 tcExpr in_expr@(SectionL arg op) res_ty
223 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
225 -- Check that res_ty is a function type
226 -- Without this check we barf in the desugarer on
228 -- because it tries to desugar to
229 -- f op = \r -> 3 op r
230 -- so (3 `op`) had better be a function!
231 tcAddErrCtxt (sectionLAppCtxt in_expr) $
232 unifyFunTy res_ty `thenTc_`
234 returnTc (SectionL arg' op', lie)
236 -- Right sections, equivalent to \ x -> x op expr, or
239 tcExpr in_expr@(SectionR op expr) res_ty
240 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
241 tcAddErrCtxt (sectionRAppCtxt in_expr) $
242 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
243 tcExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
244 unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
245 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
248 The interesting thing about @ccall@ is that it is just a template
249 which we instantiate by filling in details about the types of its
250 argument and result (ie minimal typechecking is performed). So, the
251 basic story is that we allocate a load of type variables (to hold the
252 arg/result types); unify them with the args/result; and store them for
256 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
257 = -- Get the callable and returnable classes.
258 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
259 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
260 tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
263 new_arg_dict (arg, arg_ty)
264 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
265 [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
266 returnNF_Tc arg_dicts -- Actually a singleton bag
268 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
272 mapNF_Tc (\ _ -> newTyVarTy mkTypeKind) [1..(length args)] `thenNF_Tc` \ ty_vars ->
273 tcExprs args ty_vars `thenTc` \ (args', args_lie) ->
275 -- The argument types can be unboxed or boxed; the result
276 -- type must, however, be boxed since it's an argument to the IO
278 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
280 io_result_ty = mkTyConApp ioTyCon [result_ty]
282 case tyConDataCons ioTyCon of { [ioDataCon] ->
283 unifyTauTy res_ty io_result_ty `thenTc_`
285 -- Construct the extra insts, which encode the
286 -- constraints on the argument and result types.
287 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
288 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
290 returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
291 (CCall lbl args' may_gc is_asm io_result_ty),
292 -- do the wrapping in the newtype constructor here
293 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
298 tcExpr (HsSCC label expr) res_ty
299 = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
300 returnTc (HsSCC label expr', lie)
302 tcExpr (HsLet binds expr) res_ty
305 binds -- Bindings to check
306 (tc_expr) `thenTc` \ (expr', lie) ->
307 returnTc (expr', lie)
309 tc_expr = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
310 returnTc (expr', lie)
311 combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
313 tcExpr in_expr@(HsCase scrut matches src_loc) res_ty
314 = tcAddSrcLoc src_loc $
315 tcAddErrCtxt (caseCtxt in_expr) $
317 -- Typecheck the case alternatives first.
318 -- The case patterns tend to give good type info to use
319 -- when typechecking the scrutinee. For example
322 -- will report that map is applied to too few arguments
324 tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
326 tcAddErrCtxt (caseScrutCtxt scrut) (
327 tcExpr scrut scrut_ty
328 ) `thenTc` \ (scrut',lie1) ->
330 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
332 tcExpr (HsIf pred b1 b2 src_loc) res_ty
333 = tcAddSrcLoc src_loc $
334 tcAddErrCtxt (predCtxt pred) (
335 tcExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
337 tcExpr b1 res_ty `thenTc` \ (b1',lie2) ->
338 tcExpr b2 res_ty `thenTc` \ (b2',lie3) ->
339 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
343 tcExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
344 = tcDoStmts do_or_lc stmts src_loc res_ty
348 tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
349 = unifyListTy res_ty `thenTc` \ elt_ty ->
350 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
351 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
354 = tcAddErrCtxt (listCtxt expr) $
357 tcExpr (ExplicitTuple exprs) res_ty
358 = unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
359 mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
360 (exprs `zip` arg_tys) -- we know they're of equal length.
361 `thenTc` \ (exprs', lies) ->
362 returnTc (ExplicitTuple exprs', plusLIEs lies)
364 tcExpr (RecordCon con_name _ rbinds) res_ty
365 = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
366 tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
368 (_, record_ty) = splitFunTys con_tau
370 -- Con is syntactically constrained to be a data constructor
371 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
372 unifyTauTy res_ty record_ty `thenTc_`
374 -- Check that the record bindings match the constructor
376 bad_fields = badFields rbinds con_id
378 checkTc (null bad_fields) (badFieldsCon con_id bad_fields) `thenTc_`
380 -- Typecheck the record bindings
381 -- (Do this after checkRecordFields in case there's a field that
382 -- doesn't match the constructor.)
383 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
385 returnTc (RecordCon (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
388 -- The main complication with RecordUpd is that we need to explicitly
389 -- handle the *non-updated* fields. Consider:
391 -- data T a b = MkT1 { fa :: a, fb :: b }
392 -- | MkT2 { fa :: a, fc :: Int -> Int }
393 -- | MkT3 { fd :: a }
395 -- upd :: T a b -> c -> T a c
396 -- upd t x = t { fb = x}
398 -- The type signature on upd is correct (i.e. the result should not be (T a b))
399 -- because upd should be equivalent to:
401 -- upd t x = case t of
402 -- MkT1 p q -> MkT1 p x
403 -- MkT2 a b -> MkT2 p b
404 -- MkT3 d -> error ...
406 -- So we need to give a completely fresh type to the result record,
407 -- and then constrain it by the fields that are *not* updated ("p" above).
409 -- Note that because MkT3 doesn't contain all the fields being updated,
410 -- its RHS is simply an error, so it doesn't impose any type constraints
412 -- All this is done in STEP 4 below.
414 tcExpr (RecordUpd record_expr rbinds) res_ty
415 = tcAddErrCtxt recordUpdCtxt $
418 -- Figure out the tycon and data cons from the first field name
419 ASSERT( not (null rbinds) )
421 ((first_field_name, _, _) : rest) = rbinds
423 tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
424 (case maybe_sel_id of
425 Just sel_id | isRecordSelector sel_id -> returnTc sel_id
426 other -> failWithTc (notSelector first_field_name)
427 ) `thenTc` \ sel_id ->
429 (_, tau) = splitForAllTys (idType sel_id)
430 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
431 (tycon, _, data_cons) = splitAlgTyConApp data_ty
432 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
434 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
437 -- Check for bad fields
438 checkTc (any (null . badFields rbinds) data_cons)
439 (badFieldsUpd rbinds) `thenTc_`
441 -- Typecheck the update bindings.
442 -- (Do this after checking for bad fields in case there's a field that
443 -- doesn't match the constructor.)
445 result_record_ty = mkTyConApp tycon result_inst_tys
447 unifyTauTy res_ty result_record_ty `thenTc_`
448 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
451 -- Use the un-updated fields to find a vector of booleans saying
452 -- which type arguments must be the same in updatee and result.
454 -- WARNING: this code assumes that all data_cons in a common tycon
455 -- have FieldLabels abstracted over the same tyvars.
457 upd_field_lbls = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
458 con_field_lbls_s = map dataConFieldLabels data_cons
460 -- A constructor is only relevant to this process if
461 -- it contains all the fields that are being updated
462 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
463 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
465 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
466 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
468 mk_inst_ty (tyvar, result_inst_ty)
469 | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
470 | otherwise = newTyVarTy mkBoxedTypeKind -- Fresh type
472 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
475 -- Typecheck the expression to be updated
477 record_ty = mkTyConApp tycon inst_tys
479 tcExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
482 -- Figure out the LIE we need. We have to generate some
483 -- dictionaries for the data type context, since we are going to
484 -- do some construction.
486 -- What dictionaries do we need? For the moment we assume that all
487 -- data constructors have the same context, and grab it from the first
488 -- constructor. If they have varying contexts then we'd have to
489 -- union the ones that could participate in the update.
491 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
492 inst_env = zipTyVarEnv tyvars result_inst_tys
494 tcInstTheta inst_env theta `thenNF_Tc` \ theta' ->
495 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
498 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
499 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
501 tcExpr (ArithSeqIn seq@(From expr)) res_ty
502 = unifyListTy res_ty `thenTc` \ elt_ty ->
503 tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
505 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
506 newMethod (ArithSeqOrigin seq)
507 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
509 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
512 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
513 = tcAddErrCtxt (arithSeqCtxt in_expr) $
514 unifyListTy res_ty `thenTc` \ elt_ty ->
515 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
516 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
517 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
518 newMethod (ArithSeqOrigin seq)
519 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
521 returnTc (ArithSeqOut (HsVar enum_from_then_id)
522 (FromThen expr1' expr2'),
523 lie1 `plusLIE` lie2 `plusLIE` lie3)
525 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
526 = tcAddErrCtxt (arithSeqCtxt in_expr) $
527 unifyListTy res_ty `thenTc` \ elt_ty ->
528 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
529 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
530 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
531 newMethod (ArithSeqOrigin seq)
532 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
534 returnTc (ArithSeqOut (HsVar enum_from_to_id)
535 (FromTo expr1' expr2'),
536 lie1 `plusLIE` lie2 `plusLIE` lie3)
538 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
539 = tcAddErrCtxt (arithSeqCtxt in_expr) $
540 unifyListTy res_ty `thenTc` \ elt_ty ->
541 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
542 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
543 tcExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
544 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
545 newMethod (ArithSeqOrigin seq)
546 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
548 returnTc (ArithSeqOut (HsVar eft_id)
549 (FromThenTo expr1' expr2' expr3'),
550 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
553 %************************************************************************
555 \subsection{Expressions type signatures}
557 %************************************************************************
560 tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
561 = tcSetErrCtxt (exprSigCtxt in_expr) $
562 tcHsType poly_ty `thenTc` \ sigma_sig ->
564 -- Check the tau-type part
565 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
567 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
570 -- Type check the expression, expecting the signature type
571 tcExtendGlobalTyVars sig_tyvars' (
573 ) `thenTc` \ (texpr, lie) ->
575 -- Check the type variables of the signature,
576 -- *after* typechecking the expression
577 checkSigTyVars sig_tyvars' sig_tau' `thenTc` \ zonked_sig_tyvars ->
579 -- Check overloading constraints
580 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
582 (ptext SLIT("the type signature") <+> quotes (ppr sigma_sig))
583 (mkTyVarSet zonked_sig_tyvars)
587 -- Now match the signature type with res_ty.
588 -- We must not do this earlier, because res_ty might well
589 -- mention variables free in the environment, and we'd get
590 -- bogus complaints about not being able to for-all the
592 unifyTauTy res_ty sig_tau' `thenTc_`
594 -- If everything is ok, return the stuff unchanged, except for
595 -- the effect of any substutions etc. We simply discard the
596 -- result of the tcSimplifyAndCheck, except for any default
597 -- resolution it may have done, which is recorded in the
599 returnTc (texpr, lie)
603 Typecheck expression which in most cases will be an Id.
606 tcExpr_id :: RenamedHsExpr
612 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
614 other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
615 tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
616 returnTc (id_expr', lie_id, id_ty)
619 %************************************************************************
621 \subsection{@tcApp@ typchecks an application}
623 %************************************************************************
627 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
628 -> TcType s -- Expected result type of application
629 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
632 tcApp fun args res_ty
633 = -- First type-check the function
634 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
636 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
637 split_fun_ty fun_ty (length args)
638 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
640 -- Unify with expected result before type-checking the args
641 -- This is when we might detect a too-few args situation
642 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
643 unifyTauTy res_ty actual_result_ty
646 -- Now typecheck the args
647 mapAndUnzipTc (tcArg fun)
648 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
650 -- Check that the result type doesn't have any nested for-alls.
651 -- For example, a "build" on its own is no good; it must be applied to something.
652 checkTc (isTauTy actual_result_ty)
653 (lurkingRank2Err fun fun_ty) `thenTc_`
655 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
658 -- If an error happens we try to figure out whether the
659 -- function has been given too many or too few arguments,
661 checkArgsCtxt fun args expected_res_ty actual_res_ty
662 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
663 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
665 (exp_args, _) = splitFunTys exp_ty'
666 (act_args, _) = splitFunTys act_ty'
667 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
668 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
669 | otherwise = appCtxt fun args
674 split_fun_ty :: TcType s -- The type of the function
675 -> Int -- Number of arguments
676 -> TcM s ([TcType s], -- Function argument types
677 TcType s) -- Function result types
679 split_fun_ty fun_ty 0
680 = returnTc ([], fun_ty)
682 split_fun_ty fun_ty n
683 = -- Expect the function to have type A->B
684 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
685 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
686 returnTc (arg_ty:arg_tys, final_res_ty)
690 tcArg :: RenamedHsExpr -- The function (for error messages)
691 -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
692 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
694 tcArg the_fun (arg, expected_arg_ty, arg_no)
695 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
696 tcPolyExpr (ptext SLIT("argument type of") <+> quotes (ppr the_fun))
700 -- tcPolyExpr is like tcExpr, except that the expected type
701 -- can be a polymorphic one.
702 tcPolyExpr str arg expected_arg_ty
703 | not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
704 = -- The ordinary, non-rank-2 polymorphic case
705 tcExpr arg expected_arg_ty
708 = -- Ha! The argument type of the function is a for-all type,
709 -- An example of rank-2 polymorphism.
711 -- No need to instantiate the argument type... it's must be the result
712 -- of instantiating a function involving rank-2 polymorphism, so there
713 -- isn't any danger of using the same tyvars twice
714 -- The argument type shouldn't be overloaded type (hence ASSERT)
716 -- To ensure that the forall'd type variables don't get unified with each
717 -- other or any other types, we make fresh *signature* type variables
718 -- and unify them with the tyvars.
719 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
721 (sig_theta, sig_tau) = splitRhoTy sig_rho
723 -- Type-check the arg and unify with expected type
724 tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
726 -- Check that the arg_tyvars havn't been constrained
727 -- The interesting bit here is that we must include the free variables
728 -- of the expected arg ty. Here's an example:
729 -- runST (newVar True)
730 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
731 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
732 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
733 -- So now s' isn't unconstrained because it's linked to a.
734 -- Conclusion: include the free vars of the expected arg type in the
735 -- list of "free vars" for the signature check.
737 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
738 tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
740 checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
741 newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
742 -- ToDo: better origin
746 (mkTyVarSet zonked_sig_tyvars)
747 sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
749 -- This HsLet binds any Insts which came out of the simplification.
750 -- It's a bit out of place here, but using AbsBind involves inventing
751 -- a couple of new names which seems worse.
752 returnTc ( TyLam zonked_sig_tyvars $
754 HsLet (MonoBind inst_binds [] Recursive)
760 %************************************************************************
762 \subsection{@tcId@ typchecks an identifier occurrence}
764 %************************************************************************
767 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
770 = -- Look up the Id and instantiate its type
771 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
774 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
776 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
777 tcInstType emptyTyVarEnv (idType id) `thenNF_Tc` \ inst_ty ->
779 (tyvars, rho) = splitForAllTys inst_ty
781 instantiate_it2 (RealId id) tyvars rho
784 -- The instantiate_it loop runs round instantiating the Id.
785 -- It has to be a loop because we are now prepared to entertain
787 -- f:: forall a. Eq a => forall b. Baz b => tau
788 -- We want to instantiate this to
789 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
790 instantiate_it tc_id_occ ty
791 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
792 instantiate_it2 tc_id_occ tyvars rho
794 instantiate_it2 tc_id_occ tyvars rho
795 = tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
796 if null theta then -- Is it overloaded?
797 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
799 -- Yes, it's overloaded
800 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
801 tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
802 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
803 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
806 arg_tys = mkTyVarTys tyvars
809 %************************************************************************
811 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
813 %************************************************************************
816 tcDoStmts do_or_lc stmts src_loc res_ty
817 = -- get the Monad and MonadZero classes
818 -- create type consisting of a fresh monad tyvar
819 ASSERT( not (null stmts) )
820 tcAddSrcLoc src_loc $
821 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
824 tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
825 tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
828 combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
829 combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
830 combine_stmts stmt _ ([], _) = panic "Bad last stmt tcDoStmts"
831 combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
833 tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
834 unifyTauTy res_ty result_ty `thenTc_`
836 -- Build the then and zero methods in case we need them
837 -- It's important that "then" and "return" appear just once in the final LIE,
838 -- not only for typechecker efficiency, but also because otherwise during
839 -- simplification we end up with silly stuff like
840 -- then = case d of (t,r) -> t
842 -- where the second "then" sees that it already exists in the "available" stuff.
844 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
845 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
846 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
848 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
850 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
852 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
854 monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
855 perhaps_zero_lie | all failure_free stmts' = emptyLIE
856 | otherwise = zero_lie
858 failure_free (BindStmt pat _ _) = failureFreePat pat
859 failure_free (GuardStmt _ _) = False
860 failure_free other_stmt = True
862 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
863 final_lie `plusLIE` monad_lie)
868 tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s)) -- This is tcExpr
869 -- The sole, disgusting, reason for this parameter
870 -- is to get the effect of polymorphic recursion
871 -- ToDo: rm when booting with Haskell 1.3
873 -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
874 -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
876 -> TcM s (thing, LIE s)
877 -> TcM s (thing, LIE s)
879 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
880 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
881 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
882 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
883 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
884 returnTc (ReturnStmt exp', exp_lie, m exp_ty)
885 ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
886 do_next `thenTc` \ (thing', thing_lie) ->
887 returnTc (combine stmt' (Just stmt_ty) thing',
888 stmt_lie `plusLIE` thing_lie)
890 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
891 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
892 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
893 tcAddSrcLoc src_loc (
894 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
895 tc_expr exp boolTy `thenTc` \ (exp', exp_lie) ->
896 returnTc (GuardStmt exp' src_loc, exp_lie)
897 )) `thenTc` \ (stmt', stmt_lie) ->
898 do_next `thenTc` \ (thing', thing_lie) ->
899 returnTc (combine stmt' Nothing thing',
900 stmt_lie `plusLIE` thing_lie)
902 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
903 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
904 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
905 tcAddSrcLoc src_loc (
906 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
907 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
909 -- exp has type (m tau) for some tau (doesn't matter what)
912 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
913 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
914 )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
915 do_next `thenTc` \ (thing', thing_lie) ->
916 returnTc (combine stmt' (Just stmt_ty) thing',
917 stmt_lie `plusLIE` thing_lie)
919 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
920 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
921 tcAddSrcLoc src_loc (
922 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
923 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
924 tc_expr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
926 -- NB: the environment has been extended with the new binders
927 -- which the rhs can't "see", but the renamer should have made
928 -- sure that everything is distinct by now, so there's no problem.
929 -- Putting the tcExpr before the newMonoIds messes up the nesting
930 -- of error contexts, so I didn't bother
932 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
933 )) `thenTc` \ (stmt', stmt_lie) ->
934 do_next `thenTc` \ (thing', thing_lie) ->
935 returnTc (combine stmt' Nothing thing',
936 stmt_lie `plusLIE` thing_lie)
938 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
939 = tcBindsAndThen -- No error context, but a binding group is
940 combine' -- rather a large thing for an error context anyway
944 combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
947 %************************************************************************
949 \subsection{Record bindings}
951 %************************************************************************
953 Game plan for record bindings
954 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
957 1. look up "field", to find its selector Id, which must have type
958 forall a1..an. T a1 .. an -> tau
959 where tau is the type of the field.
961 2. Instantiate this type
963 3. Unify the (T a1 .. an) part with the "expected result type", which
964 is passed in. This checks that all the field labels come from the
967 4. Type check the value using tcArg, passing tau as the expected
970 This extends OK when the field types are universally quantified.
972 Actually, to save excessive creation of fresh type variables,
977 :: TcType s -- Expected type of whole record
978 -> RenamedRecordBinds
979 -> TcM s (TcRecordBinds s, LIE s)
981 tcRecordBinds expected_record_ty rbinds
982 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
983 returnTc (rbinds', plusLIEs lies)
985 do_bind (field_label, rhs, pun_flag)
986 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
987 ASSERT( isRecordSelector sel_id )
988 -- This lookup and assertion will surely succeed, because
989 -- we check that the fields are indeed record selectors
990 -- before calling tcRecordBinds
992 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
994 -- Record selectors all have type
995 -- forall a1..an. T a1 .. an -> tau
996 ASSERT( maybeToBool (splitFunTy_maybe tau) )
998 -- Selector must have type RecordType -> FieldType
999 Just (record_ty, field_ty) = splitFunTy_maybe tau
1001 unifyTauTy expected_record_ty record_ty `thenTc_`
1002 tcPolyExpr (ptext SLIT("type of field") <+> quotes (ppr field_label))
1003 rhs field_ty `thenTc` \ (rhs', lie) ->
1004 returnTc ((RealId sel_id, rhs', pun_flag), lie)
1006 badFields rbinds data_con
1007 = [field_name | (field_name, _, _) <- rbinds,
1008 not (field_name `elem` field_names)
1011 field_names = map fieldLabelName (dataConFieldLabels data_con)
1014 %************************************************************************
1016 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
1018 %************************************************************************
1021 tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
1023 tcExprs [] [] = returnTc ([], emptyLIE)
1024 tcExprs (expr:exprs) (ty:tys)
1025 = tcExpr expr ty `thenTc` \ (expr', lie1) ->
1026 tcExprs exprs tys `thenTc` \ (exprs', lie2) ->
1027 returnTc (expr':exprs', lie1 `plusLIE` lie2)
1031 % =================================================
1038 pp_nest_hang :: String -> SDoc -> SDoc
1039 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
1042 Boring and alphabetical:
1045 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1048 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1051 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1054 = hang (ptext SLIT("In an expression with a type signature:"))
1058 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1061 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1063 sectionRAppCtxt expr
1064 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1066 sectionLAppCtxt expr
1067 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1069 funAppCtxt fun arg arg_no
1070 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1071 quotes (ppr fun) <> text ", namely"])
1072 4 (quotes (ppr arg))
1074 stmtCtxt do_or_lc stmt
1075 = hang (ptext SLIT("In a") <+> whatever <> colon)
1078 whatever = case do_or_lc of
1079 ListComp -> ptext SLIT("list-comprehension qualifier")
1080 DoStmt -> ptext SLIT("do statement")
1081 Guard -> ptext SLIT("guard")
1083 wrongArgsCtxt too_many_or_few fun args
1084 = hang (ptext SLIT("Probable cause:") <+> ppr fun
1085 <+> ptext SLIT("is applied to") <+> text too_many_or_few
1086 <+> ptext SLIT("arguments in the call"))
1087 4 (parens (ppr the_app))
1089 the_app = foldl HsApp fun args -- Used in error messages
1092 = ptext SLIT("In the application") <+> (ppr the_app)
1094 the_app = foldl HsApp fun args -- Used in error messages
1096 lurkingRank2Err fun fun_ty
1097 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1098 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1099 ptext SLIT("so that the result type has for-alls in it")])
1101 rank2ArgCtxt arg expected_arg_ty
1102 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1105 = hang (ptext SLIT("No constructor has all these fields:"))
1106 4 (pprQuotedList fields)
1108 fields = [field | (field, _, _) <- rbinds]
1110 recordUpdCtxt = ptext SLIT("In a record update construct")
1112 badFieldsCon con fields
1113 = hsep [ptext SLIT("Constructor"), ppr con,
1114 ptext SLIT("does not have field(s):"), pprQuotedList fields]
1117 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]