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 pprParendExpr, 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, sigThetaCtxt )
30 import TcEnv ( TcIdOcc(..), tcInstId,
31 tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
32 tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
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, zonkTcTyVars, 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, mkRhoTy,
55 splitFunTy_maybe, splitFunTys,
57 splitForAllTys, splitRhoTy, splitSigmaTy,
58 isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes,
59 splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe
61 import TyVar ( TyVarSet, emptyTyVarEnv, zipTyVarEnv,
62 unionTyVarSets, elementOfTyVarSet, mkTyVarSet, tyVarSetToList
64 import TyCon ( tyConDataCons )
65 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
66 floatPrimTy, addrPrimTy, realWorldTy
68 import TysWiredIn ( addrTy, mkTupleTy,
69 boolTy, charTy, stringTy, mkListTy
71 import PrelInfo ( ioTyCon_NAME )
72 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
73 unifyFunTy, unifyListTy, unifyTupleTy
75 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
76 enumFromClassOpKey, enumFromThenClassOpKey,
77 enumFromToClassOpKey, enumFromThenToClassOpKey,
78 thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
81 import PprType ( GenType, GenTyVar ) -- Instances
82 import Maybes ( maybeToBool )
83 import ListSetOps ( minusList )
88 tcExpr :: RenamedHsExpr -- Expession to type check
89 -> TcType s -- Expected type (could be a type variable)
90 -> TcM s (TcExpr s, LIE s)
93 %************************************************************************
95 \subsection{The TAUT rules for variables}
97 %************************************************************************
100 tcExpr (HsVar name) res_ty
101 = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
102 unifyTauTy res_ty id_ty `thenTc_`
104 -- Check that the result type doesn't have any nested for-alls.
105 -- For example, a "build" on its own is no good; it must be
106 -- applied to something.
107 checkTc (isTauTy id_ty)
108 (lurkingRank2Err name id_ty) `thenTc_`
110 returnTc (expr', lie)
113 %************************************************************************
115 \subsection{Literals}
117 %************************************************************************
122 tcExpr (HsLit (HsInt i)) res_ty
123 = newOverloadedLit (LiteralOrigin (HsInt i))
124 (OverloadedIntegral i)
125 res_ty `thenNF_Tc` \ stuff ->
128 tcExpr (HsLit (HsFrac f)) res_ty
129 = newOverloadedLit (LiteralOrigin (HsFrac f))
130 (OverloadedFractional f)
131 res_ty `thenNF_Tc` \ stuff ->
135 tcExpr (HsLit lit@(HsLitLit s)) res_ty
136 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
137 newDicts (LitLitOrigin (_UNPK_ s))
138 [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
139 returnTc (HsLitOut lit res_ty, dicts)
145 tcExpr (HsLit lit@(HsCharPrim c)) res_ty
146 = unifyTauTy charPrimTy res_ty `thenTc_`
147 returnTc (HsLitOut lit charPrimTy, emptyLIE)
149 tcExpr (HsLit lit@(HsStringPrim s)) res_ty
150 = unifyTauTy addrPrimTy res_ty `thenTc_`
151 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
153 tcExpr (HsLit lit@(HsIntPrim i)) res_ty
154 = unifyTauTy intPrimTy res_ty `thenTc_`
155 returnTc (HsLitOut lit intPrimTy, emptyLIE)
157 tcExpr (HsLit lit@(HsFloatPrim f)) res_ty
158 = unifyTauTy floatPrimTy res_ty `thenTc_`
159 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
161 tcExpr (HsLit lit@(HsDoublePrim d)) res_ty
162 = unifyTauTy doublePrimTy res_ty `thenTc_`
163 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
166 Unoverloaded literals:
169 tcExpr (HsLit lit@(HsChar c)) res_ty
170 = unifyTauTy charTy res_ty `thenTc_`
171 returnTc (HsLitOut lit charTy, emptyLIE)
173 tcExpr (HsLit lit@(HsString str)) res_ty
174 = unifyTauTy stringTy res_ty `thenTc_`
175 returnTc (HsLitOut lit stringTy, emptyLIE)
178 %************************************************************************
180 \subsection{Other expression forms}
182 %************************************************************************
185 tcExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
188 -- perform the negate *before* overloading the integer, since the case
189 -- of minBound on Ints fails otherwise. Could be done elsewhere, but
190 -- convenient to do it here.
192 tcExpr (NegApp (HsLit (HsInt i)) neg) res_ty
193 = tcExpr (HsLit (HsInt (-i))) res_ty
195 tcExpr (NegApp expr neg) res_ty
196 = tcExpr (HsApp neg expr) res_ty
198 tcExpr (HsLam match) res_ty
199 = tcMatchExpected [] res_ty match `thenTc` \ (match',lie) ->
200 returnTc (HsLam match', lie)
202 tcExpr (HsApp e1 e2) res_ty = accum e1 [e2]
204 accum (HsApp e1 e2) args = accum e1 (e2:args)
206 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
207 returnTc (foldl HsApp fun' args', lie)
209 -- equivalent to (op e1) e2:
210 tcExpr (OpApp arg1 op fix arg2) res_ty
211 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
212 returnTc (OpApp arg1' op' fix arg2', lie)
215 Note that the operators in sections are expected to be binary, and
216 a type error will occur if they aren't.
219 -- Left sections, equivalent to
226 tcExpr in_expr@(SectionL arg op) res_ty
227 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
229 -- Check that res_ty is a function type
230 -- Without this check we barf in the desugarer on
232 -- because it tries to desugar to
233 -- f op = \r -> 3 op r
234 -- so (3 `op`) had better be a function!
235 tcAddErrCtxt (sectionLAppCtxt in_expr) $
236 unifyFunTy res_ty `thenTc_`
238 returnTc (SectionL arg' op', lie)
240 -- Right sections, equivalent to \ x -> x op expr, or
243 tcExpr in_expr@(SectionR op expr) res_ty
244 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
245 tcAddErrCtxt (sectionRAppCtxt in_expr) $
246 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
247 tcExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
248 unifyTauTy (mkFunTy arg1_ty op_res_ty) res_ty `thenTc_`
249 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
252 The interesting thing about @ccall@ is that it is just a template
253 which we instantiate by filling in details about the types of its
254 argument and result (ie minimal typechecking is performed). So, the
255 basic story is that we allocate a load of type variables (to hold the
256 arg/result types); unify them with the args/result; and store them for
260 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
261 = -- Get the callable and returnable classes.
262 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
263 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
264 tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
267 new_arg_dict (arg, arg_ty)
268 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
269 [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
270 returnNF_Tc arg_dicts -- Actually a singleton bag
272 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
276 mapNF_Tc (\ _ -> newTyVarTy mkTypeKind) [1..(length args)] `thenNF_Tc` \ ty_vars ->
277 tcExprs args ty_vars `thenTc` \ (args', args_lie) ->
279 -- The argument types can be unboxed or boxed; the result
280 -- type must, however, be boxed since it's an argument to the IO
282 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
284 io_result_ty = mkTyConApp ioTyCon [result_ty]
286 case tyConDataCons ioTyCon of { [ioDataCon] ->
287 unifyTauTy io_result_ty res_ty `thenTc_`
289 -- Construct the extra insts, which encode the
290 -- constraints on the argument and result types.
291 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
292 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
294 returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
295 (CCall lbl args' may_gc is_asm io_result_ty),
296 -- do the wrapping in the newtype constructor here
297 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
302 tcExpr (HsSCC label expr) res_ty
303 = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
304 returnTc (HsSCC label expr', lie)
306 tcExpr (HsLet binds expr) res_ty
309 binds -- Bindings to check
310 (tc_expr) `thenTc` \ (expr', lie) ->
311 returnTc (expr', lie)
313 tc_expr = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
314 returnTc (expr', lie)
315 combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
317 tcExpr in_expr@(HsCase scrut matches src_loc) res_ty
318 = tcAddSrcLoc src_loc $
319 tcAddErrCtxt (caseCtxt in_expr) $
321 -- Typecheck the case alternatives first.
322 -- The case patterns tend to give good type info to use
323 -- when typechecking the scrutinee. For example
326 -- will report that map is applied to too few arguments
328 tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
330 tcAddErrCtxt (caseScrutCtxt scrut) (
331 tcExpr scrut scrut_ty
332 ) `thenTc` \ (scrut',lie1) ->
334 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
336 tcExpr (HsIf pred b1 b2 src_loc) res_ty
337 = tcAddSrcLoc src_loc $
338 tcAddErrCtxt (predCtxt pred) (
339 tcExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
341 tcExpr b1 res_ty `thenTc` \ (b1',lie2) ->
342 tcExpr b2 res_ty `thenTc` \ (b2',lie3) ->
343 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
347 tcExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
348 = tcDoStmts do_or_lc stmts src_loc res_ty
352 tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
353 = unifyListTy res_ty `thenTc` \ elt_ty ->
354 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
355 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
358 = tcAddErrCtxt (listCtxt expr) $
361 tcExpr (ExplicitTuple exprs) res_ty
362 = unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
363 mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
364 (exprs `zip` arg_tys) -- we know they're of equal length.
365 `thenTc` \ (exprs', lies) ->
366 returnTc (ExplicitTuple exprs', plusLIEs lies)
368 tcExpr (RecordCon con_name _ rbinds) res_ty
369 = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
370 tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
372 (_, record_ty) = splitFunTys con_tau
374 -- Con is syntactically constrained to be a data constructor
375 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
376 unifyTauTy res_ty record_ty `thenTc_`
378 -- Check that the record bindings match the constructor
380 bad_fields = badFields rbinds con_id
382 checkTc (null bad_fields) (badFieldsCon con_id bad_fields) `thenTc_`
384 -- Typecheck the record bindings
385 -- (Do this after checkRecordFields in case there's a field that
386 -- doesn't match the constructor.)
387 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
389 returnTc (RecordCon (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
392 -- The main complication with RecordUpd is that we need to explicitly
393 -- handle the *non-updated* fields. Consider:
395 -- data T a b = MkT1 { fa :: a, fb :: b }
396 -- | MkT2 { fa :: a, fc :: Int -> Int }
397 -- | MkT3 { fd :: a }
399 -- upd :: T a b -> c -> T a c
400 -- upd t x = t { fb = x}
402 -- The type signature on upd is correct (i.e. the result should not be (T a b))
403 -- because upd should be equivalent to:
405 -- upd t x = case t of
406 -- MkT1 p q -> MkT1 p x
407 -- MkT2 a b -> MkT2 p b
408 -- MkT3 d -> error ...
410 -- So we need to give a completely fresh type to the result record,
411 -- and then constrain it by the fields that are *not* updated ("p" above).
413 -- Note that because MkT3 doesn't contain all the fields being updated,
414 -- its RHS is simply an error, so it doesn't impose any type constraints
416 -- All this is done in STEP 4 below.
418 tcExpr (RecordUpd record_expr rbinds) res_ty
419 = tcAddErrCtxt recordUpdCtxt $
422 -- Figure out the tycon and data cons from the first field name
423 ASSERT( not (null rbinds) )
425 ((first_field_name, _, _) : rest) = rbinds
427 tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
428 (case maybe_sel_id of
429 Just sel_id | isRecordSelector sel_id -> returnTc sel_id
430 other -> failWithTc (notSelector first_field_name)
431 ) `thenTc` \ sel_id ->
433 (_, tau) = splitForAllTys (idType sel_id)
434 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
435 (tycon, _, data_cons) = splitAlgTyConApp data_ty
436 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
438 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
441 -- Check for bad fields
442 checkTc (any (null . badFields rbinds) data_cons)
443 (badFieldsUpd rbinds) `thenTc_`
445 -- Typecheck the update bindings.
446 -- (Do this after checking for bad fields in case there's a field that
447 -- doesn't match the constructor.)
449 result_record_ty = mkTyConApp tycon result_inst_tys
451 unifyTauTy res_ty result_record_ty `thenTc_`
452 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
455 -- Use the un-updated fields to find a vector of booleans saying
456 -- which type arguments must be the same in updatee and result.
458 -- WARNING: this code assumes that all data_cons in a common tycon
459 -- have FieldLabels abstracted over the same tyvars.
461 upd_field_lbls = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
462 con_field_lbls_s = map dataConFieldLabels data_cons
464 -- A constructor is only relevant to this process if
465 -- it contains all the fields that are being updated
466 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
467 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
469 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
470 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
472 mk_inst_ty (tyvar, result_inst_ty)
473 | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
474 | otherwise = newTyVarTy mkBoxedTypeKind -- Fresh type
476 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
479 -- Typecheck the expression to be updated
481 record_ty = mkTyConApp tycon inst_tys
483 tcExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
486 -- Figure out the LIE we need. We have to generate some
487 -- dictionaries for the data type context, since we are going to
488 -- do some construction.
490 -- What dictionaries do we need? For the moment we assume that all
491 -- data constructors have the same context, and grab it from the first
492 -- constructor. If they have varying contexts then we'd have to
493 -- union the ones that could participate in the update.
495 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
496 inst_env = zipTyVarEnv tyvars result_inst_tys
498 tcInstTheta inst_env theta `thenNF_Tc` \ theta' ->
499 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
502 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
503 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
505 tcExpr (ArithSeqIn seq@(From expr)) res_ty
506 = unifyListTy res_ty `thenTc` \ elt_ty ->
507 tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
509 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
510 newMethod (ArithSeqOrigin seq)
511 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
513 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
516 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
517 = tcAddErrCtxt (arithSeqCtxt in_expr) $
518 unifyListTy res_ty `thenTc` \ elt_ty ->
519 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
520 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
521 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
522 newMethod (ArithSeqOrigin seq)
523 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
525 returnTc (ArithSeqOut (HsVar enum_from_then_id)
526 (FromThen expr1' expr2'),
527 lie1 `plusLIE` lie2 `plusLIE` lie3)
529 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
530 = tcAddErrCtxt (arithSeqCtxt in_expr) $
531 unifyListTy res_ty `thenTc` \ elt_ty ->
532 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
533 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
534 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
535 newMethod (ArithSeqOrigin seq)
536 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
538 returnTc (ArithSeqOut (HsVar enum_from_to_id)
539 (FromTo expr1' expr2'),
540 lie1 `plusLIE` lie2 `plusLIE` lie3)
542 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
543 = tcAddErrCtxt (arithSeqCtxt in_expr) $
544 unifyListTy res_ty `thenTc` \ elt_ty ->
545 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
546 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
547 tcExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
548 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
549 newMethod (ArithSeqOrigin seq)
550 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
552 returnTc (ArithSeqOut (HsVar eft_id)
553 (FromThenTo expr1' expr2' expr3'),
554 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
557 %************************************************************************
559 \subsection{Expressions type signatures}
561 %************************************************************************
564 tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
565 = tcSetErrCtxt (exprSigCtxt in_expr) $
566 tcHsType poly_ty `thenTc` \ sigma_sig ->
568 -- Check the tau-type part
569 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
571 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
574 -- Type check the expression, expecting the signature type
575 tcExtendGlobalTyVars sig_tyvars' (
577 ) `thenTc` \ (texpr, lie) ->
579 -- Check the type variables of the signature,
580 -- *after* typechecking the expression
581 checkSigTyVars sig_tyvars' sig_tau' `thenTc` \ zonked_sig_tyvars ->
583 -- Check overloading constraints
584 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
585 tcAddErrCtxtM (sigThetaCtxt sig_dicts) (
588 (mkTyVarSet zonked_sig_tyvars)
592 -- Now match the signature type with res_ty.
593 -- We must not do this earlier, because res_ty might well
594 -- mention variables free in the environment, and we'd get
595 -- bogus complaints about not being able to for-all the
597 unifyTauTy sig_tau' res_ty `thenTc_`
599 -- If everything is ok, return the stuff unchanged, except for
600 -- the effect of any substutions etc. We simply discard the
601 -- result of the tcSimplifyAndCheck, except for any default
602 -- resolution it may have done, which is recorded in the
604 returnTc (texpr, lie)
608 Typecheck expression which in most cases will be an Id.
611 tcExpr_id :: RenamedHsExpr
617 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
619 other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
620 tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
621 returnTc (id_expr', lie_id, id_ty)
624 %************************************************************************
626 \subsection{@tcApp@ typchecks an application}
628 %************************************************************************
632 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
633 -> TcType s -- Expected result type of application
634 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
637 tcApp fun args res_ty
638 = -- First type-check the function
639 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
641 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
642 split_fun_ty fun_ty (length args)
643 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
645 -- Unify with expected result before type-checking the args
646 -- This is when we might detect a too-few args situation
647 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
648 unifyTauTy res_ty actual_result_ty
651 -- Now typecheck the args
652 mapAndUnzipTc (tcArg fun)
653 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
655 -- Check that the result type doesn't have any nested for-alls.
656 -- For example, a "build" on its own is no good; it must be applied to something.
657 checkTc (isTauTy actual_result_ty)
658 (lurkingRank2Err fun fun_ty) `thenTc_`
660 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
663 -- If an error happens we try to figure out whether the
664 -- function has been given too many or too few arguments,
666 checkArgsCtxt fun args expected_res_ty actual_res_ty
667 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
668 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
670 (exp_args, _) = splitFunTys exp_ty'
671 (act_args, _) = splitFunTys act_ty'
672 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
673 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
674 | otherwise = appCtxt fun args
679 split_fun_ty :: TcType s -- The type of the function
680 -> Int -- Number of arguments
681 -> TcM s ([TcType s], -- Function argument types
682 TcType s) -- Function result types
684 split_fun_ty fun_ty 0
685 = returnTc ([], fun_ty)
687 split_fun_ty fun_ty n
688 = -- Expect the function to have type A->B
689 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
690 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
691 returnTc (arg_ty:arg_tys, final_res_ty)
695 tcArg :: RenamedHsExpr -- The function (for error messages)
696 -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
697 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
699 tcArg the_fun (arg, expected_arg_ty, arg_no)
700 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
701 tcPolyExpr arg expected_arg_ty
704 -- tcPolyExpr is like tcExpr, except that the expected type
705 -- can be a polymorphic one.
706 tcPolyExpr arg expected_arg_ty
707 | not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
708 = -- The ordinary, non-rank-2 polymorphic case
709 tcExpr arg expected_arg_ty
712 = -- Ha! The argument type of the function is a for-all type,
713 -- An example of rank-2 polymorphism.
715 -- No need to instantiate the argument type... it's must be the result
716 -- of instantiating a function involving rank-2 polymorphism, so there
717 -- isn't any danger of using the same tyvars twice
718 -- The argument type shouldn't be overloaded type (hence ASSERT)
720 -- To ensure that the forall'd type variables don't get unified with each
721 -- other or any other types, we make fresh *signature* type variables
722 -- and unify them with the tyvars.
723 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
725 (sig_theta, sig_tau) = splitRhoTy sig_rho
727 -- Type-check the arg and unify with expected type
728 tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
730 -- Check that the arg_tyvars havn't been constrained
731 -- The interesting bit here is that we must include the free variables
732 -- of the expected arg ty. Here's an example:
733 -- runST (newVar True)
734 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
735 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
736 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
737 -- So now s' isn't unconstrained because it's linked to a.
738 -- Conclusion: include the free vars of the expected arg type in the
739 -- list of "free vars" for the signature check.
741 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
742 tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
744 checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
745 newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
746 -- ToDo: better origin
748 tcAddErrCtxtM (sigThetaCtxt sig_dicts) $
749 tcSimplifyAndCheck (text "rank2")
750 (mkTyVarSet zonked_sig_tyvars)
751 sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
753 -- This HsLet binds any Insts which came out of the simplification.
754 -- It's a bit out of place here, but using AbsBind involves inventing
755 -- a couple of new names which seems worse.
756 returnTc ( TyLam zonked_sig_tyvars $
758 HsLet (MonoBind inst_binds [] Recursive)
764 %************************************************************************
766 \subsection{@tcId@ typchecks an identifier occurrence}
768 %************************************************************************
771 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
774 = -- Look up the Id and instantiate its type
775 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
778 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
780 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
781 tcInstType emptyTyVarEnv (idType id) `thenNF_Tc` \ inst_ty ->
783 (tyvars, rho) = splitForAllTys inst_ty
785 instantiate_it2 (RealId id) tyvars rho
788 -- The instantiate_it loop runs round instantiating the Id.
789 -- It has to be a loop because we are now prepared to entertain
791 -- f:: forall a. Eq a => forall b. Baz b => tau
792 -- We want to instantiate this to
793 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
794 instantiate_it tc_id_occ ty
795 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
796 instantiate_it2 tc_id_occ tyvars rho
798 instantiate_it2 tc_id_occ tyvars rho
799 = tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
800 if null theta then -- Is it overloaded?
801 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
803 -- Yes, it's overloaded
804 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
805 tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
806 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
807 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
810 arg_tys = mkTyVarTys tyvars
813 %************************************************************************
815 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
817 %************************************************************************
820 tcDoStmts do_or_lc stmts src_loc res_ty
821 = -- get the Monad and MonadZero classes
822 -- create type consisting of a fresh monad tyvar
823 ASSERT( not (null stmts) )
824 tcAddSrcLoc src_loc $
825 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
828 tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
829 tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
832 combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
833 combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
834 combine_stmts stmt _ ([], _) = panic "Bad last stmt tcDoStmts"
835 combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
837 tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
838 unifyTauTy result_ty res_ty `thenTc_`
840 -- Build the then and zero methods in case we need them
841 -- It's important that "then" and "return" appear just once in the final LIE,
842 -- not only for typechecker efficiency, but also because otherwise during
843 -- simplification we end up with silly stuff like
844 -- then = case d of (t,r) -> t
846 -- where the second "then" sees that it already exists in the "available" stuff.
848 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
849 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
850 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
852 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
854 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
856 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
858 monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
859 perhaps_zero_lie | all failure_free stmts' = emptyLIE
860 | otherwise = zero_lie
862 failure_free (BindStmt pat _ _) = failureFreePat pat
863 failure_free (GuardStmt _ _) = False
864 failure_free other_stmt = True
866 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
867 final_lie `plusLIE` monad_lie)
872 tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s)) -- This is tcExpr
873 -- The sole, disgusting, reason for this parameter
874 -- is to get the effect of polymorphic recursion
875 -- ToDo: rm when booting with Haskell 1.3
877 -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
878 -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
880 -> TcM s (thing, LIE s)
881 -> TcM s (thing, LIE s)
883 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
884 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
885 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
886 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
887 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
888 returnTc (ReturnStmt exp', exp_lie, m exp_ty)
889 ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
890 do_next `thenTc` \ (thing', thing_lie) ->
891 returnTc (combine stmt' (Just stmt_ty) thing',
892 stmt_lie `plusLIE` thing_lie)
894 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
895 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
896 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
897 tcAddSrcLoc src_loc (
898 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
899 tc_expr exp boolTy `thenTc` \ (exp', exp_lie) ->
900 returnTc (GuardStmt exp' src_loc, exp_lie)
901 )) `thenTc` \ (stmt', stmt_lie) ->
902 do_next `thenTc` \ (thing', thing_lie) ->
903 returnTc (combine stmt' Nothing thing',
904 stmt_lie `plusLIE` thing_lie)
906 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
907 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
908 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
909 tcAddSrcLoc src_loc (
910 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
911 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
913 -- exp has type (m tau) for some tau (doesn't matter what)
916 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
917 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
918 )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
919 do_next `thenTc` \ (thing', thing_lie) ->
920 returnTc (combine stmt' (Just stmt_ty) thing',
921 stmt_lie `plusLIE` thing_lie)
923 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
924 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
925 tcAddSrcLoc src_loc (
926 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
927 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
928 tc_expr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
930 -- NB: the environment has been extended with the new binders
931 -- which the rhs can't "see", but the renamer should have made
932 -- sure that everything is distinct by now, so there's no problem.
933 -- Putting the tcExpr before the newMonoIds messes up the nesting
934 -- of error contexts, so I didn't bother
936 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
937 )) `thenTc` \ (stmt', stmt_lie) ->
938 do_next `thenTc` \ (thing', thing_lie) ->
939 returnTc (combine stmt' Nothing thing',
940 stmt_lie `plusLIE` thing_lie)
942 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
943 = tcBindsAndThen -- No error context, but a binding group is
944 combine' -- rather a large thing for an error context anyway
948 combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
951 %************************************************************************
953 \subsection{Record bindings}
955 %************************************************************************
957 Game plan for record bindings
958 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
961 1. look up "field", to find its selector Id, which must have type
962 forall a1..an. T a1 .. an -> tau
963 where tau is the type of the field.
965 2. Instantiate this type
967 3. Unify the (T a1 .. an) part with the "expected result type", which
968 is passed in. This checks that all the field labels come from the
971 4. Type check the value using tcArg, passing tau as the expected
974 This extends OK when the field types are universally quantified.
976 Actually, to save excessive creation of fresh type variables,
981 :: TcType s -- Expected type of whole record
982 -> RenamedRecordBinds
983 -> TcM s (TcRecordBinds s, LIE s)
985 tcRecordBinds expected_record_ty rbinds
986 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
987 returnTc (rbinds', plusLIEs lies)
989 do_bind (field_label, rhs, pun_flag)
990 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
991 ASSERT( isRecordSelector sel_id )
992 -- This lookup and assertion will surely succeed, because
993 -- we check that the fields are indeed record selectors
994 -- before calling tcRecordBinds
996 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
998 -- Record selectors all have type
999 -- forall a1..an. T a1 .. an -> tau
1000 ASSERT( maybeToBool (splitFunTy_maybe tau) )
1002 -- Selector must have type RecordType -> FieldType
1003 Just (record_ty, field_ty) = splitFunTy_maybe tau
1005 unifyTauTy expected_record_ty record_ty `thenTc_`
1006 tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) ->
1007 returnTc ((RealId sel_id, rhs', pun_flag), lie)
1009 badFields rbinds data_con
1010 = [field_name | (field_name, _, _) <- rbinds,
1011 not (field_name `elem` field_names)
1014 field_names = map fieldLabelName (dataConFieldLabels data_con)
1017 %************************************************************************
1019 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
1021 %************************************************************************
1024 tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
1026 tcExprs [] [] = returnTc ([], emptyLIE)
1027 tcExprs (expr:exprs) (ty:tys)
1028 = tcExpr expr ty `thenTc` \ (expr', lie1) ->
1029 tcExprs exprs tys `thenTc` \ (exprs', lie2) ->
1030 returnTc (expr':exprs', lie1 `plusLIE` lie2)
1034 % =================================================
1041 pp_nest_hang :: String -> SDoc -> SDoc
1042 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
1045 Boring and alphabetical:
1048 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1051 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1054 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1057 = hang (ptext SLIT("In an expression with a type signature:"))
1061 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1064 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1066 sectionRAppCtxt expr
1067 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1069 sectionLAppCtxt expr
1070 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1072 funAppCtxt fun arg arg_no
1073 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1074 quotes (ppr fun) <> text ", namely"])
1075 4 (quotes (ppr arg))
1077 stmtCtxt do_or_lc stmt
1078 = hang (ptext SLIT("In a") <+> whatever <> colon)
1081 whatever = case do_or_lc of
1082 ListComp -> ptext SLIT("list-comprehension qualifier")
1083 DoStmt -> ptext SLIT("do statement")
1084 Guard -> ptext SLIT("guard")
1086 wrongArgsCtxt too_many_or_few fun args
1087 = hang (ptext SLIT("Probable cause:") <+> ppr fun
1088 <+> ptext SLIT("is applied to") <+> text too_many_or_few
1089 <+> ptext SLIT("arguments in the call"))
1092 the_app = foldl HsApp fun args -- Used in error messages
1095 = ptext SLIT("In the application") <+> (ppr the_app)
1097 the_app = foldl HsApp fun args -- Used in error messages
1099 lurkingRank2Err fun fun_ty
1100 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1101 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1102 ptext SLIT("so that the result type has for-alls in it")])
1104 rank2ArgCtxt arg expected_arg_ty
1105 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1108 = hang (ptext SLIT("No constructor has all these fields:"))
1109 4 (pprQuotedList fields)
1111 fields = [field | (field, _, _) <- rbinds]
1113 recordUpdCtxt = ptext SLIT("In a record update construct")
1115 badFieldsCon con fields
1116 = hsep [ptext SLIT("Constructor"), ppr con,
1117 ptext SLIT("does not have field(s):"), pprQuotedList fields]
1120 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]