2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcExpr]{Typecheck an expression}
7 module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
12 HsBinds(..), Stmt(..), StmtCtxt(..)
14 import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
15 import TcHsSyn ( TcExpr, TcRecordBinds,
16 mkHsTyApp, maybeBoxedPrimType
20 import BasicTypes ( RecFlag(..) )
22 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
23 LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
24 newMethod, newMethodWithGivenTy, newDicts, instToId )
25 import TcBinds ( tcBindsAndThen )
26 import TcEnv ( tcInstId,
27 tcLookupValue, tcLookupClassByKey,
29 tcExtendGlobalTyVars, tcLookupValueMaybe,
30 tcLookupTyCon, tcLookupDataCon
32 import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
33 import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
34 import TcPat ( badFieldCon )
35 import TcSimplify ( tcSimplifyAndCheck )
36 import TcType ( TcType, TcTauType,
38 tcInstTcType, tcSplitRhoTy,
39 newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
41 import Class ( Class )
42 import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
43 import Id ( idType, recordSelectorFieldLabel,
47 import DataCon ( dataConFieldLabels, dataConSig, dataConId )
49 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
50 splitFunTy_maybe, splitFunTys,
52 splitForAllTys, splitRhoTy,
53 isTauTy, tyVarsOfType, tyVarsOfTypes,
54 isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
55 boxedTypeKind, mkArrowKind,
56 substTopTheta, tidyOpenType
58 import VarEnv ( zipVarEnv )
59 import VarSet ( elemVarSet, mkVarSet )
60 import TyCon ( tyConDataCons )
61 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
62 floatPrimTy, addrPrimTy
64 import TysWiredIn ( boolTy, charTy, stringTy )
65 import PrelInfo ( ioTyCon_NAME )
66 import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
68 import Unique ( cCallableClassKey, cReturnableClassKey,
69 enumFromClassOpKey, enumFromThenClassOpKey,
70 enumFromToClassOpKey, enumFromThenToClassOpKey,
71 thenMClassOpKey, failMClassOpKey, returnMClassOpKey
74 import Maybes ( maybeToBool )
75 import ListSetOps ( minusList )
79 %************************************************************************
81 \subsection{Main wrappers}
83 %************************************************************************
86 tcExpr :: RenamedHsExpr -- Expession to type check
87 -> TcType -- Expected type (could be a polytpye)
88 -> TcM s (TcExpr, LIE)
90 tcExpr expr ty | isForAllTy ty = -- Polymorphic case
91 tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
94 | otherwise = -- Monomorphic case
99 %************************************************************************
101 \subsection{@tcPolyExpr@ typchecks an application}
103 %************************************************************************
106 -- tcPolyExpr is like tcMonoExpr, except that the expected type
107 -- can be a polymorphic one.
108 tcPolyExpr :: RenamedHsExpr
109 -> TcType -- Expected type
110 -> TcM s (TcExpr, LIE, -- Generalised expr with expected type, and LIE
111 TcExpr, TcTauType, LIE) -- Same thing, but instantiated; tau-type returned
113 tcPolyExpr arg expected_arg_ty
114 = -- Ha! The argument type of the function is a for-all type,
115 -- An example of rank-2 polymorphism.
117 -- To ensure that the forall'd type variables don't get unified with each
118 -- other or any other types, we make fresh copy of the alleged type
119 tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
121 (sig_theta, sig_tau) = splitRhoTy sig_rho
123 -- Type-check the arg and unify with expected type
124 tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
126 -- Check that the sig_tyvars havn't been constrained
127 -- The interesting bit here is that we must include the free variables
128 -- of the expected arg ty. Here's an example:
129 -- runST (newVar True)
130 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
131 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
132 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
133 -- So now s' isn't unconstrained because it's linked to a.
134 -- Conclusion: include the free vars of the expected arg type in the
135 -- list of "free vars" for the signature check.
137 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
138 tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $
140 checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
142 newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
143 -- ToDo: better origin
146 (mkVarSet zonked_sig_tyvars)
147 sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
150 -- This HsLet binds any Insts which came out of the simplification.
151 -- It's a bit out of place here, but using AbsBind involves inventing
152 -- a couple of new names which seems worse.
153 generalised_arg = TyLam zonked_sig_tyvars $
155 HsLet (MonoBind inst_binds [] Recursive)
158 returnTc ( generalised_arg, free_insts,
159 arg', sig_tau, lie_arg )
161 sig_msg ty = ptext SLIT("In an expression with expected type:") <+> ppr ty
164 %************************************************************************
166 \subsection{The TAUT rules for variables}
168 %************************************************************************
171 tcMonoExpr :: RenamedHsExpr -- Expession to type check
172 -> TcTauType -- Expected type (could be a type variable)
173 -> TcM s (TcExpr, LIE)
175 tcMonoExpr (HsVar name) res_ty
176 = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
177 unifyTauTy res_ty id_ty `thenTc_`
179 -- Check that the result type doesn't have any nested for-alls.
180 -- For example, a "build" on its own is no good; it must be
181 -- applied to something.
182 checkTc (isTauTy id_ty)
183 (lurkingRank2Err name id_ty) `thenTc_`
185 returnTc (expr', lie)
188 %************************************************************************
190 \subsection{Literals}
192 %************************************************************************
197 tcMonoExpr (HsLit (HsInt i)) res_ty
198 = newOverloadedLit (LiteralOrigin (HsInt i))
199 (OverloadedIntegral i)
200 res_ty `thenNF_Tc` \ stuff ->
203 tcMonoExpr (HsLit (HsFrac f)) res_ty
204 = newOverloadedLit (LiteralOrigin (HsFrac f))
205 (OverloadedFractional f)
206 res_ty `thenNF_Tc` \ stuff ->
210 tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
211 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
212 newDicts (LitLitOrigin (_UNPK_ s))
213 [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
214 returnTc (HsLitOut lit res_ty, dicts)
220 tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty
221 = unifyTauTy res_ty charPrimTy `thenTc_`
222 returnTc (HsLitOut lit charPrimTy, emptyLIE)
224 tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty
225 = unifyTauTy res_ty addrPrimTy `thenTc_`
226 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
228 tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty
229 = unifyTauTy res_ty intPrimTy `thenTc_`
230 returnTc (HsLitOut lit intPrimTy, emptyLIE)
232 tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty
233 = unifyTauTy res_ty floatPrimTy `thenTc_`
234 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
236 tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty
237 = unifyTauTy res_ty doublePrimTy `thenTc_`
238 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
241 Unoverloaded literals:
244 tcMonoExpr (HsLit lit@(HsChar c)) res_ty
245 = unifyTauTy res_ty charTy `thenTc_`
246 returnTc (HsLitOut lit charTy, emptyLIE)
248 tcMonoExpr (HsLit lit@(HsString str)) res_ty
249 = unifyTauTy res_ty stringTy `thenTc_`
250 returnTc (HsLitOut lit stringTy, emptyLIE)
253 %************************************************************************
255 \subsection{Other expression forms}
257 %************************************************************************
260 tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
261 = tcMonoExpr expr res_ty
263 -- perform the negate *before* overloading the integer, since the case
264 -- of minBound on Ints fails otherwise. Could be done elsewhere, but
265 -- convenient to do it here.
267 tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty
268 = tcMonoExpr (HsLit (HsInt (-i))) res_ty
270 tcMonoExpr (NegApp expr neg) res_ty
271 = tcMonoExpr (HsApp neg expr) res_ty
273 tcMonoExpr (HsLam match) res_ty
274 = tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
275 returnTc (HsLam match', lie)
277 tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
279 accum (HsApp e1 e2) args = accum e1 (e2:args)
281 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
282 returnTc (foldl HsApp fun' args', lie)
284 -- equivalent to (op e1) e2:
285 tcMonoExpr (OpApp arg1 op fix arg2) res_ty
286 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
287 returnTc (OpApp arg1' op' fix arg2', lie)
290 Note that the operators in sections are expected to be binary, and
291 a type error will occur if they aren't.
294 -- Left sections, equivalent to
301 tcMonoExpr in_expr@(SectionL arg op) res_ty
302 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
304 -- Check that res_ty is a function type
305 -- Without this check we barf in the desugarer on
307 -- because it tries to desugar to
308 -- f op = \r -> 3 op r
309 -- so (3 `op`) had better be a function!
310 tcAddErrCtxt (sectionLAppCtxt in_expr) $
311 unifyFunTy res_ty `thenTc_`
313 returnTc (SectionL arg' op', lie)
315 -- Right sections, equivalent to \ x -> x op expr, or
318 tcMonoExpr in_expr@(SectionR op expr) res_ty
319 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
320 tcAddErrCtxt (sectionRAppCtxt in_expr) $
321 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
322 tcMonoExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
323 unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
324 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
327 The interesting thing about @ccall@ is that it is just a template
328 which we instantiate by filling in details about the types of its
329 argument and result (ie minimal typechecking is performed). So, the
330 basic story is that we allocate a load of type variables (to hold the
331 arg/result types); unify them with the args/result; and store them for
335 tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
336 = -- Get the callable and returnable classes.
337 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
338 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
339 tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
341 new_arg_dict (arg, arg_ty)
342 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
343 [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
344 returnNF_Tc arg_dicts -- Actually a singleton bag
346 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
350 mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..(length args)] `thenNF_Tc` \ arg_tys ->
351 tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
353 -- The argument types can be unboxed or boxed; the result
354 -- type must, however, be boxed since it's an argument to the IO
356 newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
358 io_result_ty = mkTyConApp ioTyCon [result_ty]
359 [ioDataCon] = tyConDataCons ioTyCon
361 unifyTauTy res_ty io_result_ty `thenTc_`
363 -- Construct the extra insts, which encode the
364 -- constraints on the argument and result types.
365 mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
366 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
367 returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
368 (CCall lbl args' may_gc is_asm result_ty),
369 -- do the wrapping in the newtype constructor here
370 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
374 tcMonoExpr (HsSCC label expr) res_ty
375 = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
376 returnTc (HsSCC label expr', lie)
378 tcMonoExpr (HsLet binds expr) res_ty
381 binds -- Bindings to check
382 tc_expr `thenTc` \ (expr', lie) ->
383 returnTc (expr', lie)
385 tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
386 returnTc (expr', lie)
387 combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
389 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
390 = tcAddSrcLoc src_loc $
391 tcAddErrCtxt (caseCtxt in_expr) $
393 -- Typecheck the case alternatives first.
394 -- The case patterns tend to give good type info to use
395 -- when typechecking the scrutinee. For example
398 -- will report that map is applied to too few arguments
400 -- Not only that, but it's better to check the matches on their
401 -- own, so that we get the expected results for scoped type variables.
403 -- (p::a, q::b) -> (q,p)
404 -- The above should work: the match (p,q) -> (q,p) is polymorphic as
405 -- claimed by the pattern signatures. But if we typechecked the
406 -- match with x in scope and x's type as the expected type, we'd be hosed.
408 tcMatchesCase matches res_ty `thenTc` \ (scrut_ty, matches', lie2) ->
410 tcAddErrCtxt (caseScrutCtxt scrut) (
411 tcMonoExpr scrut scrut_ty
412 ) `thenTc` \ (scrut',lie1) ->
414 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
416 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
417 = tcAddSrcLoc src_loc $
418 tcAddErrCtxt (predCtxt pred) (
419 tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
421 tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) ->
422 tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) ->
423 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
427 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
428 = tcDoStmts do_or_lc stmts src_loc res_ty
432 tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
433 = unifyListTy res_ty `thenTc` \ elt_ty ->
434 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
435 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
438 = tcAddErrCtxt (listCtxt expr) $
439 tcMonoExpr expr elt_ty
441 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
443 then unifyTupleTy (length exprs) res_ty
444 else unifyUnboxedTupleTy (length exprs) res_ty
445 ) `thenTc` \ arg_tys ->
446 mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
447 (exprs `zip` arg_tys) -- we know they're of equal length.
448 `thenTc` \ (exprs', lies) ->
449 returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
451 tcMonoExpr (RecordCon con_name rbinds) res_ty
452 = tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
454 (_, record_ty) = splitFunTys con_tau
456 -- Con is syntactically constrained to be a data constructor
457 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
458 unifyTauTy res_ty record_ty `thenTc_`
460 -- Check that the record bindings match the constructor
461 tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
463 bad_fields = badFields rbinds data_con
465 if not (null bad_fields) then
466 mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
467 failTc -- Fail now, because tcRecordBinds will crash on a bad field
470 -- Typecheck the record bindings
471 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
473 returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
476 -- The main complication with RecordUpd is that we need to explicitly
477 -- handle the *non-updated* fields. Consider:
479 -- data T a b = MkT1 { fa :: a, fb :: b }
480 -- | MkT2 { fa :: a, fc :: Int -> Int }
481 -- | MkT3 { fd :: a }
483 -- upd :: T a b -> c -> T a c
484 -- upd t x = t { fb = x}
486 -- The type signature on upd is correct (i.e. the result should not be (T a b))
487 -- because upd should be equivalent to:
489 -- upd t x = case t of
490 -- MkT1 p q -> MkT1 p x
491 -- MkT2 a b -> MkT2 p b
492 -- MkT3 d -> error ...
494 -- So we need to give a completely fresh type to the result record,
495 -- and then constrain it by the fields that are *not* updated ("p" above).
497 -- Note that because MkT3 doesn't contain all the fields being updated,
498 -- its RHS is simply an error, so it doesn't impose any type constraints
500 -- All this is done in STEP 4 below.
502 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
503 = tcAddErrCtxt recordUpdCtxt $
506 -- Check that the field names are really field names
507 ASSERT( not (null rbinds) )
509 field_names = [field_name | (field_name, _, _) <- rbinds]
511 mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
513 bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
516 Just sel_id -> not (isRecordSelector sel_id)
519 mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
520 if not (null bad_guys) then
525 -- Figure out the tycon and data cons from the first field name
527 (Just sel_id : _) = maybe_sel_ids
528 (_, tau) = splitForAllTys (idType sel_id)
529 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
530 (tycon, _, data_cons) = splitAlgTyConApp data_ty
531 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
533 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
536 -- Check that at least one constructor has all the named fields
537 -- i.e. has an empty set of bad fields returned by badFields
538 checkTc (any (null . badFields rbinds) data_cons)
539 (badFieldsUpd rbinds) `thenTc_`
542 -- Typecheck the update bindings.
543 -- (Do this after checking for bad fields in case there's a field that
544 -- doesn't match the constructor.)
546 result_record_ty = mkTyConApp tycon result_inst_tys
548 unifyTauTy res_ty result_record_ty `thenTc_`
549 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
552 -- Use the un-updated fields to find a vector of booleans saying
553 -- which type arguments must be the same in updatee and result.
555 -- WARNING: this code assumes that all data_cons in a common tycon
556 -- have FieldLabels abstracted over the same tyvars.
558 upd_field_lbls = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
559 con_field_lbls_s = map dataConFieldLabels data_cons
561 -- A constructor is only relevant to this process if
562 -- it contains all the fields that are being updated
563 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
564 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
566 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
567 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
569 mk_inst_ty (tyvar, result_inst_ty)
570 | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
571 | otherwise = newTyVarTy boxedTypeKind -- Fresh type
573 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
576 -- Typecheck the expression to be updated
578 record_ty = mkTyConApp tycon inst_tys
580 tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
583 -- Figure out the LIE we need. We have to generate some
584 -- dictionaries for the data type context, since we are going to
585 -- do some construction.
587 -- What dictionaries do we need? For the moment we assume that all
588 -- data constructors have the same context, and grab it from the first
589 -- constructor. If they have varying contexts then we'd have to
590 -- union the ones that could participate in the update.
592 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
593 inst_env = zipVarEnv tyvars result_inst_tys
594 theta' = substTopTheta inst_env theta
596 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
599 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
600 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
602 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
603 = unifyListTy res_ty `thenTc` \ elt_ty ->
604 tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
606 tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
607 newMethod (ArithSeqOrigin seq)
608 sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
610 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
613 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
614 = tcAddErrCtxt (arithSeqCtxt in_expr) $
615 unifyListTy res_ty `thenTc` \ elt_ty ->
616 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
617 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
618 tcLookupValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
619 newMethod (ArithSeqOrigin seq)
620 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
622 returnTc (ArithSeqOut (HsVar enum_from_then_id)
623 (FromThen expr1' expr2'),
624 lie1 `plusLIE` lie2 `plusLIE` lie3)
626 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
627 = tcAddErrCtxt (arithSeqCtxt in_expr) $
628 unifyListTy res_ty `thenTc` \ elt_ty ->
629 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
630 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
631 tcLookupValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
632 newMethod (ArithSeqOrigin seq)
633 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
635 returnTc (ArithSeqOut (HsVar enum_from_to_id)
636 (FromTo expr1' expr2'),
637 lie1 `plusLIE` lie2 `plusLIE` lie3)
639 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
640 = tcAddErrCtxt (arithSeqCtxt in_expr) $
641 unifyListTy res_ty `thenTc` \ elt_ty ->
642 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
643 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
644 tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
645 tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
646 newMethod (ArithSeqOrigin seq)
647 sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
649 returnTc (ArithSeqOut (HsVar eft_id)
650 (FromThenTo expr1' expr2' expr3'),
651 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
654 %************************************************************************
656 \subsection{Expressions type signatures}
658 %************************************************************************
661 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
662 = tcSetErrCtxt (exprSigCtxt in_expr) $
663 tcHsType poly_ty `thenTc` \ sig_tc_ty ->
665 if not (isForAllTy sig_tc_ty) then
667 unifyTauTy sig_tc_ty res_ty `thenTc_`
668 tcMonoExpr expr sig_tc_ty
670 else -- Signature is polymorphic
671 tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
673 -- Now match the signature type with res_ty.
674 -- We must not do this earlier, because res_ty might well
675 -- mention variables free in the environment, and we'd get
676 -- bogus complaints about not being able to for-all the
678 unifyTauTy res_ty expr_ty `thenTc_`
680 -- If everything is ok, return the stuff unchanged, except for
681 -- the effect of any substutions etc. We simply discard the
682 -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
683 -- resolution it may have done, which is recorded in the
688 Typecheck expression which in most cases will be an Id.
691 tcExpr_id :: RenamedHsExpr
697 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
699 other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty ->
700 tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
701 returnTc (id_expr', lie_id, id_ty)
704 %************************************************************************
706 \subsection{@tcApp@ typchecks an application}
708 %************************************************************************
712 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
713 -> TcType -- Expected result type of application
714 -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
717 tcApp fun args res_ty
718 = -- First type-check the function
719 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
721 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
722 split_fun_ty fun_ty (length args)
723 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
725 -- Unify with expected result before type-checking the args
726 -- This is when we might detect a too-few args situation
727 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
728 unifyTauTy res_ty actual_result_ty
731 -- Now typecheck the args
732 mapAndUnzipTc (tcArg fun)
733 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
735 -- Check that the result type doesn't have any nested for-alls.
736 -- For example, a "build" on its own is no good; it must be applied to something.
737 checkTc (isTauTy actual_result_ty)
738 (lurkingRank2Err fun fun_ty) `thenTc_`
740 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
743 -- If an error happens we try to figure out whether the
744 -- function has been given too many or too few arguments,
746 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
747 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
748 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
750 (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
751 (env2, act_ty'') = tidyOpenType env1 act_ty'
752 (exp_args, _) = splitFunTys exp_ty''
753 (act_args, _) = splitFunTys act_ty''
755 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
756 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
757 | otherwise = appCtxt fun args
759 returnNF_Tc (env2, message)
762 split_fun_ty :: TcType -- The type of the function
763 -> Int -- Number of arguments
764 -> TcM s ([TcType], -- Function argument types
765 TcType) -- Function result types
767 split_fun_ty fun_ty 0
768 = returnTc ([], fun_ty)
770 split_fun_ty fun_ty n
771 = -- Expect the function to have type A->B
772 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
773 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
774 returnTc (arg_ty:arg_tys, final_res_ty)
778 tcArg :: RenamedHsExpr -- The function (for error messages)
779 -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type
780 -> TcM s (TcExpr, LIE) -- Resulting argument and LIE
782 tcArg the_fun (arg, expected_arg_ty, arg_no)
783 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
784 tcExpr arg expected_arg_ty
788 %************************************************************************
790 \subsection{@tcId@ typchecks an identifier occurrence}
792 %************************************************************************
795 tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
798 = -- Look up the Id and instantiate its type
799 tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
802 Just tc_id -> instantiate_it tc_id (idType tc_id)
804 Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
805 tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
806 instantiate_it2 id tyvars theta tau
809 -- The instantiate_it loop runs round instantiating the Id.
810 -- It has to be a loop because we are now prepared to entertain
812 -- f:: forall a. Eq a => forall b. Baz b => tau
813 -- We want to instantiate this to
814 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
815 instantiate_it tc_id_occ ty
816 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
817 tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
818 instantiate_it2 tc_id_occ tyvars theta tau
820 instantiate_it2 tc_id_occ tyvars theta tau
821 = if null theta then -- Is it overloaded?
822 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
824 -- Yes, it's overloaded
825 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
826 tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
827 instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
828 returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
831 arg_tys = mkTyVarTys tyvars
834 %************************************************************************
836 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
838 %************************************************************************
841 tcDoStmts do_or_lc stmts src_loc res_ty
842 = -- get the Monad and MonadZero classes
843 -- create type consisting of a fresh monad tyvar
844 ASSERT( not (null stmts) )
845 tcAddSrcLoc src_loc $
847 newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
848 newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
849 unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
850 -- If it's a comprehension we're dealing with,
851 -- force it to be a list comprehension.
852 -- (as of Haskell 98, monad comprehensions are no more.)
854 ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
855 _ -> returnTc ()) `thenTc_`
857 tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
859 -- Build the then and zero methods in case we need them
860 -- It's important that "then" and "return" appear just once in the final LIE,
861 -- not only for typechecker efficiency, but also because otherwise during
862 -- simplification we end up with silly stuff like
863 -- then = case d of (t,r) -> t
865 -- where the second "then" sees that it already exists in the "available" stuff.
867 tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
868 tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
869 tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
870 newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
871 newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
872 newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
874 monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
876 returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
877 stmts_lie `plusLIE` monad_lie)
881 %************************************************************************
883 \subsection{Record bindings}
885 %************************************************************************
887 Game plan for record bindings
888 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
891 1. look up "field", to find its selector Id, which must have type
892 forall a1..an. T a1 .. an -> tau
893 where tau is the type of the field.
895 2. Instantiate this type
897 3. Unify the (T a1 .. an) part with the "expected result type", which
898 is passed in. This checks that all the field labels come from the
901 4. Type check the value using tcArg, passing tau as the expected
904 This extends OK when the field types are universally quantified.
906 Actually, to save excessive creation of fresh type variables,
911 :: TcType -- Expected type of whole record
912 -> RenamedRecordBinds
913 -> TcM s (TcRecordBinds, LIE)
915 tcRecordBinds expected_record_ty rbinds
916 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
917 returnTc (rbinds', plusLIEs lies)
919 do_bind (field_label, rhs, pun_flag)
920 = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
921 ASSERT( isRecordSelector sel_id )
922 -- This lookup and assertion will surely succeed, because
923 -- we check that the fields are indeed record selectors
924 -- before calling tcRecordBinds
926 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
928 -- Record selectors all have type
929 -- forall a1..an. T a1 .. an -> tau
930 ASSERT( maybeToBool (splitFunTy_maybe tau) )
932 -- Selector must have type RecordType -> FieldType
933 Just (record_ty, field_ty) = splitFunTy_maybe tau
935 unifyTauTy expected_record_ty record_ty `thenTc_`
936 tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
937 returnTc ((sel_id, rhs', pun_flag), lie)
939 badFields rbinds data_con
940 = [field_name | (field_name, _, _) <- rbinds,
941 not (field_name `elem` field_names)
944 field_names = map fieldLabelName (dataConFieldLabels data_con)
947 %************************************************************************
949 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
951 %************************************************************************
954 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
956 tcMonoExprs [] [] = returnTc ([], emptyLIE)
957 tcMonoExprs (expr:exprs) (ty:tys)
958 = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
959 tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
960 returnTc (expr':exprs', lie1 `plusLIE` lie2)
964 % =================================================
971 pp_nest_hang :: String -> SDoc -> SDoc
972 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
975 Boring and alphabetical:
978 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
981 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
984 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
987 = hang (ptext SLIT("In an expression with a type signature:"))
991 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
994 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
997 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1000 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1002 funAppCtxt fun arg arg_no
1003 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1004 quotes (ppr fun) <> text ", namely"])
1005 4 (quotes (ppr arg))
1007 wrongArgsCtxt too_many_or_few fun args
1008 = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1009 <+> ptext SLIT("is applied to") <+> text too_many_or_few
1010 <+> ptext SLIT("arguments in the call"))
1011 4 (parens (ppr the_app))
1013 the_app = foldl HsApp fun args -- Used in error messages
1016 = ptext SLIT("In the application") <+> (ppr the_app)
1018 the_app = foldl HsApp fun args -- Used in error messages
1020 lurkingRank2Err fun fun_ty
1021 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1022 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1023 ptext SLIT("so that the result type has for-alls in it")])
1025 rank2ArgCtxt arg expected_arg_ty
1026 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1029 = hang (ptext SLIT("No constructor has all these fields:"))
1030 4 (pprQuotedList fields)
1032 fields = [field | (field, _, _) <- rbinds]
1034 recordUpdCtxt = ptext SLIT("In a record update construct")
1037 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1039 illegalCcallTyErr isArg ty
1040 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
1044 | isArg = ptext SLIT("argument")
1045 | otherwise = ptext SLIT("result")