2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcExpr]{Typecheck an expression}
7 #include "HsVersions.h"
9 module TcExpr ( tcExpr, tcStmt, tcId ) where
13 import HsSyn ( HsExpr(..), Stmt(..), DoOrListComp(..),
14 HsBinds(..), MonoBinds(..),
15 SYN_IE(RecFlag), nonRecursive,
16 ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
17 Match, Fake, InPat, OutPat, HsType, Fixity,
18 pprParendExpr, failureFreePat, collectPatBinders )
19 import RnHsSyn ( SYN_IE(RenamedHsExpr),
20 SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
22 import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcStmt),
23 SYN_IE(TcRecordBinds),
28 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
29 SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
30 newMethod, newMethodWithGivenTy, newDicts )
31 import TcBinds ( tcBindsAndThen, checkSigTyVars )
32 import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
33 tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
34 tcExtendGlobalTyVars, tcLookupGlobalValueMaybe
36 import SpecEnv ( SpecEnv )
37 import TcMatches ( tcMatchesCase, tcMatchExpected )
38 import TcMonoType ( tcHsType )
39 import TcPat ( tcPat )
40 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
41 import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe(..),
42 tcInstId, tcInstType, tcInstSigTcType, tcInstTyVars,
43 tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
44 newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
45 import TcKind ( TcKind )
47 import Class ( SYN_IE(Class) )
48 import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
49 import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
53 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
54 import Name ( Name{-instance Eq-} )
55 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
56 getTyVar_maybe, getFunTy_maybe, instantiateTy, applyTyCon,
57 splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
58 isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes, getForAllTy_maybe,
59 getAppDataTyCon, maybeAppDataTyCon
61 import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet )
62 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
63 floatPrimTy, addrPrimTy, realWorldTy
65 import TysWiredIn ( addrTy,
66 boolTy, charTy, stringTy, mkListTy,
67 mkTupleTy, mkPrimIoTy, stDataCon
69 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
70 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
71 enumFromClassOpKey, enumFromThenClassOpKey,
72 enumFromToClassOpKey, enumFromThenToClassOpKey,
73 thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
75 import Outputable ( speakNth, interpp'SP, Outputable(..) )
76 import PprType ( GenType, GenTyVar ) -- Instances
77 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 id_ty res_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 charPrimTy res_ty `thenTc_`
143 returnTc (HsLitOut lit charPrimTy, emptyLIE)
145 tcExpr (HsLit lit@(HsStringPrim s)) res_ty
146 = unifyTauTy addrPrimTy res_ty `thenTc_`
147 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
149 tcExpr (HsLit lit@(HsIntPrim i)) res_ty
150 = unifyTauTy intPrimTy res_ty `thenTc_`
151 returnTc (HsLitOut lit intPrimTy, emptyLIE)
153 tcExpr (HsLit lit@(HsFloatPrim f)) res_ty
154 = unifyTauTy floatPrimTy res_ty `thenTc_`
155 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
157 tcExpr (HsLit lit@(HsDoublePrim d)) res_ty
158 = unifyTauTy doublePrimTy res_ty `thenTc_`
159 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
162 Unoverloaded literals:
165 tcExpr (HsLit lit@(HsChar c)) res_ty
166 = unifyTauTy charTy res_ty `thenTc_`
167 returnTc (HsLitOut lit charTy, emptyLIE)
169 tcExpr (HsLit lit@(HsString str)) res_ty
170 = unifyTauTy stringTy res_ty `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 tcExpr (NegApp expr neg) res_ty = tcExpr (HsApp neg expr) res_ty
186 tcExpr (HsLam match) res_ty
187 = tcMatchExpected res_ty match `thenTc` \ (match',lie) ->
188 returnTc (HsLam match', lie)
190 tcExpr (HsApp e1 e2) res_ty = accum e1 [e2]
192 accum (HsApp e1 e2) args = accum e1 (e2:args)
194 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
195 returnTc (foldl HsApp fun' args', lie)
197 -- equivalent to (op e1) e2:
198 tcExpr (OpApp arg1 op fix arg2) res_ty
199 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
200 returnTc (OpApp arg1' op' fix arg2', lie)
203 Note that the operators in sections are expected to be binary, and
204 a type error will occur if they aren't.
207 -- Left sections, equivalent to
214 tcExpr in_expr@(SectionL arg op) res_ty
215 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
217 -- Check that res_ty is a function type
218 -- Without this check we barf in the desugarer on
220 -- because it tries to desugar to
221 -- f op = \r -> 3 op r
222 -- so (3 `op`) had better be a function!
223 tcAddErrCtxt (sectionLAppCtxt in_expr) $
224 unifyFunTy res_ty `thenTc_`
226 returnTc (SectionL arg' op', lie)
228 -- Right sections, equivalent to \ x -> x op expr, or
231 tcExpr in_expr@(SectionR op expr) res_ty
232 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
233 tcAddErrCtxt (sectionRAppCtxt in_expr) $
234 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
235 tcExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
236 unifyTauTy (mkFunTy arg1_ty op_res_ty) res_ty `thenTc_`
237 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
240 The interesting thing about @ccall@ is that it is just a template
241 which we instantiate by filling in details about the types of its
242 argument and result (ie minimal typechecking is performed). So, the
243 basic story is that we allocate a load of type variables (to hold the
244 arg/result types); unify them with the args/result; and store them for
248 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
249 = -- Get the callable and returnable classes.
250 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
251 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
254 new_arg_dict (arg, arg_ty)
255 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
256 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
257 returnNF_Tc arg_dicts -- Actually a singleton bag
259 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
263 mapNF_Tc (\ _ -> newTyVarTy mkTypeKind) [1..(length args)] `thenNF_Tc` \ ty_vars ->
264 tcExprs args ty_vars `thenTc` \ (args', args_lie) ->
266 -- The argument types can be unboxed or boxed; the result
267 -- type must, however, be boxed since it's an argument to the PrimIO
269 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
270 unifyTauTy (mkPrimIoTy result_ty) res_ty `thenTc_`
272 -- Construct the extra insts, which encode the
273 -- constraints on the argument and result types.
274 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
275 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
277 returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
278 (CCall lbl args' may_gc is_asm result_ty),
279 -- do the wrapping in the newtype constructor here
280 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
284 tcExpr (HsSCC label expr) res_ty
285 = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
286 returnTc (HsSCC label expr', lie)
288 tcExpr (HsLet binds expr) res_ty
291 binds -- Bindings to check
292 (tc_expr) `thenTc` \ (expr', lie) ->
293 returnTc (expr', lie)
295 tc_expr = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
296 returnTc (expr', lie)
297 combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
299 tcExpr in_expr@(HsCase expr matches src_loc) res_ty
300 = tcAddSrcLoc src_loc $
301 newTyVarTy mkTypeKind `thenNF_Tc` \ expr_ty ->
302 tcExpr expr expr_ty `thenTc` \ (expr',lie1) ->
304 tcAddErrCtxt (caseCtxt in_expr) $
305 tcMatchesCase (mkFunTy expr_ty res_ty) matches
306 `thenTc` \ (matches',lie2) ->
308 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2)
310 tcExpr (HsIf pred b1 b2 src_loc) res_ty
311 = tcAddSrcLoc src_loc $
312 tcAddErrCtxt (predCtxt pred) (
313 tcExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
315 tcAddErrCtxt (branchCtxt b1 b2) $
316 tcExpr b1 res_ty `thenTc` \ (b1',lie2) ->
317 tcExpr b2 res_ty `thenTc` \ (b2',lie3) ->
318 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
322 tcExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
323 = tcDoStmts do_or_lc stmts src_loc res_ty
327 tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
328 = unifyListTy res_ty `thenTc` \ elt_ty ->
329 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
330 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
333 = tcAddErrCtxt (listCtxt expr) $
336 tcExpr (ExplicitTuple exprs) res_ty
337 -- ToDo: more direct way of testing if res_ty is a tuple type (cf. unifyListTy)?
338 = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..len] `thenNF_Tc` \ ty_vars ->
339 unifyTauTy (mkTupleTy len ty_vars) res_ty `thenTc_`
340 mapAndUnzipTc (\ (expr,ty_var) -> tcExpr expr ty_var)
341 (exprs `zip` ty_vars) -- we know they're of equal length.
342 `thenTc` \ (exprs', lies) ->
343 returnTc (ExplicitTuple exprs', plusLIEs lies)
347 tcExpr (RecordCon (HsVar con) rbinds) res_ty
348 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
350 (_, record_ty) = splitFunTy con_tau
352 -- Con is syntactically constrained to be a data constructor
353 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
354 unifyTauTy record_ty res_ty `thenTc_`
356 -- Check that the record bindings match the constructor
357 tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
359 bad_fields = badFields rbinds con_id
361 checkTc (null bad_fields) (badFieldsCon con bad_fields) `thenTc_`
363 -- Typecheck the record bindings
364 -- (Do this after checkRecordFields in case there's a field that
365 -- doesn't match the constructor.)
366 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
368 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie)
371 -- The main complication with RecordUpd is that we need to explicitly
372 -- handle the *non-updated* fields. Consider:
374 -- data T a b = MkT1 { fa :: a, fb :: b }
375 -- | MkT2 { fa :: a, fc :: Int -> Int }
376 -- | MkT3 { fd :: a }
378 -- upd :: T a b -> c -> T a c
379 -- upd t x = t { fb = x}
381 -- The type signature on upd is correct (i.e. the result should not be (T a b))
382 -- because upd should be equivalent to:
384 -- upd t x = case t of
385 -- MkT1 p q -> MkT1 p x
386 -- MkT2 a b -> MkT2 p b
387 -- MkT3 d -> error ...
389 -- So we need to give a completely fresh type to the result record,
390 -- and then constrain it by the fields that are *not* updated ("p" above).
392 -- Note that because MkT3 doesn't contain all the fields being updated,
393 -- its RHS is simply an error, so it doesn't impose any type constraints
395 -- All this is done in STEP 4 below.
397 tcExpr (RecordUpd record_expr rbinds) res_ty
398 = tcAddErrCtxt recordUpdCtxt $
401 -- Figure out the tycon and data cons from the first field name
402 ASSERT( not (null rbinds) )
404 ((first_field_name, _, _) : rest) = rbinds
406 tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
407 (case maybe_sel_id of
408 Just sel_id | isRecordSelector sel_id -> returnTc sel_id
409 other -> failTc (notSelector first_field_name)
410 ) `thenTc` \ sel_id ->
412 (_, tau) = splitForAllTy (idType sel_id)
413 Just (data_ty, _) = getFunTy_maybe tau -- Must succeed since sel_id is a selector
414 (tycon, _, data_cons) = getAppDataTyCon data_ty
415 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
417 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, result_inst_env) ->
420 -- Check for bad fields
421 checkTc (any (null . badFields rbinds) data_cons)
422 (badFieldsUpd rbinds) `thenTc_`
424 -- Typecheck the update bindings.
425 -- (Do this after checking for bad fields in case there's a field that
426 -- doesn't match the constructor.)
428 result_record_ty = applyTyCon tycon result_inst_tys
430 unifyTauTy result_record_ty res_ty `thenTc_`
431 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
434 -- Use the un-updated fields to find a vector of booleans saying
435 -- which type arguments must be the same in updatee and result.
437 -- WARNING: this code assumes that all data_cons in a common tycon
438 -- have FieldLabels abstracted over the same tyvars.
440 upd_field_lbls = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
441 con_field_lbls_s = map dataConFieldLabels data_cons
443 -- A constructor is only relevant to this process if
444 -- it contains all the fields that are being updated
445 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
446 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
448 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
449 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
451 mk_inst_ty (tyvar, result_inst_ty)
452 | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
453 | otherwise = newTyVarTy mkBoxedTypeKind -- Fresh type
455 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
458 -- Typecheck the expression to be updated
460 record_ty = applyTyCon tycon inst_tys
462 tcExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
465 -- Figure out the LIE we need. We have to generate some
466 -- dictionaries for the data type context, since we are going to
467 -- do some construction.
469 -- What dictionaries do we need? For the moment we assume that all
470 -- data constructors have the same context, and grab it from the first
471 -- constructor. If they have varying contexts then we'd have to
472 -- union the ones that could participate in the update.
474 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
475 inst_env = zipEqual "tcExpr:RecordUpd" tyvars result_inst_tys
477 tcInstTheta inst_env theta `thenNF_Tc` \ theta' ->
478 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
481 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
482 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
484 tcExpr (ArithSeqIn seq@(From expr)) res_ty
485 = unifyListTy res_ty `thenTc` \ elt_ty ->
486 tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
488 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
489 newMethod (ArithSeqOrigin seq)
490 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
492 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
495 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
496 = tcAddErrCtxt (arithSeqCtxt in_expr) $
497 unifyListTy res_ty `thenTc` \ elt_ty ->
498 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
499 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
500 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
501 newMethod (ArithSeqOrigin seq)
502 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
504 returnTc (ArithSeqOut (HsVar enum_from_then_id)
505 (FromThen expr1' expr2'),
506 lie1 `plusLIE` lie2 `plusLIE` lie3)
508 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
509 = tcAddErrCtxt (arithSeqCtxt in_expr) $
510 unifyListTy res_ty `thenTc` \ elt_ty ->
511 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
512 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
513 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
514 newMethod (ArithSeqOrigin seq)
515 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
517 returnTc (ArithSeqOut (HsVar enum_from_to_id)
518 (FromTo expr1' expr2'),
519 lie1 `plusLIE` lie2 `plusLIE` lie3)
521 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
522 = tcAddErrCtxt (arithSeqCtxt in_expr) $
523 unifyListTy res_ty `thenTc` \ elt_ty ->
524 tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
525 tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
526 tcExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
527 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
528 newMethod (ArithSeqOrigin seq)
529 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
531 returnTc (ArithSeqOut (HsVar eft_id)
532 (FromThenTo expr1' expr2' expr3'),
533 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
536 %************************************************************************
538 \subsection{Expressions type signatures}
540 %************************************************************************
543 tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
544 = tcSetErrCtxt (exprSigCtxt in_expr) $
545 tcHsType poly_ty `thenTc` \ sigma_sig ->
547 -- Check the tau-type part
548 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
550 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
552 unifyTauTy sig_tau' res_ty `thenTc_`
554 -- Type check the expression, *after* we've incorporated the signature
556 tcExpr expr res_ty `thenTc` \ (texpr, lie) ->
558 -- Check the type variables of the signature,
559 -- *after* typechecking the expression
560 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
562 -- Check overloading constraints
563 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
565 (mkTyVarSet sig_tyvars')
566 sig_dicts lie `thenTc_`
568 -- If everything is ok, return the stuff unchanged, except for
569 -- the effect of any substutions etc. We simply discard the
570 -- result of the tcSimplifyAndCheck, except for any default
571 -- resolution it may have done, which is recorded in the
573 returnTc (texpr, lie)
577 Typecheck expression which in most cases will be an Id.
580 tcExpr_id :: RenamedHsExpr
586 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
588 other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
589 tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
590 returnTc (id_expr', lie_id, id_ty)
593 --ToDo: move to Unify?
594 unifyListTy :: TcType s -- expected list type
595 -> TcM s (TcType s) -- list element type
597 -- ToDo: more direct way of testing if res_ty is a list type (cf. unifyFunTy)?
598 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
599 unifyTauTy (mkListTy elt_ty) res_ty `thenTc_`
601 -- This zonking makes the returned type as informative
603 zonkTcType elt_ty `thenNF_Tc` \ elt_ty' ->
607 %************************************************************************
609 \subsection{@tcApp@ typchecks an application}
611 %************************************************************************
615 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
616 -> TcType s -- Expected result type of application
617 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
620 tcApp fun args res_ty
621 = -- First type-check the function
622 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
624 tcAddErrCtxt (tooManyArgsCtxt fun) (
625 split_fun_ty fun_ty (length args)
626 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
628 -- Unify with expected result before type-checking the args
629 unifyTauTy res_ty actual_result_ty `thenTc_`
631 -- Now typecheck the args
632 mapAndUnzipTc tcArg (zipEqual "tcApp" args expected_arg_tys) `thenTc` \ (args', lie_args_s) ->
634 -- Check that the result type doesn't have any nested for-alls.
635 -- For example, a "build" on its own is no good; it must be applied to something.
636 checkTc (isTauTy actual_result_ty)
637 (lurkingRank2Err fun fun_ty) `thenTc_`
639 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
642 split_fun_ty :: TcType s -- The type of the function
643 -> Int -- Number of arguments
644 -> TcM s ([TcType s], -- Function argument types
645 TcType s) -- Function result types
647 split_fun_ty fun_ty 0
648 = returnTc ([], fun_ty)
650 split_fun_ty fun_ty n
651 = -- Expect the function to have type A->B
652 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
653 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
654 returnTc (arg_ty:arg_tys, final_res_ty)
658 tcArg :: (RenamedHsExpr, TcType s) -- Actual argument and expected arg type
659 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
661 tcArg (arg,expected_arg_ty)
662 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
663 = -- The ordinary, non-rank-2 polymorphic case
664 tcExpr arg expected_arg_ty
667 = -- Ha! The argument type of the function is a for-all type,
668 -- An example of rank-2 polymorphism.
670 -- No need to instantiate the argument type... it's must be the result
671 -- of instantiating a function involving rank-2 polymorphism, so there
672 -- isn't any danger of using the same tyvars twice
673 -- The argument type shouldn't be overloaded type (hence ASSERT)
675 -- To ensure that the forall'd type variables don't get unified with each
676 -- other or any other types, we make fresh *signature* type variables
677 -- and unify them with the tyvars.
678 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
680 (sig_theta, sig_tau) = splitRhoTy sig_rho
682 ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
684 -- Type-check the arg and unify with expected type
685 tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
687 -- Check that the arg_tyvars havn't been constrained
688 -- The interesting bit here is that we must include the free variables
689 -- of the expected arg ty. Here's an example:
690 -- runST (newVar True)
691 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
692 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
693 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
694 -- So now s' isn't unconstrained because it's linked to a.
695 -- Conclusion: include the free vars of the expected arg type in the
696 -- list of "free vars" for the signature check.
698 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
699 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
700 checkSigTyVars sig_tyvars sig_tau
703 -- Check that there's no overloading involved
704 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
705 -- but which, on simplification, don't actually need a dictionary involving
706 -- the tyvar. So we have to do a proper simplification right here.
707 tcSimplifyRank2 (mkTyVarSet sig_tyvars)
708 lie_arg `thenTc` \ (free_insts, inst_binds) ->
710 -- This HsLet binds any Insts which came out of the simplification.
711 -- It's a bit out of place here, but using AbsBind involves inventing
712 -- a couple of new names which seems worse.
713 returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
716 mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
719 %************************************************************************
721 \subsection{@tcId@ typchecks an identifier occurrence}
723 %************************************************************************
726 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
729 = -- Look up the Id and instantiate its type
730 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
733 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
735 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
736 tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
738 (tyvars, rho) = splitForAllTy inst_ty
740 instantiate_it2 (RealId id) tyvars rho
743 -- The instantiate_it loop runs round instantiating the Id.
744 -- It has to be a loop because we are now prepared to entertain
746 -- f:: forall a. Eq a => forall b. Baz b => tau
747 -- We want to instantiate this to
748 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
749 instantiate_it tc_id_occ ty
750 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
751 instantiate_it2 tc_id_occ tyvars rho
753 instantiate_it2 tc_id_occ tyvars rho
754 = tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
755 if null theta then -- Is it overloaded?
756 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
758 -- Yes, it's overloaded
759 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
760 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
761 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
762 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
765 arg_tys = mkTyVarTys tyvars
768 %************************************************************************
770 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
772 %************************************************************************
775 tcDoStmts do_or_lc stmts src_loc res_ty
776 = -- get the Monad and MonadZero classes
777 -- create type consisting of a fresh monad tyvar
778 ASSERT( not (null stmts) )
779 tcAddSrcLoc src_loc $
780 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
783 tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
784 tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
787 combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
788 combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
789 combine_stmts stmt _ ([], _) = panic "Bad last stmt tcDoStmts"
790 combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
792 tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
793 unifyTauTy result_ty res_ty `thenTc_`
795 -- Build the then and zero methods in case we need them
796 -- It's important that "then" and "return" appear just once in the final LIE,
797 -- not only for typechecker efficiency, but also because otherwise during
798 -- simplification we end up with silly stuff like
799 -- then = case d of (t,r) -> t
801 -- where the second "then" sees that it already exists in the "available" stuff.
803 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
804 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
805 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
807 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
809 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
811 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
813 monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
814 perhaps_zero_lie | all failure_free stmts' = emptyLIE
815 | otherwise = zero_lie
817 failure_free (BindStmt pat _ _) = failureFreePat pat
818 failure_free (GuardStmt _ _) = False
819 failure_free other_stmt = True
821 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
822 final_lie `plusLIE` monad_lie)
827 tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s)) -- This is tcExpr
828 -- The sole, disgusting, reason for this parameter
829 -- is to get the effect of polymorphic recursion
830 -- ToDo: rm when booting with Haskell 1.3
832 -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
833 -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
835 -> TcM s (thing, LIE s)
836 -> TcM s (thing, LIE s)
838 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
839 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
840 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
841 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
842 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
843 returnTc (ReturnStmt exp', exp_lie, m exp_ty)
844 ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
845 do_next `thenTc` \ (thing', thing_lie) ->
846 returnTc (combine stmt' (Just stmt_ty) thing',
847 stmt_lie `plusLIE` thing_lie)
849 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
850 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
851 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
852 tcAddSrcLoc src_loc (
853 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
854 tc_expr exp boolTy `thenTc` \ (exp', exp_lie) ->
855 returnTc (GuardStmt exp' src_loc, exp_lie)
856 )) `thenTc` \ (stmt', stmt_lie) ->
857 do_next `thenTc` \ (thing', thing_lie) ->
858 returnTc (combine stmt' Nothing thing',
859 stmt_lie `plusLIE` thing_lie)
861 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
862 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
863 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
864 tcAddSrcLoc src_loc (
865 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
866 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
868 -- exp has type (m tau) for some tau (doesn't matter what)
871 tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
872 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
873 )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
874 do_next `thenTc` \ (thing', thing_lie) ->
875 returnTc (combine stmt' (Just stmt_ty) thing',
876 stmt_lie `plusLIE` thing_lie)
878 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
879 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
880 tcAddSrcLoc src_loc (
881 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
882 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
883 tc_expr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
885 -- NB: the environment has been extended with the new binders
886 -- which the rhs can't "see", but the renamer should have made
887 -- sure that everything is distinct by now, so there's no problem.
888 -- Putting the tcExpr before the newMonoIds messes up the nesting
889 -- of error contexts, so I didn't bother
891 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
892 )) `thenTc` \ (stmt', stmt_lie) ->
893 do_next `thenTc` \ (thing', thing_lie) ->
894 returnTc (combine stmt' Nothing thing',
895 stmt_lie `plusLIE` thing_lie)
897 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
898 = tcBindsAndThen -- No error context, but a binding group is
899 combine' -- rather a large thing for an error context anyway
903 combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
906 %************************************************************************
908 \subsection{Record bindings}
910 %************************************************************************
912 Game plan for record bindings
913 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
916 1. look up "field", to find its selector Id, which must have type
917 forall a1..an. T a1 .. an -> tau
918 where tau is the type of the field.
920 2. Instantiate this type
922 3. Unify the (T a1 .. an) part with the "expected result type", which
923 is passed in. This checks that all the field labels come from the
926 4. Type check the value using tcArg, passing tau as the expected
929 This extends OK when the field types are universally quantified.
931 Actually, to save excessive creation of fresh type variables,
936 :: TcType s -- Expected type of whole record
937 -> RenamedRecordBinds
938 -> TcM s (TcRecordBinds s, LIE s)
940 tcRecordBinds expected_record_ty rbinds
941 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
942 returnTc (rbinds', plusLIEs lies)
944 do_bind (field_label, rhs, pun_flag)
945 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
946 ASSERT( isRecordSelector sel_id )
947 -- This lookup and assertion will surely succeed, because
948 -- we check that the fields are indeed record selectors
949 -- before calling tcRecordBinds
951 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
953 -- Record selectors all have type
954 -- forall a1..an. T a1 .. an -> tau
955 ASSERT( maybeToBool (getFunTy_maybe tau) )
957 -- Selector must have type RecordType -> FieldType
958 Just (record_ty, field_ty) = getFunTy_maybe tau
960 unifyTauTy expected_record_ty record_ty `thenTc_`
961 tcArg (rhs, field_ty) `thenTc` \ (rhs', lie) ->
962 returnTc ((RealId sel_id, rhs', pun_flag), lie)
964 badFields rbinds data_con
965 = [field_name | (field_name, _, _) <- rbinds,
966 not (field_name `elem` field_names)
969 field_names = map fieldLabelName (dataConFieldLabels data_con)
972 %************************************************************************
974 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
976 %************************************************************************
979 tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
981 tcExprs [] [] = returnTc ([], emptyLIE)
982 tcExprs (expr:exprs) (ty:tys)
983 = tcExpr expr ty `thenTc` \ (expr', lie1) ->
984 tcExprs exprs tys `thenTc` \ (exprs', lie2) ->
985 returnTc (expr':exprs', lie1 `plusLIE` lie2)
989 % =================================================
996 pp_nest_hang :: String -> Doc -> Doc
997 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
1000 Boring and alphabetical:
1002 arithSeqCtxt expr sty
1003 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
1005 branchCtxt b1 b2 sty
1006 = sep [ptext SLIT("In the branches of a conditional:"),
1007 pp_nest_hang "`then' branch:" (ppr sty b1),
1008 pp_nest_hang "`else' branch:" (ppr sty b2)]
1011 = hang (ptext SLIT("In the case expression")) 4 (ppr sty expr)
1013 exprSigCtxt expr sty
1014 = hang (ptext SLIT("In an expression with a type signature:"))
1018 = hang (ptext SLIT("In the list element")) 4 (ppr sty expr)
1021 = hang (ptext SLIT("In the predicate expression")) 4 (ppr sty expr)
1023 sectionRAppCtxt expr sty
1024 = hang (ptext SLIT("In the right section")) 4 (ppr sty expr)
1026 sectionLAppCtxt expr sty
1027 = hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
1029 funAppCtxt fun arg_no arg sty
1030 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1031 ppr sty fun <> text ", namely"])
1034 stmtCtxt ListComp stmt sty
1035 = hang (ptext SLIT("In a list-comprehension qualifer:"))
1038 stmtCtxt DoStmt stmt sty
1039 = hang (ptext SLIT("In a do statement:"))
1042 tooManyArgsCtxt f sty
1043 = hang (ptext SLIT("Too many arguments in an application of the function"))
1046 lurkingRank2Err fun fun_ty sty
1047 = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
1048 4 (vcat [text "It is applied to too few arguments,",
1049 ptext SLIT("so that the result type has for-alls in it")])
1051 rank2ArgCtxt arg expected_arg_ty sty
1052 = hang (ptext SLIT("In a polymorphic function argument:"))
1053 4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
1054 ppr sty expected_arg_ty])
1056 badFieldsUpd rbinds sty
1057 = hang (ptext SLIT("No constructor has all these fields:"))
1058 4 (interpp'SP sty fields)
1060 fields = [field | (field, _, _) <- rbinds]
1062 recordUpdCtxt sty = ptext SLIT("In a record update construct")
1064 badFieldsCon con fields sty
1065 = hsep [ptext SLIT("Constructor"), ppr sty con,
1066 ptext SLIT("does not have field(s)"), interpp'SP sty fields]
1068 notSelector field sty
1069 = hsep [ppr sty field, ptext SLIT("is not a record selector")]