2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcExpr]{Typecheck an expression}
7 module TcExpr ( tcPolyExpr, tcPolyExprNC,
8 tcMonoExpr, tcInferRho, tcSyntaxOp ) where
10 #include "HsVersions.h"
12 #ifdef GHCI /* Only if bootstrapped */
13 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
14 import HsSyn ( nlHsVar )
15 import Id ( Id, idName )
16 import Name ( isExternalName )
17 import TcType ( isTauTy )
18 import TcEnv ( checkWellStaged )
19 import HsSyn ( nlHsApp )
20 import qualified DsMeta
23 import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
24 HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs,
26 import TcHsSyn ( hsLitType )
28 import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
29 boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
31 import BasicTypes ( Arity, isMarkedStrict )
32 import Inst ( newMethodFromName, newIPDict, instCall,
33 newMethodWithGivenTy, instStupidTheta )
34 import TcBinds ( tcLocalBinds )
35 import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 )
36 import TcArrows ( tcProc )
37 import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
39 import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
40 import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
41 import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
42 readFilledBox, zonkTcTypes )
43 import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst,
44 BoxySigmaType, BoxyRhoType, ThetaType,
46 tcMultiSplitSigmaTy, tcSplitFunTysN,
47 tcSplitTyConApp_maybe,
48 isSigmaTy, mkFunTy, mkTyConApp,
49 exactTyVarsOfType, exactTyVarsOfTypes,
50 zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
52 import {- Kind parts of -}
55 import Id ( idType, recordSelectorFieldLabel,
56 isRecordSelector, isNaughtyRecordSelector,
58 import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
60 dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
63 import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons,
65 import Type ( substTheta, substTy )
66 import Var ( TyVar, tyVarKind )
67 import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
68 import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
69 import PrelNames ( enumFromName, enumFromThenName,
70 enumFromToName, enumFromThenToName,
71 enumFromToPName, enumFromThenToPName, negateName,
74 import PrimOp ( tagToEnumKey )
77 import StaticFlags ( opt_NoMethodSharing )
78 import HscTypes ( TyThing(..) )
79 import SrcLoc ( Located(..), unLoc )
81 import ListSetOps ( assocMaybe )
82 import Maybes ( catMaybes )
87 import TyCon ( tyConArity )
91 %************************************************************************
93 \subsection{Main wrappers}
95 %************************************************************************
98 tcPolyExpr, tcPolyExprNC
99 :: LHsExpr Name -- Expession to type check
100 -> BoxySigmaType -- Expected type (could be a polytpye)
101 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
103 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
104 -- to add context information.
105 -- The NC version does not do so, usually because the caller wants
108 tcPolyExpr expr res_ty
109 = addErrCtxt (exprCtxt (unLoc expr)) $
110 tcPolyExprNC expr res_ty
112 tcPolyExprNC expr res_ty
114 = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
115 -- Note the recursive call to tcPolyExpr, because the
116 -- type may have multiple layers of for-alls
117 ; return (mkLHsWrap gen_fn expr') }
120 = tcMonoExpr expr res_ty
123 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
124 tcPolyExprs [] [] = returnM []
125 tcPolyExprs (expr:exprs) (ty:tys)
126 = do { expr' <- tcPolyExpr expr ty
127 ; exprs' <- tcPolyExprs exprs tys
128 ; returnM (expr':exprs') }
129 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
132 tcMonoExpr :: LHsExpr Name -- Expression to type check
133 -> BoxyRhoType -- Expected type (could be a type variable)
134 -- Definitely no foralls at the top
135 -- Can contain boxes, which will be filled in
136 -> TcM (LHsExpr TcId)
138 tcMonoExpr (L loc expr) res_ty
139 = ASSERT( not (isSigmaTy res_ty) )
141 do { expr' <- tcExpr expr res_ty
142 ; return (L loc expr') }
145 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
146 tcInferRho expr = tcInfer (tcMonoExpr expr)
151 %************************************************************************
153 tcExpr: the main expression typechecker
155 %************************************************************************
158 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
159 tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
161 tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty
162 ; return (HsLit lit) }
164 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
165 ; return (HsPar expr') }
167 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
168 ; returnM (HsSCC lbl expr') }
170 tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
171 = do { expr' <- tcMonoExpr expr res_ty
172 ; return (HsCoreAnn lbl expr') }
174 tcExpr (HsOverLit lit) res_ty
175 = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
176 ; return (HsOverLit lit') }
178 tcExpr (NegApp expr neg_expr) res_ty
179 = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
180 (mkFunTy res_ty res_ty)
181 ; expr' <- tcMonoExpr expr res_ty
182 ; return (NegApp expr' neg_expr') }
184 tcExpr (HsIPVar ip) res_ty
185 = do { -- Implicit parameters must have a *tau-type* not a
186 -- type scheme. We enforce this by creating a fresh
187 -- type variable as its type. (Because res_ty may not
189 ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
190 ; co_fn <- tcSubExp ip_ty res_ty
191 ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
193 ; return (mkHsWrap co_fn (HsIPVar ip')) }
195 tcExpr (HsApp e1 e2) res_ty
198 go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
199 go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
200 go lfun@(L loc fun) args
201 = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
202 tcApp fun (length args) (tcArgs lfun args) res_ty
203 ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
205 tcExpr (HsLam match) res_ty
206 = do { (co_fn, match') <- tcMatchLambda match res_ty
207 ; return (mkHsWrap co_fn (HsLam match')) }
209 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
210 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
212 -- Remember to extend the lexical type-variable environment
213 ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
214 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
215 tcPolyExprNC expr res_ty)
217 ; co_fn <- tcSubExp sig_tc_ty res_ty
218 ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
220 tcExpr (HsType ty) res_ty
221 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
222 -- This is the syntax for type applications that I was planning
223 -- but there are difficulties (e.g. what order for type args)
224 -- so it's not enabled yet.
225 -- Can't eliminate it altogether from the parser, because the
226 -- same parser parses *patterns*.
230 %************************************************************************
232 Infix operators and sections
234 %************************************************************************
237 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
238 = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
239 ; return (OpApp arg1' (L loc op') fix arg2') }
241 -- Left sections, equivalent to
248 -- We treat it as similar to the latter, so we don't
249 -- actually require the function to take two arguments
250 -- at all. For example, (x `not`) means (not x);
251 -- you get postfix operators! Not really Haskell 98
252 -- I suppose, but it's less work and kind of useful.
254 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
255 = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
256 ; return (SectionL arg1' (L loc op')) }
258 -- Right sections, equivalent to \ x -> x `op` expr, or
261 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
262 = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
263 tcApp op 2 (tc_args arg1_ty') res_ty'
264 ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
266 doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
267 <+> ptext SLIT("takes one argument")
268 tc_args arg1_ty' [arg1_ty, arg2_ty]
269 = do { boxyUnify arg1_ty' arg1_ty
270 ; tcArg lop (arg2, arg2_ty, 2) }
271 tc_args arg1_ty' other = panic "tcExpr SectionR"
275 tcExpr (HsLet binds expr) res_ty
276 = do { (binds', expr') <- tcLocalBinds binds $
277 tcMonoExpr expr res_ty
278 ; return (HsLet binds' expr') }
280 tcExpr (HsCase scrut matches) exp_ty
281 = do { -- We used to typecheck the case alternatives first.
282 -- The case patterns tend to give good type info to use
283 -- when typechecking the scrutinee. For example
286 -- will report that map is applied to too few arguments
288 -- But now, in the GADT world, we need to typecheck the scrutinee
289 -- first, to get type info that may be refined in the case alternatives
290 (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
293 ; traceTc (text "HsCase" <+> ppr scrut_ty)
294 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
295 ; return (HsCase scrut' matches') }
297 match_ctxt = MC { mc_what = CaseAlt,
300 tcExpr (HsIf pred b1 b2) res_ty
301 = do { pred' <- addErrCtxt (predCtxt pred) $
302 tcMonoExpr pred boolTy
303 ; b1' <- tcMonoExpr b1 res_ty
304 ; b2' <- tcMonoExpr b2 res_ty
305 ; return (HsIf pred' b1' b2') }
307 tcExpr (HsDo do_or_lc stmts body _) res_ty
308 = tcDoStmts do_or_lc stmts body res_ty
310 tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
311 = do { elt_ty <- boxySplitListTy res_ty
312 ; exprs' <- mappM (tc_elt elt_ty) exprs
313 ; return (ExplicitList elt_ty exprs') }
315 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
317 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
318 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
319 ; exprs' <- mappM (tc_elt elt_ty) exprs
320 ; ifM (null exprs) (zapToMonotype elt_ty)
321 -- If there are no expressions in the comprehension
322 -- we must still fill in the box
323 -- (Not needed for [] and () becuase they happen
324 -- to parse as data constructors.)
325 ; return (ExplicitPArr elt_ty exprs') }
327 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
329 tcExpr (ExplicitTuple exprs boxity) res_ty
330 = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
331 ; exprs' <- tcPolyExprs exprs arg_tys
332 ; return (ExplicitTuple exprs' boxity) }
334 tcExpr (HsProc pat cmd) res_ty
335 = do { (pat', cmd') <- tcProc pat cmd res_ty
336 ; return (HsProc pat' cmd') }
338 tcExpr e@(HsArrApp _ _ _ _ _) _
339 = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
340 ptext SLIT("was found where an expression was expected")])
342 tcExpr e@(HsArrForm _ _ _) _
343 = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
344 ptext SLIT("was found where an expression was expected")])
347 %************************************************************************
349 Record construction and update
351 %************************************************************************
354 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
355 = do { data_con <- tcLookupDataCon con_name
357 -- Check for missing fields
358 ; checkMissingFields data_con rbinds
360 ; let arity = dataConSourceArity data_con
362 = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds
365 -- The unBox ensures that all the boxes in arg_tys are indeed
366 -- filled, which is the invariant expected by tcIdApp
368 ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
370 ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
372 -- The main complication with RecordUpd is that we need to explicitly
373 -- handle the *non-updated* fields. Consider:
375 -- data T a b = MkT1 { fa :: a, fb :: b }
376 -- | MkT2 { fa :: a, fc :: Int -> Int }
377 -- | MkT3 { fd :: a }
379 -- upd :: T a b -> c -> T a c
380 -- upd t x = t { fb = x}
382 -- The type signature on upd is correct (i.e. the result should not be (T a b))
383 -- because upd should be equivalent to:
385 -- upd t x = case t of
386 -- MkT1 p q -> MkT1 p x
387 -- MkT2 a b -> MkT2 p b
388 -- MkT3 d -> error ...
390 -- So we need to give a completely fresh type to the result record,
391 -- and then constrain it by the fields that are *not* updated ("p" above).
393 -- Note that because MkT3 doesn't contain all the fields being updated,
394 -- its RHS is simply an error, so it doesn't impose any type constraints
396 -- All this is done in STEP 4 below.
400 -- For record update we require that every constructor involved in the
401 -- update (i.e. that has all the specified fields) is "vanilla". I
402 -- don't know how to do the update otherwise.
405 tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
407 -- Check that the field names are really field names
408 ASSERT( notNull rbinds )
410 field_names = map fst rbinds
412 mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
413 -- The renamer has already checked that they
416 bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
417 | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
418 not (isRecordSelector sel_id) -- Excludes class ops
421 checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
424 -- Figure out the tycon and data cons from the first field name
426 -- It's OK to use the non-tc splitters here (for a selector)
427 upd_field_lbls = recBindFields rbinds
429 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
430 data_cons = tyConDataCons tycon -- it's not a field label
431 relevant_cons = filter is_relevant data_cons
432 is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
436 -- Check that at least one constructor has all the named fields
437 -- i.e. has an empty set of bad fields returned by badFields
438 checkTc (not (null relevant_cons))
439 (badFieldsUpd rbinds) `thenM_`
441 -- Check that all relevant data cons are vanilla. Doing record updates on
442 -- GADTs and/or existentials is more than my tiny brain can cope with today
443 checkTc (all isVanillaDataCon relevant_cons)
444 (nonVanillaUpd tycon) `thenM_`
447 -- Use the un-updated fields to find a vector of booleans saying
448 -- which type arguments must be the same in updatee and result.
450 -- WARNING: this code assumes that all data_cons in a common tycon
451 -- have FieldLabels abstracted over the same tyvars.
453 -- A constructor is only relevant to this process if
454 -- it contains *all* the fields that are being updated
455 con1 = head relevant_cons -- A representative constructor
456 con1_tyvars = dataConUnivTyVars con1
457 con1_flds = dataConFieldLabels con1
458 con1_arg_tys = dataConOrigArgTys con1
459 common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
460 , not (fld `elem` upd_field_lbls) ]
462 is_common_tv tv = tv `elemVarSet` common_tyvars
464 mk_inst_ty tv result_inst_ty
465 | is_common_tv tv = returnM result_inst_ty -- Same as result type
466 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
468 tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
469 zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
472 -- Typecheck the update bindings.
473 -- (Do this after checking for bad fields in case there's a field that
474 -- doesn't match the constructor.)
476 result_record_ty = mkTyConApp tycon result_inst_tys
477 con1_arg_tys' = map (substTy inst_env) con1_arg_tys
479 tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
480 tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
483 -- Typecheck the expression to be updated
485 record_ty = ASSERT( length inst_tys == tyConArity tycon )
486 mkTyConApp tycon inst_tys
487 -- This is one place where the isVanilla check is important
488 -- So that inst_tys matches the tycon
490 tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
493 -- Figure out the LIE we need. We have to generate some
494 -- dictionaries for the data type context, since we are going to
495 -- do pattern matching over the data cons.
497 -- What dictionaries do we need? The tyConStupidTheta tells us.
499 theta' = substTheta inst_env (tyConStupidTheta tycon)
501 instStupidTheta RecordUpdOrigin theta' `thenM_`
504 returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
508 %************************************************************************
510 Arithmetic sequences e.g. [a,b..]
511 and their parallel-array counterparts e.g. [: a,b.. :]
514 %************************************************************************
517 tcExpr (ArithSeq _ seq@(From expr)) res_ty
518 = do { elt_ty <- boxySplitListTy res_ty
519 ; expr' <- tcPolyExpr expr elt_ty
520 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
522 ; return (ArithSeq (HsVar enum_from) (From expr')) }
524 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
525 = do { elt_ty <- boxySplitListTy res_ty
526 ; expr1' <- tcPolyExpr expr1 elt_ty
527 ; expr2' <- tcPolyExpr expr2 elt_ty
528 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
529 elt_ty enumFromThenName
530 ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
533 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
534 = do { elt_ty <- boxySplitListTy res_ty
535 ; expr1' <- tcPolyExpr expr1 elt_ty
536 ; expr2' <- tcPolyExpr expr2 elt_ty
537 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
538 elt_ty enumFromToName
539 ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
541 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
542 = do { elt_ty <- boxySplitListTy res_ty
543 ; expr1' <- tcPolyExpr expr1 elt_ty
544 ; expr2' <- tcPolyExpr expr2 elt_ty
545 ; expr3' <- tcPolyExpr expr3 elt_ty
546 ; eft <- newMethodFromName (ArithSeqOrigin seq)
547 elt_ty enumFromThenToName
548 ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
550 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
551 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
552 ; expr1' <- tcPolyExpr expr1 elt_ty
553 ; expr2' <- tcPolyExpr expr2 elt_ty
554 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
555 elt_ty enumFromToPName
556 ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
558 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
559 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
560 ; expr1' <- tcPolyExpr expr1 elt_ty
561 ; expr2' <- tcPolyExpr expr2 elt_ty
562 ; expr3' <- tcPolyExpr expr3 elt_ty
563 ; eft <- newMethodFromName (PArrSeqOrigin seq)
564 elt_ty enumFromThenToPName
565 ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
567 tcExpr (PArrSeq _ _) _
568 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
569 -- the parser shouldn't have generated it and the renamer shouldn't have
574 %************************************************************************
578 %************************************************************************
581 #ifdef GHCI /* Only if bootstrapped */
582 -- Rename excludes these cases otherwise
583 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
584 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
590 %************************************************************************
594 %************************************************************************
597 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
601 %************************************************************************
605 %************************************************************************
608 ---------------------------
609 tcApp :: HsExpr Name -- Function
610 -> Arity -- Number of args reqd
611 -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
612 -> BoxyRhoType -- Result type
613 -> TcM (HsExpr TcId, arg_results)
615 -- (tcFun fun n_args arg_checker res_ty)
616 -- The argument type checker, arg_checker, will be passed exactly n_args types
618 tcApp (HsVar fun_name) n_args arg_checker res_ty
619 = tcIdApp fun_name n_args arg_checker res_ty
621 tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
622 = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
623 ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
624 ; arg_tys' <- mapM readFilledBox arg_boxes
625 ; args' <- arg_checker arg_tys'
626 ; return (fun', args') }
628 ---------------------------
629 tcIdApp :: Name -- Function
630 -> Arity -- Number of args reqd
631 -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
632 -- The arg-checker guarantees to fill all boxes in the arg types
633 -> BoxyRhoType -- Result type
634 -> TcM (HsExpr TcId, arg_results)
636 -- Call (f e1 ... en) :: res_ty
637 -- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
638 -- (where k <= n; fres has the rest)
639 -- NB: if k < n then the function doesn't have enough args, and
640 -- presumably fres is a type variable that we are going to
641 -- instantiate with a function type
643 -- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
645 tcIdApp fun_name n_args arg_checker res_ty
646 = do { let orig = OccurrenceOf fun_name
647 ; (fun, fun_ty) <- lookupFun orig fun_name
649 -- Split up the function type
650 ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
651 (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
653 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
654 arg_qtvs = exactTyVarsOfTypes fun_arg_tys
655 res_qtvs = exactTyVarsOfType fun_res_ty
656 -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app]
657 tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
658 k = length fun_arg_tys -- k <= n_args
659 n_missing_args = n_args - k -- Always >= 0
661 -- Match the result type of the function with the
662 -- result type of the context, to get an inital substitution
663 ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
664 ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
665 res_ty' = mkFunTys extra_arg_tys' res_ty
666 ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
667 ; let arg_subst = zipOpenTvSubst qtvs qtys'
668 fun_arg_tys' = substTys arg_subst fun_arg_tys
670 -- Typecheck the arguments!
671 -- Doing so will fill arg_qtvs and extra_arg_tys'
672 ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
674 -- Strip boxes from the qtvs that have been filled in by the arg checking
675 -- AND any variables that are mentioned in neither arg nor result
676 -- the latter are mentioned only in constraints; stripBoxyType will
677 -- fill them with a monotype
678 ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
679 | otherwise = return qty'
680 ; qtys'' <- zipWithM strip qtvs qtys'
681 ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
683 -- Result subsumption
684 ; let res_subst = zipOpenTvSubst qtvs qtys''
685 fun_res_ty'' = substTy res_subst fun_res_ty
686 res_ty'' = mkFunTys extra_arg_tys'' res_ty
687 ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
689 -- And pack up the results
690 -- By applying the coercion just to the *function* we can make
691 -- tcFun work nicely for OpApp and Sections too
692 ; fun' <- instFun orig fun res_subst tv_theta_prs
693 ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
694 ; return (mkHsWrap co_fn' fun', args') }
697 Note [Silly type synonyms in smart-app]
698 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
699 When we call sripBoxyType, all of the boxes should be filled
700 in. But we need to be careful about type synonyms:
704 In the call (f x) we'll typecheck x, expecting it to have type
705 (T box). Usually that would fill in the box, but in this case not;
706 because 'a' is discarded by the silly type synonym T. So we must
707 use exactTyVarsOfType to figure out which type variables are free
708 in the argument type.
711 -- tcId is a specialisation of tcIdApp when there are no arguments
712 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
717 -> BoxyRhoType -- Result type
719 tcId orig fun_name res_ty
720 = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
721 ; (fun, fun_ty) <- lookupFun orig fun_name
723 -- Split up the function type
724 ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
725 qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
726 tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
727 ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
729 -- Do the subsumption check wrt the result type
730 ; let res_subst = zipTopTvSubst qtvs qtv_tys
731 fun_tau' = substTy res_subst fun_tau
733 ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
735 -- And pack up the results
736 ; fun' <- instFun orig fun res_subst tv_theta_prs
737 ; return (mkHsWrap co_fn fun') }
739 -- Note [Push result type in]
741 -- Unify with expected result before (was: after) type-checking the args
742 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
743 -- This is when we might detect a too-few args situation.
744 -- (One can think of cases when the opposite order would give
745 -- a better error message.)
746 -- [March 2003: I'm experimenting with putting this first. Here's an
747 -- example where it actually makes a real difference
748 -- class C t a b | t a -> b
749 -- instance C Char a Bool
751 -- data P t a = forall b. (C t a b) => MkP b
752 -- data Q t = MkQ (forall a. P t a)
755 -- f1 = MkQ (MkP True)
756 -- f2 = MkQ (MkP True :: forall a. P Char a)
758 -- With the change, f1 will type-check, because the 'Char' info from
759 -- the signature is propagated into MkQ's argument. With the check
760 -- in the other order, the extra signature in f2 is reqd.]
762 ---------------------------
763 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
764 -- Typecheck a syntax operator, checking that it has the specified type
765 -- The operator is always a variable at this stage (i.e. renamer output)
766 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
767 tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
769 ---------------------------
770 instFun :: InstOrigin
772 -> TvSubst -- The instantiating substitution
773 -> [([TyVar], ThetaType)] -- Stuff to instantiate
776 instFun orig fun subst []
777 = return fun -- Common short cut
779 instFun orig fun subst tv_theta_prs
780 = do { let ty_theta_prs' = map subst_pr tv_theta_prs
782 -- Make two ad-hoc checks
783 ; doStupidChecks fun ty_theta_prs'
785 -- Now do normal instantiation
786 ; go True fun ty_theta_prs' }
788 subst_pr (tvs, theta)
789 = (map (substTyVar subst) tvs, substTheta subst theta)
791 go _ fun [] = return fun
793 go True (HsVar fun_id) ((tys,theta) : prs)
794 | want_method_inst theta
795 = do { meth_id <- newMethodWithGivenTy orig fun_id tys
796 ; go False (HsVar meth_id) prs }
797 -- Go round with 'False' to prevent further use
798 -- of newMethod: see Note [Multiple instantiation]
800 go _ fun ((tys, theta) : prs)
801 = do { co_fn <- instCall orig tys theta
802 ; go False (HsWrap co_fn fun) prs }
804 -- See Note [No method sharing]
805 want_method_inst theta = not (null theta) -- Overloaded
806 && not opt_NoMethodSharing
809 Note [Multiple instantiation]
810 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
811 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
812 For example, consider
813 f :: forall a. Eq a => forall b. Ord b => a -> b
814 At a call to f, at say [Int, Bool], it's tempting to translate the call to
818 f_m1 :: forall b. Ord b => Int -> b
822 f_m2 = f_m1 Bool dOrdBool
824 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
825 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
827 But it's entirely possible that f_m2 will continue to float out, because it
828 mentions no type variables. Result, f_m1 isn't in scope.
830 Here's a concrete example that does this (test tc200):
833 f :: Eq b => b -> a -> Int
834 baz :: Eq a => Int -> a -> Int
839 Current solution: only do the "method sharing" thing for the first type/dict
840 application, not for the iterated ones. A horribly subtle point.
842 Note [No method sharing]
843 ~~~~~~~~~~~~~~~~~~~~~~~~
844 The -fno-method-sharing flag controls what happens so far as the LIE
845 is concerned. The default case is that for an overloaded function we
846 generate a "method" Id, and add the Method Inst to the LIE. So you get
849 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
850 If you specify -fno-method-sharing, the dictionary application
851 isn't shared, so we get
853 f = /\a (d:Num a) (x:a) -> (+) a d x x
854 This gets a bit less sharing, but
855 a) it's better for RULEs involving overloaded functions
856 b) perhaps fewer separated lambdas
859 tcArgs :: LHsExpr Name -- The function (for error messages)
860 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
861 -> TcM [LHsExpr TcId] -- Resulting args
863 tcArgs fun args expected_arg_tys
864 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
866 tcArg :: LHsExpr Name -- The function (for error messages)
867 -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type
868 -> TcM (LHsExpr TcId) -- Resulting argument
869 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
876 Nasty check to ensure that tagToEnum# is applied to a type that is an
877 enumeration TyCon. Unification may refine the type later, but this
878 check won't see that, alas. It's crude but it works.
880 Here's are two cases that should fail
882 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
885 g = tagToEnum# 0 -- Int is not an enumeration
889 doStupidChecks :: HsExpr TcId
890 -> [([TcType], ThetaType)]
892 -- Check two tiresome and ad-hoc cases
893 -- (a) the "stupid theta" for a data con; add the constraints
894 -- from the "stupid theta" of a data constructor (sigh)
895 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
897 doStupidChecks (HsVar fun_id) ((tys,_):_)
898 | Just con <- isDataConId_maybe fun_id -- (a)
899 = addDataConStupidTheta con tys
901 | fun_id `hasKey` tagToEnumKey -- (b)
902 = do { tys' <- zonkTcTypes tys
903 ; checkTc (ok tys') (tagToEnumError tys')
907 ok (ty:tys) = case tcSplitTyConApp_maybe ty of
908 Just (tc,_) -> isEnumerationTyCon tc
911 doStupidChecks fun tv_theta_prs
912 = return () -- The common case
916 = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
917 2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
918 ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
920 at_type | null tys = empty -- Probably never happens
921 | otherwise = ptext SLIT("at type") <+> ppr (head tys)
924 %************************************************************************
926 \subsection{@tcId@ typchecks an identifier occurrence}
928 %************************************************************************
931 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
932 lookupFun orig id_name
933 = do { thing <- tcLookup id_name
935 AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
937 wrap_id = dataConWrapId con
940 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
941 | otherwise -> return (HsVar id, idType id)
942 -- A global cannot possibly be ill-staged
943 -- nor does it need the 'lifting' treatment
945 ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
946 -> do { thLocalId orig id ty lvl
948 Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars
949 Just co -> return (mkHsWrap co (HsVar id), ty) }
951 other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
954 #ifndef GHCI /* GHCI and TH is off */
955 --------------------------------------
956 -- thLocalId : Check for cross-stage lifting
957 thLocalId orig id id_ty th_bind_lvl
960 #else /* GHCI and TH is on */
961 thLocalId orig id id_ty th_bind_lvl
962 = do { use_stage <- getStage -- TH case
964 Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
965 -> thBrackId orig id ps_var lie_var
966 other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
970 --------------------------------------
971 thBrackId orig id ps_var lie_var
972 | isExternalName id_name
973 = -- Top-level identifiers in this module,
974 -- (which have External Names)
975 -- are just like the imported case:
976 -- no need for the 'lifting' treatment
977 -- E.g. this is fine:
980 -- But we do need to put f into the keep-alive
981 -- set, because after desugaring the code will
982 -- only mention f's *name*, not f itself.
983 do { keepAliveTc id_name; return id }
986 = -- Nested identifiers, such as 'x' in
987 -- E.g. \x -> [| h x |]
988 -- We must behave as if the reference to x was
990 -- We use 'x' itself as the splice proxy, used by
991 -- the desugarer to stitch it all back together.
992 -- If 'x' occurs many times we may get many identical
993 -- bindings of the same splice proxy, but that doesn't
994 -- matter, although it's a mite untidy.
995 do { let id_ty = idType id
996 ; checkTc (isTauTy id_ty) (polySpliceErr id)
997 -- If x is polymorphic, its occurrence sites might
998 -- have different instantiations, so we can't use plain
999 -- 'x' as the splice proxy name. I don't know how to
1000 -- solve this, and it's probably unimportant, so I'm
1001 -- just going to flag an error for now
1003 ; id_ty' <- zapToMonotype id_ty
1004 -- The id_ty might have an OpenTypeKind, but we
1005 -- can't instantiate the Lift class at that kind,
1006 -- so we zap it to a LiftedTypeKind monotype
1007 -- C.f. the call in TcPat.newLitInst
1009 ; setLIEVar lie_var $ do
1010 { lift <- newMethodFromName orig id_ty' DsMeta.liftName
1011 -- Put the 'lift' constraint into the right LIE
1013 -- Update the pending splices
1014 ; ps <- readMutVar ps_var
1015 ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
1024 %************************************************************************
1026 \subsection{Record bindings}
1028 %************************************************************************
1030 Game plan for record bindings
1031 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1032 1. Find the TyCon for the bindings, from the first field label.
1034 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1036 For each binding field = value
1038 3. Instantiate the field type (from the field label) using the type
1041 4 Type check the value using tcArg, passing the field type as
1042 the expected argument type.
1044 This extends OK when the field types are universally quantified.
1050 -> [TcType] -- Expected type for each field
1051 -> HsRecordBinds Name
1052 -> TcM (HsRecordBinds TcId)
1054 tcRecordBinds data_con arg_tys rbinds
1055 = do { mb_binds <- mappM do_bind rbinds
1056 ; return (catMaybes mb_binds) }
1058 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1059 do_bind (L loc field_lbl, rhs)
1060 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1061 = addErrCtxt (fieldCtxt field_lbl) $
1062 do { rhs' <- tcPolyExprNC rhs field_ty
1063 ; sel_id <- tcLookupField field_lbl
1064 ; ASSERT( isRecordSelector sel_id )
1065 return (Just (L loc sel_id, rhs')) }
1067 = do { addErrTc (badFieldCon data_con field_lbl)
1070 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1071 checkMissingFields data_con rbinds
1072 | null field_labels -- Not declared as a record;
1073 -- But C{} is still valid if no strict fields
1074 = if any isMarkedStrict field_strs then
1075 -- Illegal if any arg is strict
1076 addErrTc (missingStrictFields data_con [])
1080 | otherwise -- A record
1081 = checkM (null missing_s_fields)
1082 (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_`
1084 doptM Opt_WarnMissingFields `thenM` \ warn ->
1085 checkM (not (warn && notNull missing_ns_fields))
1086 (warnTc True (missingFields data_con missing_ns_fields))
1090 = [ fl | (fl, str) <- field_info,
1092 not (fl `elem` field_names_used)
1095 = [ fl | (fl, str) <- field_info,
1096 not (isMarkedStrict str),
1097 not (fl `elem` field_names_used)
1100 field_names_used = recBindFields rbinds
1101 field_labels = dataConFieldLabels data_con
1103 field_info = zipEqual "missingFields"
1107 field_strs = dataConStrictMarks data_con
1110 %************************************************************************
1112 \subsection{Errors and contexts}
1114 %************************************************************************
1116 Boring and alphabetical:
1119 = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1122 = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1124 fieldCtxt field_name
1125 = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1127 funAppCtxt fun arg arg_no
1128 = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1129 quotes (ppr fun) <> text ", namely"])
1130 4 (quotes (ppr arg))
1133 = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1136 = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
1137 <+> ptext SLIT("is not (yet) supported"),
1138 ptext SLIT("Use pattern-matching instead")]
1140 = hang (ptext SLIT("No constructor has all these fields:"))
1141 4 (pprQuotedList (recBindFields rbinds))
1143 naughtyRecordSel sel_id
1144 = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
1145 ptext SLIT("as a function due to escaped type variables") $$
1146 ptext SLIT("Probably fix: use pattern-matching syntax instead")
1149 = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1151 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1152 missingStrictFields con fields
1155 rest | null fields = empty -- Happens for non-record constructors
1156 -- with strict fields
1157 | otherwise = colon <+> pprWithCommas ppr fields
1159 header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1160 ptext SLIT("does not have the required strict field(s)")
1162 missingFields :: DataCon -> [FieldLabel] -> SDoc
1163 missingFields con fields
1164 = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1165 <+> pprWithCommas ppr fields
1168 = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
1171 polySpliceErr :: Id -> SDoc
1173 = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)