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 TcIdOcc(..), 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, tcMatch )
38 import TcMonoType ( tcHsType )
39 import TcPat ( tcPat )
40 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
41 import TcType ( 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), classSig )
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 -> TcM s (TcExpr s, LIE s, TcType s)
87 %************************************************************************
89 \subsection{The TAUT rules for variables}
91 %************************************************************************
95 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
97 -- Check that the result type doesn't have any nested for-alls.
98 -- For example, a "build" on its own is no good; it must be
99 -- applied to something.
100 checkTc (isTauTy res_ty)
101 (lurkingRank2Err name res_ty) `thenTc_`
103 returnTc (expr', lie, res_ty)
106 %************************************************************************
108 \subsection{Literals}
110 %************************************************************************
115 tcExpr (HsLit (HsInt i))
116 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
118 newOverloadedLit (LiteralOrigin (HsInt i))
119 (OverloadedIntegral i)
120 ty `thenNF_Tc` \ (lie, over_lit_id) ->
122 returnTc (HsVar over_lit_id, lie, ty)
124 tcExpr (HsLit (HsFrac f))
125 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
127 newOverloadedLit (LiteralOrigin (HsFrac f))
128 (OverloadedFractional f)
129 ty `thenNF_Tc` \ (lie, over_lit_id) ->
131 returnTc (HsVar over_lit_id, lie, ty)
133 tcExpr (HsLit lit@(HsLitLit s))
134 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
135 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
136 newDicts (LitLitOrigin (_UNPK_ s))
137 [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
138 returnTc (HsLitOut lit ty, dicts, ty)
144 tcExpr (HsLit lit@(HsCharPrim c))
145 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
147 tcExpr (HsLit lit@(HsStringPrim s))
148 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
150 tcExpr (HsLit lit@(HsIntPrim i))
151 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
153 tcExpr (HsLit lit@(HsFloatPrim f))
154 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
156 tcExpr (HsLit lit@(HsDoublePrim d))
157 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
160 Unoverloaded literals:
163 tcExpr (HsLit lit@(HsChar c))
164 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
166 tcExpr (HsLit lit@(HsString str))
167 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
170 %************************************************************************
172 \subsection{Other expression forms}
174 %************************************************************************
177 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
180 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
183 = tcMatch match `thenTc` \ (match',lie,ty) ->
184 returnTc (HsLam match', lie, ty)
186 tcExpr (HsApp e1 e2) = accum e1 [e2]
188 accum (HsApp e1 e2) args = accum e1 (e2:args)
190 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
191 returnTc (foldl HsApp fun' args', lie, res_ty)
193 -- equivalent to (op e1) e2:
194 tcExpr (OpApp arg1 op fix arg2)
195 = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
196 returnTc (OpApp arg1' op' fix arg2', lie, res_ty)
199 Note that the operators in sections are expected to be binary, and
200 a type error will occur if they aren't.
203 -- Left sections, equivalent to
210 tcExpr in_expr@(SectionL arg op)
211 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
213 -- Check that res_ty is a function type
214 -- Without this check we barf in the desugarer on
216 -- because it tries to desugar to
217 -- f op = \r -> 3 op r
218 -- so (3 `op`) had better be a function!
219 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
220 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
221 tcAddErrCtxt (sectionLAppCtxt in_expr) $
222 unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
224 returnTc (SectionL arg' op', lie, res_ty)
226 -- Right sections, equivalent to \ x -> x op expr, or
229 tcExpr in_expr@(SectionR op expr)
230 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
231 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
233 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
234 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
235 tcAddErrCtxt (sectionRAppCtxt in_expr) $
236 unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty `thenTc_`
238 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
241 The interesting thing about @ccall@ is that it is just a template
242 which we instantiate by filling in details about the types of its
243 argument and result (ie minimal typechecking is performed). So, the
244 basic story is that we allocate a load of type variables (to hold the
245 arg/result types); unify them with the args/result; and store them for
249 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
250 = -- Get the callable and returnable classes.
251 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
252 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
255 new_arg_dict (arg, arg_ty)
256 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
257 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
258 returnNF_Tc arg_dicts -- Actually a singleton bag
260 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
264 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
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 ->
271 -- Construct the extra insts, which encode the
272 -- constraints on the argument and result types.
273 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
274 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
276 returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
277 (CCall lbl args' may_gc is_asm result_ty),
278 -- do the wrapping in the newtype constructor here
279 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
280 mkPrimIoTy result_ty)
284 tcExpr (HsSCC label expr)
285 = tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
286 -- No unification. Give SCC the type of expr
287 returnTc (HsSCC label expr', lie, expr_ty)
289 tcExpr (HsLet binds expr)
292 binds -- Bindings to check
293 (tc_expr expr) `thenTc` \ ((expr', ty), lie) ->
294 returnTc (expr', lie, ty)
296 tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
297 returnTc ((expr',ty), lie)
298 combiner bind (expr, ty) = (HsLet bind expr, ty)
300 tcExpr in_expr@(HsCase expr matches src_loc)
301 = tcAddSrcLoc src_loc $
302 tcExpr expr `thenTc` \ (expr',lie1,expr_ty) ->
303 newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
305 tcAddErrCtxt (caseCtxt in_expr) $
306 tcMatchesCase (mkFunTy expr_ty result_ty) matches
307 `thenTc` \ (matches',lie2) ->
309 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
311 tcExpr (HsIf pred b1 b2 src_loc)
312 = tcAddSrcLoc src_loc $
313 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
315 tcAddErrCtxt (predCtxt pred) (
316 unifyTauTy boolTy predTy
319 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
320 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
322 tcAddErrCtxt (branchCtxt b1 b2) $
323 unifyTauTy result_ty b2Ty `thenTc_`
325 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
329 tcExpr expr@(HsDo do_or_lc stmts src_loc)
330 = tcDoStmts do_or_lc stmts src_loc
334 tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
335 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
336 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
337 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies, mkListTy elt_ty)
340 = tcAddErrCtxt (listCtxt expr) $
341 tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
342 unifyTauTy elt_ty expr_ty `thenTc_`
343 returnTc (expr', lie)
345 tcExpr (ExplicitTuple exprs)
346 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
347 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
349 tcExpr (RecordCon (HsVar con) rbinds)
350 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
352 (_, record_ty) = splitFunTy con_tau
354 -- Con is syntactically constrained to be a data constructor
355 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
357 -- Check that the record bindings match the constructor
358 tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
360 bad_fields = badFields rbinds con_id
362 checkTc (null bad_fields) (badFieldsCon con bad_fields) `thenTc_`
364 -- Typecheck the record bindings
365 -- (Do this after checkRecordFields in case there's a field that
366 -- doesn't match the constructor.)
367 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
369 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
372 -- The main complication with RecordUpd is that we need to explicitly
373 -- handle the *non-updated* fields. Consider:
375 -- data T a b = MkT1 { fa :: a, fb :: b }
376 -- | MkT2 { fa :: a, fc :: Int -> Int }
377 -- | MkT3 { fd :: a }
379 -- upd :: T a b -> c -> T a c
380 -- upd t x = t { fb = x}
382 -- The type signature on upd is correct (i.e. the result should not be (T a b))
383 -- because upd should be equivalent to:
385 -- upd t x = case t of
386 -- MkT1 p q -> MkT1 p x
387 -- MkT2 a b -> MkT2 p b
388 -- MkT3 d -> error ...
390 -- So we need to give a completely fresh type to the result record,
391 -- and then constrain it by the fields that are *not* updated ("p" above).
393 -- Note that because MkT3 doesn't contain all the fields being updated,
394 -- its RHS is simply an error, so it doesn't impose any type constraints
396 -- All this is done in STEP 4 below.
398 tcExpr (RecordUpd record_expr rbinds)
399 = tcAddErrCtxt recordUpdCtxt $
402 -- Figure out the tycon and data cons from the first field name
403 ASSERT( not (null rbinds) )
405 ((first_field_name, _, _) : rest) = rbinds
407 tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
408 (case maybe_sel_id of
409 Just sel_id | isRecordSelector sel_id -> returnTc sel_id
410 other -> failTc (notSelector first_field_name)
411 ) `thenTc` \ sel_id ->
413 (_, tau) = splitForAllTy (idType sel_id)
414 Just (data_ty, _) = getFunTy_maybe tau -- Must succeed since sel_id is a selector
415 (tycon, _, data_cons) = getAppDataTyCon data_ty
416 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
418 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, result_inst_env) ->
421 -- Check for bad fields
422 checkTc (any (null . badFields rbinds) data_cons)
423 (badFieldsUpd rbinds) `thenTc_`
425 -- Typecheck the update bindings.
426 -- (Do this after checking for bad fields in case there's a field that
427 -- doesn't match the constructor.)
429 result_record_ty = applyTyCon tycon result_inst_tys
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
459 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
460 unifyTauTy (applyTyCon tycon inst_tys) record_ty `thenTc_`
464 -- Figure out the LIE we need. We have to generate some
465 -- dictionaries for the data type context, since we are going to
466 -- do some construction.
468 -- What dictionaries do we need? For the moment we assume that all
469 -- data constructors have the same context, and grab it from the first
470 -- constructor. If they have varying contexts then we'd have to
471 -- union the ones that could participate in the update.
473 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
474 inst_env = zipEqual "tcExpr:RecordUpd" tyvars result_inst_tys
476 tcInstTheta inst_env theta `thenNF_Tc` \ theta' ->
477 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
480 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
481 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
485 tcExpr (ArithSeqIn seq@(From expr))
486 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
488 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
489 newMethod (ArithSeqOrigin seq)
490 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
492 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
496 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
497 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
498 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
500 tcAddErrCtxt (arithSeqCtxt in_expr) $
501 unifyTauTyList [ty1, ty2] `thenTc_`
503 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
504 newMethod (ArithSeqOrigin seq)
505 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
507 returnTc (ArithSeqOut (HsVar enum_from_then_id)
508 (FromThen expr1' expr2'),
509 lie1 `plusLIE` lie2 `plusLIE` lie3,
512 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
513 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
514 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
516 tcAddErrCtxt (arithSeqCtxt in_expr) $
517 unifyTauTyList [ty1,ty2] `thenTc_`
519 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
520 newMethod (ArithSeqOrigin seq)
521 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
523 returnTc (ArithSeqOut (HsVar enum_from_to_id)
524 (FromTo expr1' expr2'),
525 lie1 `plusLIE` lie2 `plusLIE` lie3,
528 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
529 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
530 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
531 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
533 tcAddErrCtxt (arithSeqCtxt in_expr) $
534 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
536 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
537 newMethod (ArithSeqOrigin seq)
538 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
540 returnTc (ArithSeqOut (HsVar eft_id)
541 (FromThenTo expr1' expr2' expr3'),
542 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
546 %************************************************************************
548 \subsection{Expressions type signatures}
550 %************************************************************************
553 tcExpr in_expr@(ExprWithTySig expr poly_ty)
554 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
555 tcHsType poly_ty `thenTc` \ sigma_sig ->
557 -- Check the tau-type part
558 tcSetErrCtxt (exprSigCtxt in_expr) $
559 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
561 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
563 unifyTauTy sig_tau' tau_ty `thenTc_`
565 -- Check the type variables of the signature
566 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
568 -- Check overloading constraints
569 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
571 (mkTyVarSet sig_tyvars')
572 sig_dicts lie `thenTc_`
574 -- If everything is ok, return the stuff unchanged, except for
575 -- the effect of any substutions etc. We simply discard the
576 -- result of the tcSimplifyAndCheck, except for any default
577 -- resolution it may have done, which is recorded in the
579 returnTc (texpr, lie, tau_ty)
582 %************************************************************************
584 \subsection{@tcApp@ typchecks an application}
586 %************************************************************************
589 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
590 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
592 TcType s) -- Type of the application
595 = -- First type-check the function
596 -- In the HsVar case we go straight to tcId to avoid hitting the
597 -- rank-2 check, which we check later here anyway
599 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
601 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
603 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
605 -- Check that the result type doesn't have any nested for-alls.
606 -- For example, a "build" on its own is no good; it must be applied to something.
607 checkTc (isTauTy res_ty)
608 (lurkingRank2Err fun fun_ty) `thenTc_`
610 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
613 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
614 -> TcType s -- The type of the function
615 -> [RenamedHsExpr] -- Arguments
616 -> TcM s ([TcExpr s], -- Typechecked args
618 TcType s) -- Result type of the application
620 tcApp_help orig_fun arg_no fun_ty []
621 = returnTc ([], emptyLIE, fun_ty)
623 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
624 = -- Expect the function to have type A->B
625 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
627 ) `thenTc` \ (expected_arg_ty, result_ty) ->
629 -- Type check the argument
630 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
631 tcArg expected_arg_ty arg
632 ) `thenTc` \ (arg', lie_arg) ->
635 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
638 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
643 tcArg :: TcType s -- Expected arg type
644 -> RenamedHsExpr -- Actual argument
645 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
647 tcArg expected_arg_ty arg
648 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
649 = -- The ordinary, non-rank-2 polymorphic case
650 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
651 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
652 returnTc (arg', lie_arg)
655 = -- Ha! The argument type of the function is a for-all type,
656 -- An example of rank-2 polymorphism.
658 -- No need to instantiate the argument type... it's must be the result
659 -- of instantiating a function involving rank-2 polymorphism, so there
660 -- isn't any danger of using the same tyvars twice
661 -- The argument type shouldn't be overloaded type (hence ASSERT)
663 -- To ensure that the forall'd type variables don't get unified with each
664 -- other or any other types, we make fresh *signature* type variables
665 -- and unify them with the tyvars.
666 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
668 (sig_theta, sig_tau) = splitRhoTy sig_rho
670 ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
672 -- Type-check the arg and unify with expected type
673 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
674 unifyTauTy sig_tau actual_arg_ty `thenTc_`
676 -- Check that the arg_tyvars havn't been constrained
677 -- The interesting bit here is that we must include the free variables
678 -- of the expected arg ty. Here's an example:
679 -- runST (newVar True)
680 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
681 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
682 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
683 -- So now s' isn't unconstrained because it's linked to a.
684 -- Conclusion: include the free vars of the expected arg type in the
685 -- list of "free vars" for the signature check.
687 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
688 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
689 checkSigTyVars sig_tyvars sig_tau
692 -- Check that there's no overloading involved
693 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
694 -- but which, on simplification, don't actually need a dictionary involving
695 -- the tyvar. So we have to do a proper simplification right here.
696 tcSimplifyRank2 (mkTyVarSet sig_tyvars)
697 lie_arg `thenTc` \ (free_insts, inst_binds) ->
699 -- This HsLet binds any Insts which came out of the simplification.
700 -- It's a bit out of place here, but using AbsBind involves inventing
701 -- a couple of new names which seems worse.
702 returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
705 mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
708 %************************************************************************
710 \subsection{@tcId@ typchecks an identifier occurrence}
712 %************************************************************************
715 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
718 = -- Look up the Id and instantiate its type
719 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
722 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
724 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
725 tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
727 (tyvars, rho) = splitForAllTy inst_ty
729 instantiate_it2 (RealId id) tyvars rho
732 -- The instantiate_it loop runs round instantiating the Id.
733 -- It has to be a loop because we are now prepared to entertain
735 -- f:: forall a. Eq a => forall b. Baz b => tau
736 -- We want to instantiate this to
737 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
738 instantiate_it tc_id_occ ty
739 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
740 instantiate_it2 tc_id_occ tyvars rho
742 instantiate_it2 tc_id_occ tyvars rho
743 = tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
744 if null theta then -- Is it overloaded?
745 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
747 -- Yes, it's overloaded
748 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
749 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
750 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
751 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
754 arg_tys = mkTyVarTys tyvars
757 %************************************************************************
759 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
761 %************************************************************************
764 tcDoStmts do_or_lc stmts src_loc
765 = -- get the Monad and MonadZero classes
766 -- create type consisting of a fresh monad tyvar
767 ASSERT( not (null stmts) )
768 tcAddSrcLoc src_loc $
769 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
772 tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
773 tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
776 combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
777 combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
778 combine_stmts stmt _ ([], _) = panic "Bad last stmt tcDoStmts"
779 combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
781 tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
783 -- Build the then and zero methods in case we need them
784 -- It's important that "then" and "return" appear just once in the final LIE,
785 -- not only for typechecker efficiency, but also because otherwise during
786 -- simplification we end up with silly stuff like
787 -- then = case d of (t,r) -> t
789 -- where the second "then" sees that it already exists in the "available" stuff.
791 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
792 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
793 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
795 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
797 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
799 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
801 monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
802 perhaps_zero_lie | all failure_free stmts' = emptyLIE
803 | otherwise = zero_lie
805 failure_free (BindStmt pat _ _) = failureFreePat pat
806 failure_free (GuardStmt _ _) = False
807 failure_free other_stmt = True
809 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc,
810 final_lie `plusLIE` monad_lie,
815 tcStmt :: (RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)) -- This is tcExpr
816 -- The sole, disgusting, reason for this parameter
817 -- is to get the effect of polymorphic recursion
818 -- ToDo: rm when booting with Haskell 1.3
820 -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
821 -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
823 -> TcM s (thing, LIE s)
824 -> TcM s (thing, LIE s)
826 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
827 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
828 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
829 tc_expr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
830 returnTc (ReturnStmt exp', exp_lie, m exp_ty)
831 ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
832 do_next `thenTc` \ (thing', thing_lie) ->
833 returnTc (combine stmt' (Just stmt_ty) thing',
834 stmt_lie `plusLIE` thing_lie)
836 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
837 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
838 tcAddSrcLoc src_loc (
839 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
840 tc_expr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
841 unifyTauTy boolTy exp_ty `thenTc_`
842 returnTc (GuardStmt exp' src_loc, exp_lie)
843 )) `thenTc` \ (stmt', stmt_lie) ->
844 do_next `thenTc` \ (thing', thing_lie) ->
845 returnTc (combine stmt' Nothing thing',
846 stmt_lie `plusLIE` thing_lie)
848 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
849 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
850 tcAddSrcLoc src_loc (
851 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
852 tc_expr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
853 -- Check that exp has type (m tau) for some tau (doesn't matter what)
854 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
855 unifyTauTy (m tau) exp_ty `thenTc_`
856 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
857 )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
858 do_next `thenTc` \ (thing', thing_lie) ->
859 returnTc (combine stmt' (Just stmt_ty) thing',
860 stmt_lie `plusLIE` thing_lie)
862 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
863 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
864 tcAddSrcLoc src_loc (
865 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
866 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
867 tc_expr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
868 unifyTauTy (m pat_ty) exp_ty `thenTc_`
870 -- NB: the environment has been extended with the new binders
871 -- which the rhs can't "see", but the renamer should have made
872 -- sure that everything is distinct by now, so there's no problem.
873 -- Putting the tcExpr before the newMonoIds messes up the nesting
874 -- of error contexts, so I didn't bother
876 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
877 )) `thenTc` \ (stmt', stmt_lie) ->
878 do_next `thenTc` \ (thing', thing_lie) ->
879 returnTc (combine stmt' Nothing thing',
880 stmt_lie `plusLIE` thing_lie)
882 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
883 = tcBindsAndThen -- No error context, but a binding group is
884 combine' -- rather a large thing for an error context anyway
888 combine' binds' thing' = combine (LetStmt binds') Nothing thing'
891 %************************************************************************
893 \subsection{Record bindings}
895 %************************************************************************
897 Game plan for record bindings
898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
901 1. look up "field", to find its selector Id, which must have type
902 forall a1..an. T a1 .. an -> tau
903 where tau is the type of the field.
905 2. Instantiate this type
907 3. Unify the (T a1 .. an) part with the "expected result type", which
908 is passed in. This checks that all the field labels come from the
911 4. Type check the value using tcArg, passing tau as the expected
914 This extends OK when the field types are universally quantified.
916 Actually, to save excessive creation of fresh type variables,
921 :: TcType s -- Expected type of whole record
922 -> RenamedRecordBinds
923 -> TcM s (TcRecordBinds s, LIE s)
925 tcRecordBinds expected_record_ty rbinds
926 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
927 returnTc (rbinds', plusLIEs lies)
929 do_bind (field_label, rhs, pun_flag)
930 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
931 ASSERT( isRecordSelector sel_id )
932 -- This lookup and assertion will surely succeed, because
933 -- we check that the fields are indeed record selectors
934 -- before calling tcRecordBinds
936 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
938 -- Record selectors all have type
939 -- forall a1..an. T a1 .. an -> tau
940 ASSERT( maybeToBool (getFunTy_maybe tau) )
942 -- Selector must have type RecordType -> FieldType
943 Just (record_ty, field_ty) = getFunTy_maybe tau
945 unifyTauTy expected_record_ty record_ty `thenTc_`
946 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
947 returnTc ((RealId sel_id, rhs', pun_flag), lie)
949 badFields rbinds data_con
950 = [field_name | (field_name, _, _) <- rbinds,
951 not (field_name `elem` field_names)
954 field_names = map fieldLabelName (dataConFieldLabels data_con)
957 %************************************************************************
959 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
961 %************************************************************************
964 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
966 tcExprs [] = returnTc ([], emptyLIE, [])
968 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
969 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
970 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
974 % =================================================
981 pp_nest_hang :: String -> Doc -> Doc
982 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
985 Boring and alphabetical:
987 arithSeqCtxt expr sty
988 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
991 = sep [ptext SLIT("In the branches of a conditional:"),
992 pp_nest_hang "`then' branch:" (ppr sty b1),
993 pp_nest_hang "`else' branch:" (ppr sty b2)]
996 = hang (ptext SLIT("In the case expression")) 4 (ppr sty expr)
999 = hang (ptext SLIT("In an expression with a type signature:"))
1003 = hang (ptext SLIT("In the list element")) 4 (ppr sty expr)
1006 = hang (ptext SLIT("In the predicate expression")) 4 (ppr sty expr)
1008 sectionRAppCtxt expr sty
1009 = hang (ptext SLIT("In the right section")) 4 (ppr sty expr)
1011 sectionLAppCtxt expr sty
1012 = hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
1014 funAppCtxt fun arg_no arg sty
1015 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1016 ppr sty fun <> text ", namely"])
1019 stmtCtxt ListComp stmt sty
1020 = hang (ptext SLIT("In a list-comprehension qualifer:"))
1023 stmtCtxt DoStmt stmt sty
1024 = hang (ptext SLIT("In a do statement:"))
1027 tooManyArgsCtxt f sty
1028 = hang (ptext SLIT("Too many arguments in an application of the function"))
1031 lurkingRank2Err fun fun_ty sty
1032 = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
1033 4 (vcat [text "It is applied to too few arguments,",
1034 ptext SLIT("so that the result type has for-alls in it")])
1036 rank2ArgCtxt arg expected_arg_ty sty
1037 = hang (ptext SLIT("In a polymorphic function argument:"))
1038 4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
1039 ppr sty expected_arg_ty])
1041 badFieldsUpd rbinds sty
1042 = hang (ptext SLIT("No constructor has all these fields:"))
1043 4 (interpp'SP sty fields)
1045 fields = [field | (field, _, _) <- rbinds]
1047 recordUpdCtxt sty = ptext SLIT("In a record update construct")
1049 badFieldsCon con fields sty
1050 = hsep [ptext SLIT("Constructor"), ppr sty con,
1051 ptext SLIT("does not have field(s)"), interpp'SP sty fields]
1053 notSelector field sty
1054 = hsep [ppr sty field, ptext SLIT("is not a record selector")]