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 let n_args = length args
351 tv_idxs | n_args == 0 = []
352 | otherwise = [1..n_args]
354 mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys ->
355 tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
357 -- The argument types can be unboxed or boxed; the result
358 -- type must, however, be boxed since it's an argument to the IO
360 newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
362 io_result_ty = mkTyConApp ioTyCon [result_ty]
363 [ioDataCon] = tyConDataCons ioTyCon
365 unifyTauTy res_ty io_result_ty `thenTc_`
367 -- Construct the extra insts, which encode the
368 -- constraints on the argument and result types.
369 mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
370 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
371 returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
372 (CCall lbl args' may_gc is_asm result_ty),
373 -- do the wrapping in the newtype constructor here
374 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
378 tcMonoExpr (HsSCC label expr) res_ty
379 = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
380 returnTc (HsSCC label expr', lie)
382 tcMonoExpr (HsLet binds expr) res_ty
385 binds -- Bindings to check
386 tc_expr `thenTc` \ (expr', lie) ->
387 returnTc (expr', lie)
389 tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
390 returnTc (expr', lie)
391 combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
393 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
394 = tcAddSrcLoc src_loc $
395 tcAddErrCtxt (caseCtxt in_expr) $
397 -- Typecheck the case alternatives first.
398 -- The case patterns tend to give good type info to use
399 -- when typechecking the scrutinee. For example
402 -- will report that map is applied to too few arguments
404 -- Not only that, but it's better to check the matches on their
405 -- own, so that we get the expected results for scoped type variables.
407 -- (p::a, q::b) -> (q,p)
408 -- The above should work: the match (p,q) -> (q,p) is polymorphic as
409 -- claimed by the pattern signatures. But if we typechecked the
410 -- match with x in scope and x's type as the expected type, we'd be hosed.
412 tcMatchesCase matches res_ty `thenTc` \ (scrut_ty, matches', lie2) ->
414 tcAddErrCtxt (caseScrutCtxt scrut) (
415 tcMonoExpr scrut scrut_ty
416 ) `thenTc` \ (scrut',lie1) ->
418 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
420 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
421 = tcAddSrcLoc src_loc $
422 tcAddErrCtxt (predCtxt pred) (
423 tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
425 tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) ->
426 tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) ->
427 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
431 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
432 = tcDoStmts do_or_lc stmts src_loc res_ty
436 tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
437 = unifyListTy res_ty `thenTc` \ elt_ty ->
438 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
439 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
442 = tcAddErrCtxt (listCtxt expr) $
443 tcMonoExpr expr elt_ty
445 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
447 then unifyTupleTy (length exprs) res_ty
448 else unifyUnboxedTupleTy (length exprs) res_ty
449 ) `thenTc` \ arg_tys ->
450 mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
451 (exprs `zip` arg_tys) -- we know they're of equal length.
452 `thenTc` \ (exprs', lies) ->
453 returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
455 tcMonoExpr (RecordCon con_name rbinds) res_ty
456 = tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
458 (_, record_ty) = splitFunTys con_tau
460 -- Con is syntactically constrained to be a data constructor
461 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
462 unifyTauTy res_ty record_ty `thenTc_`
464 -- Check that the record bindings match the constructor
465 tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
467 bad_fields = badFields rbinds data_con
469 if not (null bad_fields) then
470 mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
471 failTc -- Fail now, because tcRecordBinds will crash on a bad field
474 -- Typecheck the record bindings
475 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
477 returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
480 -- The main complication with RecordUpd is that we need to explicitly
481 -- handle the *non-updated* fields. Consider:
483 -- data T a b = MkT1 { fa :: a, fb :: b }
484 -- | MkT2 { fa :: a, fc :: Int -> Int }
485 -- | MkT3 { fd :: a }
487 -- upd :: T a b -> c -> T a c
488 -- upd t x = t { fb = x}
490 -- The type signature on upd is correct (i.e. the result should not be (T a b))
491 -- because upd should be equivalent to:
493 -- upd t x = case t of
494 -- MkT1 p q -> MkT1 p x
495 -- MkT2 a b -> MkT2 p b
496 -- MkT3 d -> error ...
498 -- So we need to give a completely fresh type to the result record,
499 -- and then constrain it by the fields that are *not* updated ("p" above).
501 -- Note that because MkT3 doesn't contain all the fields being updated,
502 -- its RHS is simply an error, so it doesn't impose any type constraints
504 -- All this is done in STEP 4 below.
506 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
507 = tcAddErrCtxt recordUpdCtxt $
510 -- Check that the field names are really field names
511 ASSERT( not (null rbinds) )
513 field_names = [field_name | (field_name, _, _) <- rbinds]
515 mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
517 bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
520 Just sel_id -> not (isRecordSelector sel_id)
523 mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
524 if not (null bad_guys) then
529 -- Figure out the tycon and data cons from the first field name
531 (Just sel_id : _) = maybe_sel_ids
532 (_, tau) = splitForAllTys (idType sel_id)
533 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
534 (tycon, _, data_cons) = splitAlgTyConApp data_ty
535 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
537 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
540 -- Check that at least one constructor has all the named fields
541 -- i.e. has an empty set of bad fields returned by badFields
542 checkTc (any (null . badFields rbinds) data_cons)
543 (badFieldsUpd rbinds) `thenTc_`
546 -- Typecheck the update bindings.
547 -- (Do this after checking for bad fields in case there's a field that
548 -- doesn't match the constructor.)
550 result_record_ty = mkTyConApp tycon result_inst_tys
552 unifyTauTy res_ty result_record_ty `thenTc_`
553 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
556 -- Use the un-updated fields to find a vector of booleans saying
557 -- which type arguments must be the same in updatee and result.
559 -- WARNING: this code assumes that all data_cons in a common tycon
560 -- have FieldLabels abstracted over the same tyvars.
562 upd_field_lbls = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
563 con_field_lbls_s = map dataConFieldLabels data_cons
565 -- A constructor is only relevant to this process if
566 -- it contains all the fields that are being updated
567 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
568 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
570 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
571 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
573 mk_inst_ty (tyvar, result_inst_ty)
574 | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
575 | otherwise = newTyVarTy boxedTypeKind -- Fresh type
577 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
580 -- Typecheck the expression to be updated
582 record_ty = mkTyConApp tycon inst_tys
584 tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
587 -- Figure out the LIE we need. We have to generate some
588 -- dictionaries for the data type context, since we are going to
589 -- do some construction.
591 -- What dictionaries do we need? For the moment we assume that all
592 -- data constructors have the same context, and grab it from the first
593 -- constructor. If they have varying contexts then we'd have to
594 -- union the ones that could participate in the update.
596 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
597 inst_env = zipVarEnv tyvars result_inst_tys
598 theta' = substTopTheta inst_env theta
600 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
603 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
604 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
606 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
607 = unifyListTy res_ty `thenTc` \ elt_ty ->
608 tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
610 tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
611 newMethod (ArithSeqOrigin seq)
612 sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
614 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
617 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
618 = tcAddErrCtxt (arithSeqCtxt in_expr) $
619 unifyListTy res_ty `thenTc` \ elt_ty ->
620 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
621 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
622 tcLookupValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
623 newMethod (ArithSeqOrigin seq)
624 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
626 returnTc (ArithSeqOut (HsVar enum_from_then_id)
627 (FromThen expr1' expr2'),
628 lie1 `plusLIE` lie2 `plusLIE` lie3)
630 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
631 = tcAddErrCtxt (arithSeqCtxt in_expr) $
632 unifyListTy res_ty `thenTc` \ elt_ty ->
633 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
634 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
635 tcLookupValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
636 newMethod (ArithSeqOrigin seq)
637 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
639 returnTc (ArithSeqOut (HsVar enum_from_to_id)
640 (FromTo expr1' expr2'),
641 lie1 `plusLIE` lie2 `plusLIE` lie3)
643 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
644 = tcAddErrCtxt (arithSeqCtxt in_expr) $
645 unifyListTy res_ty `thenTc` \ elt_ty ->
646 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
647 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
648 tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
649 tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
650 newMethod (ArithSeqOrigin seq)
651 sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
653 returnTc (ArithSeqOut (HsVar eft_id)
654 (FromThenTo expr1' expr2' expr3'),
655 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
658 %************************************************************************
660 \subsection{Expressions type signatures}
662 %************************************************************************
665 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
666 = tcSetErrCtxt (exprSigCtxt in_expr) $
667 tcHsType poly_ty `thenTc` \ sig_tc_ty ->
669 if not (isForAllTy sig_tc_ty) then
671 unifyTauTy sig_tc_ty res_ty `thenTc_`
672 tcMonoExpr expr sig_tc_ty
674 else -- Signature is polymorphic
675 tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
677 -- Now match the signature type with res_ty.
678 -- We must not do this earlier, because res_ty might well
679 -- mention variables free in the environment, and we'd get
680 -- bogus complaints about not being able to for-all the
682 unifyTauTy res_ty expr_ty `thenTc_`
684 -- If everything is ok, return the stuff unchanged, except for
685 -- the effect of any substutions etc. We simply discard the
686 -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
687 -- resolution it may have done, which is recorded in the
692 Typecheck expression which in most cases will be an Id.
695 tcExpr_id :: RenamedHsExpr
701 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
703 other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty ->
704 tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
705 returnTc (id_expr', lie_id, id_ty)
708 %************************************************************************
710 \subsection{@tcApp@ typchecks an application}
712 %************************************************************************
716 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
717 -> TcType -- Expected result type of application
718 -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
721 tcApp fun args res_ty
722 = -- First type-check the function
723 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
725 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
726 split_fun_ty fun_ty (length args)
727 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
729 -- Unify with expected result before type-checking the args
730 -- This is when we might detect a too-few args situation
731 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
732 unifyTauTy res_ty actual_result_ty
735 -- Now typecheck the args
736 mapAndUnzipTc (tcArg fun)
737 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
739 -- Check that the result type doesn't have any nested for-alls.
740 -- For example, a "build" on its own is no good; it must be applied to something.
741 checkTc (isTauTy actual_result_ty)
742 (lurkingRank2Err fun fun_ty) `thenTc_`
744 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
747 -- If an error happens we try to figure out whether the
748 -- function has been given too many or too few arguments,
750 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
751 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
752 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
754 (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
755 (env2, act_ty'') = tidyOpenType env1 act_ty'
756 (exp_args, _) = splitFunTys exp_ty''
757 (act_args, _) = splitFunTys act_ty''
759 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
760 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
761 | otherwise = appCtxt fun args
763 returnNF_Tc (env2, message)
766 split_fun_ty :: TcType -- The type of the function
767 -> Int -- Number of arguments
768 -> TcM s ([TcType], -- Function argument types
769 TcType) -- Function result types
771 split_fun_ty fun_ty 0
772 = returnTc ([], fun_ty)
774 split_fun_ty fun_ty n
775 = -- Expect the function to have type A->B
776 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
777 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
778 returnTc (arg_ty:arg_tys, final_res_ty)
782 tcArg :: RenamedHsExpr -- The function (for error messages)
783 -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type
784 -> TcM s (TcExpr, LIE) -- Resulting argument and LIE
786 tcArg the_fun (arg, expected_arg_ty, arg_no)
787 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
788 tcExpr arg expected_arg_ty
792 %************************************************************************
794 \subsection{@tcId@ typchecks an identifier occurrence}
796 %************************************************************************
799 tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
802 = -- Look up the Id and instantiate its type
803 tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
806 Just tc_id -> instantiate_it tc_id (idType tc_id)
808 Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
809 tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
810 instantiate_it2 id tyvars theta tau
813 -- The instantiate_it loop runs round instantiating the Id.
814 -- It has to be a loop because we are now prepared to entertain
816 -- f:: forall a. Eq a => forall b. Baz b => tau
817 -- We want to instantiate this to
818 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
819 instantiate_it tc_id_occ ty
820 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
821 tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
822 instantiate_it2 tc_id_occ tyvars theta tau
824 instantiate_it2 tc_id_occ tyvars theta tau
825 = if null theta then -- Is it overloaded?
826 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
828 -- Yes, it's overloaded
829 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
830 tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
831 instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
832 returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
835 arg_tys = mkTyVarTys tyvars
838 %************************************************************************
840 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
842 %************************************************************************
845 tcDoStmts do_or_lc stmts src_loc res_ty
846 = -- get the Monad and MonadZero classes
847 -- create type consisting of a fresh monad tyvar
848 ASSERT( not (null stmts) )
849 tcAddSrcLoc src_loc $
851 newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
852 newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
853 unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
854 -- If it's a comprehension we're dealing with,
855 -- force it to be a list comprehension.
856 -- (as of Haskell 98, monad comprehensions are no more.)
858 ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
859 _ -> returnTc ()) `thenTc_`
861 tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
863 -- Build the then and zero methods in case we need them
864 -- It's important that "then" and "return" appear just once in the final LIE,
865 -- not only for typechecker efficiency, but also because otherwise during
866 -- simplification we end up with silly stuff like
867 -- then = case d of (t,r) -> t
869 -- where the second "then" sees that it already exists in the "available" stuff.
871 tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
872 tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
873 tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
874 newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
875 newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
876 newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
878 monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
880 returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
881 stmts_lie `plusLIE` monad_lie)
885 %************************************************************************
887 \subsection{Record bindings}
889 %************************************************************************
891 Game plan for record bindings
892 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
895 1. look up "field", to find its selector Id, which must have type
896 forall a1..an. T a1 .. an -> tau
897 where tau is the type of the field.
899 2. Instantiate this type
901 3. Unify the (T a1 .. an) part with the "expected result type", which
902 is passed in. This checks that all the field labels come from the
905 4. Type check the value using tcArg, passing tau as the expected
908 This extends OK when the field types are universally quantified.
910 Actually, to save excessive creation of fresh type variables,
915 :: TcType -- Expected type of whole record
916 -> RenamedRecordBinds
917 -> TcM s (TcRecordBinds, LIE)
919 tcRecordBinds expected_record_ty rbinds
920 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
921 returnTc (rbinds', plusLIEs lies)
923 do_bind (field_label, rhs, pun_flag)
924 = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
925 ASSERT( isRecordSelector sel_id )
926 -- This lookup and assertion will surely succeed, because
927 -- we check that the fields are indeed record selectors
928 -- before calling tcRecordBinds
930 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
932 -- Record selectors all have type
933 -- forall a1..an. T a1 .. an -> tau
934 ASSERT( maybeToBool (splitFunTy_maybe tau) )
936 -- Selector must have type RecordType -> FieldType
937 Just (record_ty, field_ty) = splitFunTy_maybe tau
939 unifyTauTy expected_record_ty record_ty `thenTc_`
940 tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
941 returnTc ((sel_id, rhs', pun_flag), lie)
943 badFields rbinds data_con
944 = [field_name | (field_name, _, _) <- rbinds,
945 not (field_name `elem` field_names)
948 field_names = map fieldLabelName (dataConFieldLabels data_con)
951 %************************************************************************
953 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
955 %************************************************************************
958 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
960 tcMonoExprs [] [] = returnTc ([], emptyLIE)
961 tcMonoExprs (expr:exprs) (ty:tys)
962 = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
963 tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
964 returnTc (expr':exprs', lie1 `plusLIE` lie2)
968 % =================================================
975 pp_nest_hang :: String -> SDoc -> SDoc
976 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
979 Boring and alphabetical:
982 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
985 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
988 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
991 = hang (ptext SLIT("In an expression with a type signature:"))
995 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
998 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1000 sectionRAppCtxt expr
1001 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1003 sectionLAppCtxt expr
1004 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1006 funAppCtxt fun arg arg_no
1007 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1008 quotes (ppr fun) <> text ", namely"])
1009 4 (quotes (ppr arg))
1011 wrongArgsCtxt too_many_or_few fun args
1012 = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1013 <+> ptext SLIT("is applied to") <+> text too_many_or_few
1014 <+> ptext SLIT("arguments in the call"))
1015 4 (parens (ppr the_app))
1017 the_app = foldl HsApp fun args -- Used in error messages
1020 = ptext SLIT("In the application") <+> quotes (ppr the_app)
1022 the_app = foldl HsApp fun args -- Used in error messages
1024 lurkingRank2Err fun fun_ty
1025 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1026 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1027 ptext SLIT("so that the result type has for-alls in it")])
1029 rank2ArgCtxt arg expected_arg_ty
1030 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1033 = hang (ptext SLIT("No constructor has all these fields:"))
1034 4 (pprQuotedList fields)
1036 fields = [field | (field, _, _) <- rbinds]
1038 recordUpdCtxt = ptext SLIT("In a record update construct")
1041 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1043 illegalCcallTyErr isArg ty
1044 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
1048 | isArg = ptext SLIT("argument")
1049 | otherwise = ptext SLIT("result")