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(..),
15 import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
16 import TcHsSyn ( TcExpr, TcRecordBinds,
21 import BasicTypes ( RecFlag(..) )
23 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
24 LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
25 newMethod, newMethodWithGivenTy, newDicts, instToId )
26 import TcBinds ( tcBindsAndThen )
27 import TcEnv ( TcIdOcc(..), tcInstId, tidyType,
28 tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
29 tcLookupGlobalValueByKey,
30 tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
31 tcLookupTyCon, tcLookupDataCon
33 import TcMatches ( tcMatchesCase, tcMatchExpected )
34 import TcGRHSs ( tcStmts )
35 import TcMonoType ( tcHsTcType, checkSigTyVars, sigCtxt )
36 import TcPat ( badFieldCon )
37 import TcSimplify ( tcSimplifyAndCheck )
38 import TcType ( TcType, TcTauType, TcMaybe(..),
40 tcInstTcType, tcSplitRhoTy,
41 newTyVarTy, zonkTcType )
43 import Class ( Class )
44 import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
45 import Id ( idType, recordSelectorFieldLabel,
49 import DataCon ( dataConFieldLabels, dataConSig, dataConId )
51 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
52 splitFunTy_maybe, splitFunTys,
54 splitForAllTys, splitRhoTy,
55 isTauTy, tyVarsOfType, tyVarsOfTypes,
56 isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
57 boxedTypeKind, openTypeKind, mkArrowKind,
60 import VarEnv ( zipVarEnv )
61 import VarSet ( elemVarSet, mkVarSet )
62 import TyCon ( tyConDataCons )
63 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
64 floatPrimTy, addrPrimTy
66 import TysWiredIn ( boolTy, charTy, stringTy )
67 import PrelInfo ( ioTyCon_NAME )
68 import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
70 import Unique ( cCallableClassKey, cReturnableClassKey,
71 enumFromClassOpKey, enumFromThenClassOpKey,
72 enumFromToClassOpKey, enumFromThenToClassOpKey,
73 thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
76 import Maybes ( maybeToBool )
77 import ListSetOps ( minusList )
81 %************************************************************************
83 \subsection{Main wrappers}
85 %************************************************************************
88 tcExpr :: RenamedHsExpr -- Expession to type check
89 -> TcType s -- Expected type (could be a polytpye)
90 -> TcM s (TcExpr s, LIE s)
92 tcExpr expr ty | isForAllTy ty = -- Polymorphic case
93 tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
96 | otherwise = -- Monomorphic case
101 %************************************************************************
103 \subsection{@tcPolyExpr@ typchecks an application}
105 %************************************************************************
108 -- tcPolyExpr is like tcMonoExpr, except that the expected type
109 -- can be a polymorphic one.
110 tcPolyExpr :: RenamedHsExpr
111 -> TcType s -- Expected type
112 -> TcM s (TcExpr s, LIE s, -- Generalised expr with expected type, and LIE
113 TcExpr s, TcTauType s, LIE s) -- Same thing, but instantiated; tau-type returned
115 tcPolyExpr arg expected_arg_ty
116 = -- Ha! The argument type of the function is a for-all type,
117 -- An example of rank-2 polymorphism.
119 -- To ensure that the forall'd type variables don't get unified with each
120 -- other or any other types, we make fresh copy of the alleged type
121 tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
123 (sig_theta, sig_tau) = splitRhoTy sig_rho
125 -- Type-check the arg and unify with expected type
126 tcExtendGlobalTyVars (mkVarSet sig_tyvars) (
127 tcMonoExpr arg sig_tau
128 ) `thenTc` \ (arg', lie_arg) ->
130 -- Check that the arg_tyvars havn't been constrained
131 -- The interesting bit here is that we must include the free variables
132 -- of the expected arg ty. Here's an example:
133 -- runST (newVar True)
134 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
135 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
136 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
137 -- So now s' isn't unconstrained because it's linked to a.
138 -- Conclusion: include the free vars of the expected arg type in the
139 -- list of "free vars" for the signature check.
141 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
142 tcAddErrCtxtM (sigCtxt (text "an expression") sig_tau) $
144 checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
146 newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
147 -- ToDo: better origin
150 (mkVarSet zonked_sig_tyvars)
151 sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
154 -- This HsLet binds any Insts which came out of the simplification.
155 -- It's a bit out of place here, but using AbsBind involves inventing
156 -- a couple of new names which seems worse.
157 generalised_arg = TyLam zonked_sig_tyvars $
159 HsLet (MonoBind inst_binds [] Recursive)
162 returnTc ( generalised_arg, free_insts,
163 arg', sig_tau, lie_arg )
166 %************************************************************************
168 \subsection{The TAUT rules for variables}
170 %************************************************************************
173 tcMonoExpr :: RenamedHsExpr -- Expession to type check
174 -> TcTauType s -- Expected type (could be a type variable)
175 -> TcM s (TcExpr s, LIE s)
177 tcMonoExpr (HsVar name) res_ty
178 = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
179 unifyTauTy res_ty id_ty `thenTc_`
181 -- Check that the result type doesn't have any nested for-alls.
182 -- For example, a "build" on its own is no good; it must be
183 -- applied to something.
184 checkTc (isTauTy id_ty)
185 (lurkingRank2Err name id_ty) `thenTc_`
187 returnTc (expr', lie)
190 %************************************************************************
192 \subsection{Literals}
194 %************************************************************************
199 tcMonoExpr (HsLit (HsInt i)) res_ty
200 = newOverloadedLit (LiteralOrigin (HsInt i))
201 (OverloadedIntegral i)
202 res_ty `thenNF_Tc` \ stuff ->
205 tcMonoExpr (HsLit (HsFrac f)) res_ty
206 = newOverloadedLit (LiteralOrigin (HsFrac f))
207 (OverloadedFractional f)
208 res_ty `thenNF_Tc` \ stuff ->
212 tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
213 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
214 newDicts (LitLitOrigin (_UNPK_ s))
215 [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
216 returnTc (HsLitOut lit res_ty, dicts)
222 tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty
223 = unifyTauTy res_ty charPrimTy `thenTc_`
224 returnTc (HsLitOut lit charPrimTy, emptyLIE)
226 tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty
227 = unifyTauTy res_ty addrPrimTy `thenTc_`
228 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
230 tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty
231 = unifyTauTy res_ty intPrimTy `thenTc_`
232 returnTc (HsLitOut lit intPrimTy, emptyLIE)
234 tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty
235 = unifyTauTy res_ty floatPrimTy `thenTc_`
236 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
238 tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty
239 = unifyTauTy res_ty doublePrimTy `thenTc_`
240 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
243 Unoverloaded literals:
246 tcMonoExpr (HsLit lit@(HsChar c)) res_ty
247 = unifyTauTy res_ty charTy `thenTc_`
248 returnTc (HsLitOut lit charTy, emptyLIE)
250 tcMonoExpr (HsLit lit@(HsString str)) res_ty
251 = unifyTauTy res_ty stringTy `thenTc_`
252 returnTc (HsLitOut lit stringTy, emptyLIE)
255 %************************************************************************
257 \subsection{Other expression forms}
259 %************************************************************************
262 tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
263 = tcMonoExpr expr res_ty
265 -- perform the negate *before* overloading the integer, since the case
266 -- of minBound on Ints fails otherwise. Could be done elsewhere, but
267 -- convenient to do it here.
269 tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty
270 = tcMonoExpr (HsLit (HsInt (-i))) res_ty
272 tcMonoExpr (NegApp expr neg) res_ty
273 = tcMonoExpr (HsApp neg expr) res_ty
275 tcMonoExpr (HsLam match) res_ty
276 = tcMatchExpected match res_ty LambdaBody `thenTc` \ (match',lie) ->
277 returnTc (HsLam match', lie)
279 tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
281 accum (HsApp e1 e2) args = accum e1 (e2:args)
283 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
284 returnTc (foldl HsApp fun' args', lie)
286 -- equivalent to (op e1) e2:
287 tcMonoExpr (OpApp arg1 op fix arg2) res_ty
288 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
289 returnTc (OpApp arg1' op' fix arg2', lie)
292 Note that the operators in sections are expected to be binary, and
293 a type error will occur if they aren't.
296 -- Left sections, equivalent to
303 tcMonoExpr in_expr@(SectionL arg op) res_ty
304 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
306 -- Check that res_ty is a function type
307 -- Without this check we barf in the desugarer on
309 -- because it tries to desugar to
310 -- f op = \r -> 3 op r
311 -- so (3 `op`) had better be a function!
312 tcAddErrCtxt (sectionLAppCtxt in_expr) $
313 unifyFunTy res_ty `thenTc_`
315 returnTc (SectionL arg' op', lie)
317 -- Right sections, equivalent to \ x -> x op expr, or
320 tcMonoExpr in_expr@(SectionR op expr) res_ty
321 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
322 tcAddErrCtxt (sectionRAppCtxt in_expr) $
323 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
324 tcMonoExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
325 unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
326 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
329 The interesting thing about @ccall@ is that it is just a template
330 which we instantiate by filling in details about the types of its
331 argument and result (ie minimal typechecking is performed). So, the
332 basic story is that we allocate a load of type variables (to hold the
333 arg/result types); unify them with the args/result; and store them for
337 tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
338 = -- Get the callable and returnable classes.
339 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
340 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
341 tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
343 new_arg_dict (arg, arg_ty)
344 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
345 [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
346 returnNF_Tc arg_dicts -- Actually a singleton bag
348 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
352 mapNF_Tc (\ _ -> newTyVarTy openTypeKind)
353 [1..(length args)] `thenNF_Tc` \ ty_vars ->
354 tcMonoExprs args ty_vars `thenTc` \ (args', args_lie) ->
356 -- The argument types can be unboxed or boxed; the result
357 -- type must, however, be boxed since it's an argument to the IO
359 newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
361 io_result_ty = mkTyConApp ioTyCon [result_ty]
362 [ioDataCon] = tyConDataCons ioTyCon
364 unifyTauTy res_ty io_result_ty `thenTc_`
366 -- Construct the extra insts, which encode the
367 -- constraints on the argument and result types.
368 mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
369 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
371 returnTc (HsApp (HsVar (RealId (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 tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
406 tcAddErrCtxt (caseScrutCtxt scrut) (
407 tcMonoExpr scrut scrut_ty
408 ) `thenTc` \ (scrut',lie1) ->
410 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
412 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
413 = tcAddSrcLoc src_loc $
414 tcAddErrCtxt (predCtxt pred) (
415 tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
417 tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) ->
418 tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) ->
419 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
423 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
424 = tcDoStmts do_or_lc stmts src_loc res_ty
428 tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
429 = unifyListTy res_ty `thenTc` \ elt_ty ->
430 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
431 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
434 = tcAddErrCtxt (listCtxt expr) $
435 tcMonoExpr expr elt_ty
437 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
439 then unifyTupleTy (length exprs) res_ty
440 else unifyUnboxedTupleTy (length exprs) res_ty
441 ) `thenTc` \ arg_tys ->
442 mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
443 (exprs `zip` arg_tys) -- we know they're of equal length.
444 `thenTc` \ (exprs', lies) ->
445 returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
447 tcMonoExpr (RecordCon con_name rbinds) res_ty
448 = tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
450 (_, record_ty) = splitFunTys con_tau
452 -- Con is syntactically constrained to be a data constructor
453 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
454 unifyTauTy res_ty record_ty `thenTc_`
456 -- Check that the record bindings match the constructor
457 tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
459 bad_fields = badFields rbinds data_con
461 mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
463 -- Typecheck the record bindings
464 -- (Do this after checkRecordFields in case there's a field that
465 -- doesn't match the constructor.)
466 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
468 returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
471 -- The main complication with RecordUpd is that we need to explicitly
472 -- handle the *non-updated* fields. Consider:
474 -- data T a b = MkT1 { fa :: a, fb :: b }
475 -- | MkT2 { fa :: a, fc :: Int -> Int }
476 -- | MkT3 { fd :: a }
478 -- upd :: T a b -> c -> T a c
479 -- upd t x = t { fb = x}
481 -- The type signature on upd is correct (i.e. the result should not be (T a b))
482 -- because upd should be equivalent to:
484 -- upd t x = case t of
485 -- MkT1 p q -> MkT1 p x
486 -- MkT2 a b -> MkT2 p b
487 -- MkT3 d -> error ...
489 -- So we need to give a completely fresh type to the result record,
490 -- and then constrain it by the fields that are *not* updated ("p" above).
492 -- Note that because MkT3 doesn't contain all the fields being updated,
493 -- its RHS is simply an error, so it doesn't impose any type constraints
495 -- All this is done in STEP 4 below.
497 tcMonoExpr (RecordUpd record_expr rbinds) res_ty
498 = tcAddErrCtxt recordUpdCtxt $
501 -- Figure out the tycon and data cons from the first field name
502 ASSERT( not (null rbinds) )
504 ((first_field_name, _, _) : rest) = rbinds
506 tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
507 (case maybe_sel_id of
508 Just sel_id | isRecordSelector sel_id -> returnTc sel_id
509 other -> failWithTc (notSelector first_field_name)
510 ) `thenTc` \ sel_id ->
512 (_, tau) = splitForAllTys (idType sel_id)
513 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
514 (tycon, _, data_cons) = splitAlgTyConApp data_ty
515 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
517 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
520 -- Check for bad fields
521 checkTc (any (null . badFields rbinds) data_cons)
522 (badFieldsUpd rbinds) `thenTc_`
524 -- Typecheck the update bindings.
525 -- (Do this after checking for bad fields in case there's a field that
526 -- doesn't match the constructor.)
528 result_record_ty = mkTyConApp tycon result_inst_tys
530 unifyTauTy res_ty result_record_ty `thenTc_`
531 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
534 -- Use the un-updated fields to find a vector of booleans saying
535 -- which type arguments must be the same in updatee and result.
537 -- WARNING: this code assumes that all data_cons in a common tycon
538 -- have FieldLabels abstracted over the same tyvars.
540 upd_field_lbls = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
541 con_field_lbls_s = map dataConFieldLabels data_cons
543 -- A constructor is only relevant to this process if
544 -- it contains all the fields that are being updated
545 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
546 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
548 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
549 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
551 mk_inst_ty (tyvar, result_inst_ty)
552 | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
553 | otherwise = newTyVarTy boxedTypeKind -- Fresh type
555 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
558 -- Typecheck the expression to be updated
560 record_ty = mkTyConApp tycon inst_tys
562 tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
565 -- Figure out the LIE we need. We have to generate some
566 -- dictionaries for the data type context, since we are going to
567 -- do some construction.
569 -- What dictionaries do we need? For the moment we assume that all
570 -- data constructors have the same context, and grab it from the first
571 -- constructor. If they have varying contexts then we'd have to
572 -- union the ones that could participate in the update.
574 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
575 inst_env = zipVarEnv tyvars result_inst_tys
576 theta' = substFlexiTheta inst_env theta
578 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
581 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
582 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
584 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
585 = unifyListTy res_ty `thenTc` \ elt_ty ->
586 tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
588 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
589 newMethod (ArithSeqOrigin seq)
590 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
592 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
595 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
596 = tcAddErrCtxt (arithSeqCtxt in_expr) $
597 unifyListTy res_ty `thenTc` \ elt_ty ->
598 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
599 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
600 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
601 newMethod (ArithSeqOrigin seq)
602 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
604 returnTc (ArithSeqOut (HsVar enum_from_then_id)
605 (FromThen expr1' expr2'),
606 lie1 `plusLIE` lie2 `plusLIE` lie3)
608 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
609 = tcAddErrCtxt (arithSeqCtxt in_expr) $
610 unifyListTy res_ty `thenTc` \ elt_ty ->
611 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
612 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
613 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
614 newMethod (ArithSeqOrigin seq)
615 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
617 returnTc (ArithSeqOut (HsVar enum_from_to_id)
618 (FromTo expr1' expr2'),
619 lie1 `plusLIE` lie2 `plusLIE` lie3)
621 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
622 = tcAddErrCtxt (arithSeqCtxt in_expr) $
623 unifyListTy res_ty `thenTc` \ elt_ty ->
624 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
625 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
626 tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
627 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
628 newMethod (ArithSeqOrigin seq)
629 (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
631 returnTc (ArithSeqOut (HsVar eft_id)
632 (FromThenTo expr1' expr2' expr3'),
633 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
636 %************************************************************************
638 \subsection{Expressions type signatures}
640 %************************************************************************
643 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
644 = tcSetErrCtxt (exprSigCtxt in_expr) $
645 tcHsTcType poly_ty `thenTc` \ sig_tc_ty ->
647 if not (isForAllTy sig_tc_ty) then
649 unifyTauTy sig_tc_ty res_ty `thenTc_`
650 tcMonoExpr expr sig_tc_ty
652 else -- Signature is polymorphic
653 tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
655 -- Now match the signature type with res_ty.
656 -- We must not do this earlier, because res_ty might well
657 -- mention variables free in the environment, and we'd get
658 -- bogus complaints about not being able to for-all the
660 unifyTauTy res_ty expr_ty `thenTc_`
662 -- If everything is ok, return the stuff unchanged, except for
663 -- the effect of any substutions etc. We simply discard the
664 -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
665 -- resolution it may have done, which is recorded in the
670 Typecheck expression which in most cases will be an Id.
673 tcExpr_id :: RenamedHsExpr
679 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
681 other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty ->
682 tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
683 returnTc (id_expr', lie_id, id_ty)
686 %************************************************************************
688 \subsection{@tcApp@ typchecks an application}
690 %************************************************************************
694 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
695 -> TcType s -- Expected result type of application
696 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
699 tcApp fun args res_ty
700 = -- First type-check the function
701 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
703 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
704 split_fun_ty fun_ty (length args)
705 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
707 -- Unify with expected result before type-checking the args
708 -- This is when we might detect a too-few args situation
709 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
710 unifyTauTy res_ty actual_result_ty
713 -- Now typecheck the args
714 mapAndUnzipTc (tcArg fun)
715 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
717 -- Check that the result type doesn't have any nested for-alls.
718 -- For example, a "build" on its own is no good; it must be applied to something.
719 checkTc (isTauTy actual_result_ty)
720 (lurkingRank2Err fun fun_ty) `thenTc_`
722 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
725 -- If an error happens we try to figure out whether the
726 -- function has been given too many or too few arguments,
728 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
729 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
730 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
732 (env1, exp_ty'') = tidyType tidy_env exp_ty'
733 (env2, act_ty'') = tidyType env1 act_ty'
734 (exp_args, _) = splitFunTys exp_ty''
735 (act_args, _) = splitFunTys act_ty''
737 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
738 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
739 | otherwise = appCtxt fun args
741 returnNF_Tc (env2, message)
744 split_fun_ty :: TcType s -- The type of the function
745 -> Int -- Number of arguments
746 -> TcM s ([TcType s], -- Function argument types
747 TcType s) -- Function result types
749 split_fun_ty fun_ty 0
750 = returnTc ([], fun_ty)
752 split_fun_ty fun_ty n
753 = -- Expect the function to have type A->B
754 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
755 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
756 returnTc (arg_ty:arg_tys, final_res_ty)
760 tcArg :: RenamedHsExpr -- The function (for error messages)
761 -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
762 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
764 tcArg the_fun (arg, expected_arg_ty, arg_no)
765 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
766 tcExpr arg expected_arg_ty
770 %************************************************************************
772 \subsection{@tcId@ typchecks an identifier occurrence}
774 %************************************************************************
777 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
780 = -- Look up the Id and instantiate its type
781 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
784 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
786 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
787 tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
788 instantiate_it2 (RealId id) tyvars theta tau
791 -- The instantiate_it loop runs round instantiating the Id.
792 -- It has to be a loop because we are now prepared to entertain
794 -- f:: forall a. Eq a => forall b. Baz b => tau
795 -- We want to instantiate this to
796 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
797 instantiate_it tc_id_occ ty
798 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
799 tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
800 instantiate_it2 tc_id_occ tyvars theta tau
802 instantiate_it2 tc_id_occ tyvars theta tau
803 = if null theta then -- Is it overloaded?
804 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
806 -- Yes, it's overloaded
807 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
808 tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
809 instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
810 returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
813 arg_tys = mkTyVarTys tyvars
816 %************************************************************************
818 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
820 %************************************************************************
823 tcDoStmts do_or_lc stmts src_loc res_ty
824 = -- get the Monad and MonadZero classes
825 -- create type consisting of a fresh monad tyvar
826 ASSERT( not (null stmts) )
827 tcAddSrcLoc src_loc $
829 newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
830 newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
831 unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
833 tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
835 -- Build the then and zero methods in case we need them
836 -- It's important that "then" and "return" appear just once in the final LIE,
837 -- not only for typechecker efficiency, but also because otherwise during
838 -- simplification we end up with silly stuff like
839 -- then = case d of (t,r) -> t
841 -- where the second "then" sees that it already exists in the "available" stuff.
843 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
844 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
845 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
847 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
849 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
851 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
853 monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
854 perhaps_zero_lie | all failure_free stmts' = emptyLIE
855 | otherwise = zero_lie
857 failure_free (BindStmt pat _ _) = failureFreePat pat
858 failure_free (GuardStmt _ _) = False
859 failure_free other_stmt = True
861 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
862 stmts_lie `plusLIE` monad_lie)
866 %************************************************************************
868 \subsection{Record bindings}
870 %************************************************************************
872 Game plan for record bindings
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
876 1. look up "field", to find its selector Id, which must have type
877 forall a1..an. T a1 .. an -> tau
878 where tau is the type of the field.
880 2. Instantiate this type
882 3. Unify the (T a1 .. an) part with the "expected result type", which
883 is passed in. This checks that all the field labels come from the
886 4. Type check the value using tcArg, passing tau as the expected
889 This extends OK when the field types are universally quantified.
891 Actually, to save excessive creation of fresh type variables,
896 :: TcType s -- Expected type of whole record
897 -> RenamedRecordBinds
898 -> TcM s (TcRecordBinds s, LIE s)
900 tcRecordBinds expected_record_ty rbinds
901 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
902 returnTc (rbinds', plusLIEs lies)
904 do_bind (field_label, rhs, pun_flag)
905 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
906 ASSERT( isRecordSelector sel_id )
907 -- This lookup and assertion will surely succeed, because
908 -- we check that the fields are indeed record selectors
909 -- before calling tcRecordBinds
911 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
913 -- Record selectors all have type
914 -- forall a1..an. T a1 .. an -> tau
915 ASSERT( maybeToBool (splitFunTy_maybe tau) )
917 -- Selector must have type RecordType -> FieldType
918 Just (record_ty, field_ty) = splitFunTy_maybe tau
920 unifyTauTy expected_record_ty record_ty `thenTc_`
921 tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
922 returnTc ((RealId sel_id, rhs', pun_flag), lie)
924 badFields rbinds data_con
925 = [field_name | (field_name, _, _) <- rbinds,
926 not (field_name `elem` field_names)
929 field_names = map fieldLabelName (dataConFieldLabels data_con)
932 %************************************************************************
934 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
936 %************************************************************************
939 tcMonoExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
941 tcMonoExprs [] [] = returnTc ([], emptyLIE)
942 tcMonoExprs (expr:exprs) (ty:tys)
943 = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
944 tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
945 returnTc (expr':exprs', lie1 `plusLIE` lie2)
949 % =================================================
956 pp_nest_hang :: String -> SDoc -> SDoc
957 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
960 Boring and alphabetical:
963 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
966 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
969 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
972 = hang (ptext SLIT("In an expression with a type signature:"))
976 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
979 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
982 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
985 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
987 funAppCtxt fun arg arg_no
988 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
989 quotes (ppr fun) <> text ", namely"])
992 wrongArgsCtxt too_many_or_few fun args
993 = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
994 <+> ptext SLIT("is applied to") <+> text too_many_or_few
995 <+> ptext SLIT("arguments in the call"))
996 4 (parens (ppr the_app))
998 the_app = foldl HsApp fun args -- Used in error messages
1001 = ptext SLIT("In the application") <+> (ppr the_app)
1003 the_app = foldl HsApp fun args -- Used in error messages
1005 lurkingRank2Err fun fun_ty
1006 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1007 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1008 ptext SLIT("so that the result type has for-alls in it")])
1010 rank2ArgCtxt arg expected_arg_ty
1011 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1014 = hang (ptext SLIT("No constructor has all these fields:"))
1015 4 (pprQuotedList fields)
1017 fields = [field | (field, _, _) <- rbinds]
1019 recordUpdCtxt = ptext SLIT("In a record update construct")
1022 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]