2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcExpr]{Typecheck an expression}
7 module TcExpr ( tcApp, 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,
17 mkHsTyApp, mkHsLet, maybeBoxedPrimType
21 import BasicTypes ( RecFlag(..) )
23 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
24 LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
25 newMethod, instOverloadedFun, newDicts )
26 import TcBinds ( tcBindsAndThen )
27 import TcEnv ( tcInstId,
28 tcLookupValue, tcLookupClassByKey,
30 tcExtendGlobalTyVars, tcLookupValueMaybe,
31 tcLookupTyCon, tcLookupDataCon
33 import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
34 import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
35 import TcPat ( badFieldCon )
36 import TcSimplify ( tcSimplifyAndCheck )
37 import TcType ( TcType, TcTauType,
39 tcInstTcType, tcSplitRhoTy,
40 newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
42 import Class ( Class )
43 import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType
45 import Id ( idType, recordSelectorFieldLabel,
49 import DataCon ( dataConFieldLabels, dataConSig, dataConId,
50 dataConStrictMarks, StrictnessMark(..)
53 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
54 splitFunTy_maybe, splitFunTys, isNotUsgTy,
56 splitForAllTys, splitRhoTy,
57 isTauTy, tyVarsOfType, tyVarsOfTypes,
58 isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
59 boxedTypeKind, mkArrowKind,
62 import Subst ( mkTopTyVarSubst, substTheta )
63 import UsageSPUtils ( unannotTy )
64 import VarSet ( elemVarSet, mkVarSet )
65 import TyCon ( tyConDataCons )
66 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
67 floatPrimTy, addrPrimTy
69 import TysWiredIn ( boolTy, charTy, stringTy )
70 import PrelInfo ( ioTyCon_NAME )
71 import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
73 import Unique ( cCallableClassKey, cReturnableClassKey,
74 enumFromClassOpKey, enumFromThenClassOpKey,
75 enumFromToClassOpKey, enumFromThenToClassOpKey,
76 thenMClassOpKey, failMClassOpKey, returnMClassOpKey
79 import Maybes ( maybeToBool, mapMaybe )
80 import ListSetOps ( minusList )
82 import CmdLineOpts ( opt_WarnMissingFields )
86 %************************************************************************
88 \subsection{Main wrappers}
90 %************************************************************************
93 tcExpr :: RenamedHsExpr -- Expession to type check
94 -> TcType -- Expected type (could be a polytpye)
95 -> TcM s (TcExpr, LIE)
97 tcExpr expr ty | isForAllTy ty = -- Polymorphic case
98 tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
101 | otherwise = -- Monomorphic case
106 %************************************************************************
108 \subsection{@tcPolyExpr@ typchecks an application}
110 %************************************************************************
113 -- tcPolyExpr is like tcMonoExpr, except that the expected type
114 -- can be a polymorphic one.
115 tcPolyExpr :: RenamedHsExpr
116 -> TcType -- Expected type
117 -> TcM s (TcExpr, LIE, -- Generalised expr with expected type, and LIE
118 TcExpr, TcTauType, LIE) -- Same thing, but instantiated; tau-type returned
120 tcPolyExpr arg expected_arg_ty
121 = -- Ha! The argument type of the function is a for-all type,
122 -- An example of rank-2 polymorphism.
124 -- To ensure that the forall'd type variables don't get unified with each
125 -- other or any other types, we make fresh copy of the alleged type
126 tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
128 (sig_theta, sig_tau) = splitRhoTy sig_rho
130 -- Type-check the arg and unify with expected type
131 tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
133 -- Check that the sig_tyvars havn't been constrained
134 -- The interesting bit here is that we must include the free variables
135 -- of the expected arg ty. Here's an example:
136 -- runST (newVar True)
137 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
138 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
139 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
140 -- So now s' isn't unconstrained because it's linked to a.
141 -- Conclusion: include the free vars of the expected arg type in the
142 -- list of "free vars" for the signature check.
144 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
145 tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $
147 checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
149 newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
150 -- ToDo: better origin
152 (text "the type signature of an expression")
153 (mkVarSet zonked_sig_tyvars)
154 sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
157 -- This HsLet binds any Insts which came out of the simplification.
158 -- It's a bit out of place here, but using AbsBind involves inventing
159 -- a couple of new names which seems worse.
160 generalised_arg = TyLam zonked_sig_tyvars $
165 returnTc ( generalised_arg, free_insts,
166 arg', sig_tau, lie_arg )
168 sig_msg ty = sep [ptext SLIT("In an expression with expected type:"),
172 %************************************************************************
174 \subsection{The TAUT rules for variables}
176 %************************************************************************
179 tcMonoExpr :: RenamedHsExpr -- Expession to type check
180 -> TcTauType -- Expected type (could be a type variable)
181 -> TcM s (TcExpr, LIE)
183 tcMonoExpr (HsVar name) res_ty
184 = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
185 unifyTauTy res_ty id_ty `thenTc_`
187 -- Check that the result type doesn't have any nested for-alls.
188 -- For example, a "build" on its own is no good; it must be
189 -- applied to something.
190 checkTc (isTauTy id_ty)
191 (lurkingRank2Err name id_ty) `thenTc_`
193 returnTc (expr', lie)
196 %************************************************************************
198 \subsection{Literals}
200 %************************************************************************
205 tcMonoExpr (HsLit (HsInt i)) res_ty
206 = newOverloadedLit (LiteralOrigin (HsInt i))
207 (OverloadedIntegral i)
208 res_ty `thenNF_Tc` \ stuff ->
211 tcMonoExpr (HsLit (HsFrac f)) res_ty
212 = newOverloadedLit (LiteralOrigin (HsFrac f))
213 (OverloadedFractional f)
214 res_ty `thenNF_Tc` \ stuff ->
218 tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
219 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
220 newDicts (LitLitOrigin (_UNPK_ s))
221 [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
222 returnTc (HsLitOut lit res_ty, dicts)
228 tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty
229 = unifyTauTy res_ty charPrimTy `thenTc_`
230 returnTc (HsLitOut lit charPrimTy, emptyLIE)
232 tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty
233 = unifyTauTy res_ty addrPrimTy `thenTc_`
234 returnTc (HsLitOut lit addrPrimTy, emptyLIE)
236 tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty
237 = unifyTauTy res_ty intPrimTy `thenTc_`
238 returnTc (HsLitOut lit intPrimTy, emptyLIE)
240 tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty
241 = unifyTauTy res_ty floatPrimTy `thenTc_`
242 returnTc (HsLitOut lit floatPrimTy, emptyLIE)
244 tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty
245 = unifyTauTy res_ty doublePrimTy `thenTc_`
246 returnTc (HsLitOut lit doublePrimTy, emptyLIE)
249 Unoverloaded literals:
252 tcMonoExpr (HsLit lit@(HsChar c)) res_ty
253 = unifyTauTy res_ty charTy `thenTc_`
254 returnTc (HsLitOut lit charTy, emptyLIE)
256 tcMonoExpr (HsLit lit@(HsString str)) res_ty
257 = unifyTauTy res_ty stringTy `thenTc_`
258 returnTc (HsLitOut lit stringTy, emptyLIE)
261 %************************************************************************
263 \subsection{Other expression forms}
265 %************************************************************************
268 tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
269 = tcMonoExpr expr res_ty
271 -- perform the negate *before* overloading the integer, since the case
272 -- of minBound on Ints fails otherwise. Could be done elsewhere, but
273 -- convenient to do it here.
275 tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty
276 = tcMonoExpr (HsLit (HsInt (-i))) res_ty
278 tcMonoExpr (NegApp expr neg) res_ty
279 = tcMonoExpr (HsApp neg expr) res_ty
281 tcMonoExpr (HsLam match) res_ty
282 = tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
283 returnTc (HsLam match', lie)
285 tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
287 accum (HsApp e1 e2) args = accum e1 (e2:args)
289 = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
290 returnTc (foldl HsApp fun' args', lie)
292 -- equivalent to (op e1) e2:
293 tcMonoExpr (OpApp arg1 op fix arg2) res_ty
294 = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
295 returnTc (OpApp arg1' op' fix arg2', lie)
298 Note that the operators in sections are expected to be binary, and
299 a type error will occur if they aren't.
302 -- Left sections, equivalent to
309 tcMonoExpr in_expr@(SectionL arg op) res_ty
310 = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
312 -- Check that res_ty is a function type
313 -- Without this check we barf in the desugarer on
315 -- because it tries to desugar to
316 -- f op = \r -> 3 op r
317 -- so (3 `op`) had better be a function!
318 tcAddErrCtxt (sectionLAppCtxt in_expr) $
319 unifyFunTy res_ty `thenTc_`
321 returnTc (SectionL arg' op', lie)
323 -- Right sections, equivalent to \ x -> x op expr, or
326 tcMonoExpr in_expr@(SectionR op expr) res_ty
327 = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
328 tcAddErrCtxt (sectionRAppCtxt in_expr) $
329 split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
330 tcMonoExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
331 unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
332 returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
335 The interesting thing about @ccall@ is that it is just a template
336 which we instantiate by filling in details about the types of its
337 argument and result (ie minimal typechecking is performed). So, the
338 basic story is that we allocate a load of type variables (to hold the
339 arg/result types); unify them with the args/result; and store them for
343 tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
344 = -- Get the callable and returnable classes.
345 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
346 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
347 tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
349 new_arg_dict (arg, arg_ty)
350 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
351 [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
352 returnNF_Tc arg_dicts -- Actually a singleton bag
354 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
358 let n_args = length args
359 tv_idxs | n_args == 0 = []
360 | otherwise = [1..n_args]
362 mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys ->
363 tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
365 -- The argument types can be unboxed or boxed; the result
366 -- type must, however, be boxed since it's an argument to the IO
368 newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
370 io_result_ty = mkTyConApp ioTyCon [result_ty]
371 [ioDataCon] = tyConDataCons ioTyCon
373 unifyTauTy res_ty io_result_ty `thenTc_`
375 -- Construct the extra insts, which encode the
376 -- constraints on the argument and result types.
377 mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
378 newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
379 returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
380 (CCall lbl args' may_gc is_asm result_ty),
381 -- do the wrapping in the newtype constructor here
382 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
386 tcMonoExpr (HsSCC lbl expr) res_ty
387 = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
388 returnTc (HsSCC lbl expr', lie)
390 tcMonoExpr (HsLet binds expr) res_ty
393 binds -- Bindings to check
394 tc_expr `thenTc` \ (expr', lie) ->
395 returnTc (expr', lie)
397 tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
398 returnTc (expr', lie)
399 combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
401 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
402 = tcAddSrcLoc src_loc $
403 tcAddErrCtxt (caseCtxt in_expr) $
405 -- Typecheck the case alternatives first.
406 -- The case patterns tend to give good type info to use
407 -- when typechecking the scrutinee. For example
410 -- will report that map is applied to too few arguments
412 -- Not only that, but it's better to check the matches on their
413 -- own, so that we get the expected results for scoped type variables.
415 -- (p::a, q::b) -> (q,p)
416 -- The above should work: the match (p,q) -> (q,p) is polymorphic as
417 -- claimed by the pattern signatures. But if we typechecked the
418 -- match with x in scope and x's type as the expected type, we'd be hosed.
420 tcMatchesCase matches res_ty `thenTc` \ (scrut_ty, matches', lie2) ->
422 tcAddErrCtxt (caseScrutCtxt scrut) (
423 tcMonoExpr scrut scrut_ty
424 ) `thenTc` \ (scrut',lie1) ->
426 returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
428 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
429 = tcAddSrcLoc src_loc $
430 tcAddErrCtxt (predCtxt pred) (
431 tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
433 tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) ->
434 tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) ->
435 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
439 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
440 = tcDoStmts do_or_lc stmts src_loc res_ty
444 tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
445 = unifyListTy res_ty `thenTc` \ elt_ty ->
446 mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
447 returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
450 = tcAddErrCtxt (listCtxt expr) $
451 tcMonoExpr expr elt_ty
453 tcMonoExpr (ExplicitTuple exprs boxed) res_ty
455 then unifyTupleTy (length exprs) res_ty
456 else unifyUnboxedTupleTy (length exprs) res_ty
457 ) `thenTc` \ arg_tys ->
458 mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
459 (exprs `zip` arg_tys) -- we know they're of equal length.
460 `thenTc` \ (exprs', lies) ->
461 returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
463 tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
464 = tcAddErrCtxt (recordConCtxt expr) $
465 tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
467 (_, record_ty) = splitFunTys con_tau
469 -- Con is syntactically constrained to be a data constructor
470 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
471 unifyTauTy res_ty record_ty `thenTc_`
473 -- Check that the record bindings match the constructor
474 tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
476 bad_fields = badFields rbinds data_con
478 if not (null bad_fields) then
479 mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
480 failTc -- Fail now, because tcRecordBinds will crash on a bad field
483 -- Typecheck the record bindings
484 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
487 missing_s_fields = missingStrictFields rbinds data_con
489 checkTcM (null missing_s_fields)
490 (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
491 returnNF_Tc ()) `thenNF_Tc_`
493 missing_fields = missingFields rbinds data_con
495 checkTcM (not (opt_WarnMissingFields && not (null missing_fields)))
496 (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
497 returnNF_Tc ()) `thenNF_Tc_`
499 returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
501 -- The main complication with RecordUpd is that we need to explicitly
502 -- handle the *non-updated* fields. Consider:
504 -- data T a b = MkT1 { fa :: a, fb :: b }
505 -- | MkT2 { fa :: a, fc :: Int -> Int }
506 -- | MkT3 { fd :: a }
508 -- upd :: T a b -> c -> T a c
509 -- upd t x = t { fb = x}
511 -- The type signature on upd is correct (i.e. the result should not be (T a b))
512 -- because upd should be equivalent to:
514 -- upd t x = case t of
515 -- MkT1 p q -> MkT1 p x
516 -- MkT2 a b -> MkT2 p b
517 -- MkT3 d -> error ...
519 -- So we need to give a completely fresh type to the result record,
520 -- and then constrain it by the fields that are *not* updated ("p" above).
522 -- Note that because MkT3 doesn't contain all the fields being updated,
523 -- its RHS is simply an error, so it doesn't impose any type constraints
525 -- All this is done in STEP 4 below.
527 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
528 = tcAddErrCtxt (recordUpdCtxt expr) $
531 -- Check that the field names are really field names
532 ASSERT( not (null rbinds) )
534 field_names = [field_name | (field_name, _, _) <- rbinds]
536 mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
538 bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
541 Just sel_id -> not (isRecordSelector sel_id)
544 mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
545 if not (null bad_guys) then
550 -- Figure out the tycon and data cons from the first field name
552 (Just sel_id : _) = maybe_sel_ids
553 (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
554 splitForAllTys (idType sel_id)
555 Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
556 (tycon, _, data_cons) = splitAlgTyConApp data_ty
557 (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
559 tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
562 -- Check that at least one constructor has all the named fields
563 -- i.e. has an empty set of bad fields returned by badFields
564 checkTc (any (null . badFields rbinds) data_cons)
565 (badFieldsUpd rbinds) `thenTc_`
568 -- Typecheck the update bindings.
569 -- (Do this after checking for bad fields in case there's a field that
570 -- doesn't match the constructor.)
572 result_record_ty = mkTyConApp tycon result_inst_tys
574 unifyTauTy res_ty result_record_ty `thenTc_`
575 tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
578 -- Use the un-updated fields to find a vector of booleans saying
579 -- which type arguments must be the same in updatee and result.
581 -- WARNING: this code assumes that all data_cons in a common tycon
582 -- have FieldLabels abstracted over the same tyvars.
584 upd_field_lbls = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
585 con_field_lbls_s = map dataConFieldLabels data_cons
587 -- A constructor is only relevant to this process if
588 -- it contains all the fields that are being updated
589 relevant_field_lbls_s = filter is_relevant con_field_lbls_s
590 is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
592 non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
593 common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
595 mk_inst_ty (tyvar, result_inst_ty)
596 | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
597 | otherwise = newTyVarTy boxedTypeKind -- Fresh type
599 mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
602 -- Typecheck the expression to be updated
604 record_ty = mkTyConApp tycon inst_tys
606 tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
609 -- Figure out the LIE we need. We have to generate some
610 -- dictionaries for the data type context, since we are going to
611 -- do some construction.
613 -- What dictionaries do we need? For the moment we assume that all
614 -- data constructors have the same context, and grab it from the first
615 -- constructor. If they have varying contexts then we'd have to
616 -- union the ones that could participate in the update.
618 (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
619 inst_env = mkTopTyVarSubst tyvars result_inst_tys
620 theta' = substTheta inst_env theta
622 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
625 returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
626 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
628 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
629 = unifyListTy res_ty `thenTc` \ elt_ty ->
630 tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
632 tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
633 newMethod (ArithSeqOrigin seq)
634 sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
636 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
639 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) 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 tcLookupValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
645 newMethod (ArithSeqOrigin seq)
646 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
648 returnTc (ArithSeqOut (HsVar enum_from_then_id)
649 (FromThen expr1' expr2'),
650 lie1 `plusLIE` lie2 `plusLIE` lie3)
652 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
653 = tcAddErrCtxt (arithSeqCtxt in_expr) $
654 unifyListTy res_ty `thenTc` \ elt_ty ->
655 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
656 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
657 tcLookupValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
658 newMethod (ArithSeqOrigin seq)
659 sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
661 returnTc (ArithSeqOut (HsVar enum_from_to_id)
662 (FromTo expr1' expr2'),
663 lie1 `plusLIE` lie2 `plusLIE` lie3)
665 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
666 = tcAddErrCtxt (arithSeqCtxt in_expr) $
667 unifyListTy res_ty `thenTc` \ elt_ty ->
668 tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
669 tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
670 tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
671 tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
672 newMethod (ArithSeqOrigin seq)
673 sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
675 returnTc (ArithSeqOut (HsVar eft_id)
676 (FromThenTo expr1' expr2' expr3'),
677 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
680 %************************************************************************
682 \subsection{Expressions type signatures}
684 %************************************************************************
687 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
688 = tcSetErrCtxt (exprSigCtxt in_expr) $
689 tcHsType poly_ty `thenTc` \ sig_tc_ty ->
691 if not (isForAllTy sig_tc_ty) then
693 unifyTauTy sig_tc_ty res_ty `thenTc_`
694 tcMonoExpr expr sig_tc_ty
696 else -- Signature is polymorphic
697 tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
699 -- Now match the signature type with res_ty.
700 -- We must not do this earlier, because res_ty might well
701 -- mention variables free in the environment, and we'd get
702 -- bogus complaints about not being able to for-all the
704 unifyTauTy res_ty expr_ty `thenTc_`
706 -- If everything is ok, return the stuff unchanged, except for
707 -- the effect of any substutions etc. We simply discard the
708 -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
709 -- resolution it may have done, which is recorded in the
714 Typecheck expression which in most cases will be an Id.
717 tcExpr_id :: RenamedHsExpr
723 HsVar name -> tcId name `thenNF_Tc` \ stuff ->
725 other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty ->
726 tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
727 returnTc (id_expr', lie_id, id_ty)
730 %************************************************************************
732 \subsection{@tcApp@ typchecks an application}
734 %************************************************************************
738 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
739 -> TcType -- Expected result type of application
740 -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
743 tcApp fun args res_ty
744 = -- First type-check the function
745 tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
747 tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
748 split_fun_ty fun_ty (length args)
749 ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
751 -- Unify with expected result before type-checking the args
752 -- This is when we might detect a too-few args situation
753 tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
754 unifyTauTy res_ty actual_result_ty
757 -- Now typecheck the args
758 mapAndUnzipTc (tcArg fun)
759 (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
761 -- Check that the result type doesn't have any nested for-alls.
762 -- For example, a "build" on its own is no good; it must be applied to something.
763 checkTc (isTauTy actual_result_ty)
764 (lurkingRank2Err fun fun_ty) `thenTc_`
766 returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
769 -- If an error happens we try to figure out whether the
770 -- function has been given too many or too few arguments,
772 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
773 = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
774 zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
776 (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
777 (env2, act_ty'') = tidyOpenType env1 act_ty'
778 (exp_args, _) = splitFunTys exp_ty''
779 (act_args, _) = splitFunTys act_ty''
781 message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
782 | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
783 | otherwise = appCtxt fun args
785 returnNF_Tc (env2, message)
788 split_fun_ty :: TcType -- The type of the function
789 -> Int -- Number of arguments
790 -> TcM s ([TcType], -- Function argument types
791 TcType) -- Function result types
793 split_fun_ty fun_ty 0
794 = returnTc ([], fun_ty)
796 split_fun_ty fun_ty n
797 = -- Expect the function to have type A->B
798 unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
799 split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
800 returnTc (arg_ty:arg_tys, final_res_ty)
804 tcArg :: RenamedHsExpr -- The function (for error messages)
805 -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type
806 -> TcM s (TcExpr, LIE) -- Resulting argument and LIE
808 tcArg the_fun (arg, expected_arg_ty, arg_no)
809 = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
810 tcExpr arg expected_arg_ty
814 %************************************************************************
816 \subsection{@tcId@ typchecks an identifier occurrence}
818 %************************************************************************
820 Between the renamer and the first invocation of the UsageSP inference,
821 identifiers read from interface files will have usage information in
822 their types, whereas other identifiers will not. The unannotTy here
823 in @tcId@ prevents this information from pointlessly propagating
824 further prior to the first usage inference.
827 tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
830 = -- Look up the Id and instantiate its type
831 tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
834 Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
836 Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
837 tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
838 instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
841 -- The instantiate_it loop runs round instantiating the Id.
842 -- It has to be a loop because we are now prepared to entertain
844 -- f:: forall a. Eq a => forall b. Baz b => tau
845 -- We want to instantiate this to
846 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
847 instantiate_it orig fun ty
848 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
849 tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
850 instantiate_it2 orig fun tyvars theta tau
852 instantiate_it2 orig fun tyvars theta tau
853 = if null theta then -- Is it overloaded?
854 returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
856 -- Yes, it's overloaded
857 instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
858 instantiate_it orig fun' tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
859 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
862 arg_tys = mkTyVarTys tyvars
865 %************************************************************************
867 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
869 %************************************************************************
872 tcDoStmts do_or_lc stmts src_loc res_ty
873 = -- get the Monad and MonadZero classes
874 -- create type consisting of a fresh monad tyvar
875 ASSERT( not (null stmts) )
876 tcAddSrcLoc src_loc $
878 newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
879 newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
880 unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
882 -- If it's a comprehension we're dealing with,
883 -- force it to be a list comprehension.
884 -- (as of Haskell 98, monad comprehensions are no more.)
886 ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
887 _ -> returnTc ()) `thenTc_`
889 tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
891 -- Build the then and zero methods in case we need them
892 -- It's important that "then" and "return" appear just once in the final LIE,
893 -- not only for typechecker efficiency, but also because otherwise during
894 -- simplification we end up with silly stuff like
895 -- then = case d of (t,r) -> t
897 -- where the second "then" sees that it already exists in the "available" stuff.
899 tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
900 tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
901 tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
902 newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
903 newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
904 newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
906 monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
908 returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
909 stmts_lie `plusLIE` monad_lie)
913 %************************************************************************
915 \subsection{Record bindings}
917 %************************************************************************
919 Game plan for record bindings
920 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
923 1. look up "field", to find its selector Id, which must have type
924 forall a1..an. T a1 .. an -> tau
925 where tau is the type of the field.
927 2. Instantiate this type
929 3. Unify the (T a1 .. an) part with the "expected result type", which
930 is passed in. This checks that all the field labels come from the
933 4. Type check the value using tcArg, passing tau as the expected
936 This extends OK when the field types are universally quantified.
938 Actually, to save excessive creation of fresh type variables,
943 :: TcType -- Expected type of whole record
944 -> RenamedRecordBinds
945 -> TcM s (TcRecordBinds, LIE)
947 tcRecordBinds expected_record_ty rbinds
948 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
949 returnTc (rbinds', plusLIEs lies)
951 do_bind (field_label, rhs, pun_flag)
952 = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
953 ASSERT( isRecordSelector sel_id )
954 -- This lookup and assertion will surely succeed, because
955 -- we check that the fields are indeed record selectors
956 -- before calling tcRecordBinds
958 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
960 -- Record selectors all have type
961 -- forall a1..an. T a1 .. an -> tau
962 ASSERT( maybeToBool (splitFunTy_maybe tau) )
964 -- Selector must have type RecordType -> FieldType
965 Just (record_ty, field_ty) = splitFunTy_maybe tau
967 unifyTauTy expected_record_ty record_ty `thenTc_`
968 tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
969 returnTc ((sel_id, rhs', pun_flag), lie)
971 badFields rbinds data_con
972 = [field_name | (field_name, _, _) <- rbinds,
973 not (field_name `elem` field_names)
976 field_names = map fieldLabelName (dataConFieldLabels data_con)
978 missingStrictFields rbinds data_con
979 = [ fn | fn <- strict_field_names,
980 not (fn `elem` field_names_used)
983 field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
984 strict_field_names = mapMaybe isStrict field_info
986 isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
989 field_info = zip (dataConFieldLabels data_con)
990 (dataConStrictMarks data_con)
992 missingFields rbinds data_con
993 = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
995 field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
997 -- missing strict fields have already been flagged as
998 -- being so, so leave them out here.
999 non_strict_field_names = mapMaybe isn'tStrict field_info
1001 isn'tStrict (fl, MarkedStrict) = Nothing
1002 isn'tStrict (fl, _) = Just (fieldLabelName fl)
1004 field_info = zip (dataConFieldLabels data_con)
1005 (dataConStrictMarks data_con)
1009 %************************************************************************
1011 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
1013 %************************************************************************
1016 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
1018 tcMonoExprs [] [] = returnTc ([], emptyLIE)
1019 tcMonoExprs (expr:exprs) (ty:tys)
1020 = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
1021 tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
1022 returnTc (expr':exprs', lie1 `plusLIE` lie2)
1026 % =================================================
1033 pp_nest_hang :: String -> SDoc -> SDoc
1034 pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
1037 Boring and alphabetical:
1040 = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1043 = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1046 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1049 = hang (ptext SLIT("In an expression with a type signature:"))
1053 = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1056 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1058 sectionRAppCtxt expr
1059 = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1061 sectionLAppCtxt expr
1062 = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1064 funAppCtxt fun arg arg_no
1065 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1066 quotes (ppr fun) <> text ", namely"])
1067 4 (quotes (ppr arg))
1069 wrongArgsCtxt too_many_or_few fun args
1070 = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1071 <+> ptext SLIT("is applied to") <+> text too_many_or_few
1072 <+> ptext SLIT("arguments in the call"))
1073 4 (parens (ppr the_app))
1075 the_app = foldl HsApp fun args -- Used in error messages
1078 = ptext SLIT("In the application") <+> quotes (ppr the_app)
1080 the_app = foldl HsApp fun args -- Used in error messages
1082 lurkingRank2Err fun fun_ty
1083 = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1084 4 (vcat [ptext SLIT("It is applied to too few arguments"),
1085 ptext SLIT("so that the result type has for-alls in it")])
1087 rank2ArgCtxt arg expected_arg_ty
1088 = ptext SLIT("In a polymorphic function argument:") <+> ppr arg
1091 = hang (ptext SLIT("No constructor has all these fields:"))
1092 4 (pprQuotedList fields)
1094 fields = [field | (field, _, _) <- rbinds]
1096 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1097 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1100 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1102 illegalCcallTyErr isArg ty
1103 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
1107 | isArg = ptext SLIT("argument")
1108 | otherwise = ptext SLIT("result")
1111 missingStrictFieldCon :: Name -> Name -> SDoc
1112 missingStrictFieldCon con field
1113 = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1114 ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1116 missingFieldCon :: Name -> Name -> SDoc
1117 missingFieldCon con field
1118 = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1119 ptext SLIT("is not initialised")]