2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[TcExpr]{Typecheck an expression}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
15 tcInferRho, tcInferRhoNC,
16 tcSyntaxOp, tcCheckId,
17 addExprErrCtxt ) where
19 #include "HsVersions.h"
21 #ifdef GHCI /* Only if bootstrapped */
22 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
23 import qualified DsMeta
49 import TysPrim( intPrimTy )
50 import PrimOp( tagToEnumKey )
62 %************************************************************************
64 \subsection{Main wrappers}
66 %************************************************************************
69 tcPolyExpr, tcPolyExprNC
70 :: LHsExpr Name -- Expression to type check
71 -> TcSigmaType -- Expected type (could be a polytpye)
72 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
74 -- tcPolyExpr is a convenient place (frequent but not too frequent)
75 -- place to add context information.
76 -- The NC version does not do so, usually because the caller wants
79 tcPolyExpr expr res_ty
80 = addExprErrCtxt expr $
81 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
83 tcPolyExprNC expr res_ty
84 = do { traceTc "tcPolyExprNC" (ppr res_ty)
85 ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho ->
87 ; return (mkLHsWrap gen_fn expr') }
90 tcMonoExpr, tcMonoExprNC
91 :: LHsExpr Name -- Expression to type check
92 -> TcRhoType -- Expected type (could be a type variable)
93 -- Definitely no foralls at the top
96 tcMonoExpr expr res_ty
97 = addErrCtxt (exprCtxt expr) $
98 tcMonoExprNC expr res_ty
100 tcMonoExprNC (L loc expr) res_ty
101 = ASSERT( not (isSigmaTy res_ty) )
103 do { expr' <- tcExpr expr res_ty
104 ; return (L loc expr') }
107 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
108 -- Infer a *rho*-type. This is, in effect, a special case
109 -- for ids and partial applications, so that if
110 -- f :: Int -> (forall a. a -> a) -> Int
112 -- f 3 :: (forall a. a -> a) -> Int
113 -- And that in turn is useful
114 -- (a) for the function part of any application (see tcApp)
115 -- (b) for the special rule for '$'
116 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
118 tcInferRhoNC (L loc expr)
120 do { (expr', rho) <- tcInfExpr expr
121 ; return (L loc expr', rho) }
123 tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
124 tcInfExpr (HsVar f) = tcInferId f
125 tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e
126 ; return (HsPar e', ty) }
127 tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
128 tcInfExpr e = tcInfer (tcExpr e)
132 %************************************************************************
134 tcExpr: the main expression typechecker
136 %************************************************************************
139 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
140 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
141 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
143 tcExpr (HsVar name) res_ty = tcCheckId name res_ty
145 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
147 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
148 ; tcWrapResult (HsLit lit) lit_ty res_ty }
150 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
151 ; return (HsPar expr') }
153 tcExpr (HsSCC lbl expr) res_ty
154 = do { expr' <- tcMonoExpr expr res_ty
155 ; return (HsSCC lbl expr') }
157 tcExpr (HsTickPragma info expr) res_ty
158 = do { expr' <- tcMonoExpr expr res_ty
159 ; return (HsTickPragma info expr') }
161 tcExpr (HsCoreAnn lbl expr) res_ty
162 = do { expr' <- tcMonoExpr expr res_ty
163 ; return (HsCoreAnn lbl expr') }
165 tcExpr (HsOverLit lit) res_ty
166 = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
167 ; return (HsOverLit lit') }
169 tcExpr (NegApp expr neg_expr) res_ty
170 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
171 (mkFunTy res_ty res_ty)
172 ; expr' <- tcMonoExpr expr res_ty
173 ; return (NegApp expr' neg_expr') }
175 tcExpr (HsIPVar ip) res_ty
176 = do { let origin = IPOccOrigin ip
177 -- Implicit parameters must have a *tau-type* not a
178 -- type scheme. We enforce this by creating a fresh
179 -- type variable as its type. (Because res_ty may not
181 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
182 ; ip_var <- emitWanted origin (mkIPPred ip ip_ty)
183 ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty }
185 tcExpr (HsLam match) res_ty
186 = do { (co_fn, match') <- tcMatchLambda match res_ty
187 ; return (mkHsWrap co_fn (HsLam match')) }
189 tcExpr (ExprWithTySig expr sig_ty) res_ty
190 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
192 -- Remember to extend the lexical type-variable environment
194 <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty ->
195 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
196 -- See Note [More instantiated than scoped] in TcBinds
197 tcMonoExprNC expr res_ty
199 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
201 ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
202 ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
205 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
206 -- This is the syntax for type applications that I was planning
207 -- but there are difficulties (e.g. what order for type args)
208 -- so it's not enabled yet.
209 -- Can't eliminate it altogether from the parser, because the
210 -- same parser parses *patterns*.
214 %************************************************************************
216 Infix operators and sections
218 %************************************************************************
222 Left sections, like (4 *), are equivalent to
224 or, if PostfixOperators is enabled, just
226 With PostfixOperators we don't actually require the function to take
227 two arguments at all. For example, (x `not`) means (not x); you get
228 postfix operators! Not Haskell 98, but it's less work and kind of
231 Note [Typing rule for ($)]
232 ~~~~~~~~~~~~~~~~~~~~~~~~~~
236 runST :: (forall s. ST s a) -> a
237 that I have finally given in and written a special type-checking
238 rule just for saturated appliations of ($).
239 * Infer the type of the first argument
240 * Decompose it; should be of form (arg2_ty -> res_ty),
241 where arg2_ty might be a polytype
242 * Use arg2_ty to typecheck arg2
244 Note [Typing rule for seq]
245 ~~~~~~~~~~~~~~~~~~~~~~~~~~
248 which suggests this type for seq:
249 seq :: forall (a:*) (b:??). a -> b -> b,
250 with (b:??) meaning that be can be instantiated with an unboxed tuple.
251 But that's ill-kinded! Function arguments can't be unboxed tuples.
252 And indeed, you could not expect to do this with a partially-applied
253 'seq'; it's only going to work when it's fully applied. so it turns
255 case x of _ -> (# p,q #)
257 For a while I slid by by giving 'seq' an ill-kinded type, but then
258 the simplifier eta-reduced an application of seq and Lint blew up
259 with a kind error. It seems more uniform to treat 'seq' as it it
260 was a language construct.
262 See Note [seqId magic] in MkId, and
266 tcExpr (OpApp arg1 op fix arg2) res_ty
267 | (L loc (HsVar op_name)) <- op
268 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
269 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
270 ; let arg2_ty = res_ty
271 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
272 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
273 ; op_id <- tcLookupId op_name
274 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
275 ; return $ OpApp arg1' op' fix arg2' }
277 | (L loc (HsVar op_name)) <- op
278 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
279 = do { traceTc "Application rule" (ppr op)
280 ; (arg1', arg1_ty) <- tcInferRho arg1
281 ; let doc = ptext (sLit "The first argument of ($) takes")
282 ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
283 -- arg2_ty maybe polymorphic; that's the point
284 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
285 ; co_res <- unifyType op_res_ty res_ty
286 ; op_id <- tcLookupId op_name
287 ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
288 ; return $ mkHsWrapCoI co_res $
289 OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
292 = do { traceTc "Non Application rule" (ppr op)
293 ; (op', op_ty) <- tcInferFun op
294 ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
295 ; co_res <- unifyType op_res_ty res_ty
296 ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
297 ; return $ mkHsWrapCoI co_res $
298 OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
300 -- Right sections, equivalent to \ x -> x `op` expr, or
303 tcExpr (SectionR op arg2) res_ty
304 = do { (op', op_ty) <- tcInferFun op
305 ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
306 ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
307 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
308 ; return $ mkHsWrapCoI co_res $
309 SectionR (mkLHsWrapCoI co_fn op') arg2' }
311 tcExpr (SectionL arg1 op) res_ty
312 = do { (op', op_ty) <- tcInferFun op
313 ; dflags <- getDOpts -- Note [Left sections]
314 ; let n_reqd_args | dopt Opt_PostfixOperators dflags = 1
317 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
318 ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
319 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
320 ; return $ mkHsWrapCoI co_res $
321 SectionL arg1' (mkLHsWrapCoI co_fn op') }
323 tcExpr (ExplicitTuple tup_args boxity) res_ty
324 | all tupArgPresent tup_args
325 = do { let tup_tc = tupleTyCon boxity (length tup_args)
326 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
327 ; tup_args1 <- tcTupArgs tup_args arg_tys
328 ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
331 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
332 do { let kind = case boxity of { Boxed -> liftedTypeKind
333 ; Unboxed -> argTypeKind }
334 arity = length tup_args
335 tup_tc = tupleTyCon boxity arity
337 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
339 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
340 (mkTyConApp tup_tc arg_tys)
342 ; coi <- unifyType actual_res_ty res_ty
344 -- Handle tuple sections where
345 ; tup_args1 <- tcTupArgs tup_args arg_tys
347 ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
349 tcExpr (ExplicitList _ exprs) res_ty
350 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
351 ; exprs' <- mapM (tc_elt elt_ty) exprs
352 ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
354 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
356 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
357 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
358 ; exprs' <- mapM (tc_elt elt_ty) exprs
359 ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
361 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
364 %************************************************************************
368 %************************************************************************
371 tcExpr (HsLet binds expr) res_ty
372 = do { (binds', expr') <- tcLocalBinds binds $
373 tcMonoExpr expr res_ty
374 ; return (HsLet binds' expr') }
376 tcExpr (HsCase scrut matches) exp_ty
377 = do { -- We used to typecheck the case alternatives first.
378 -- The case patterns tend to give good type info to use
379 -- when typechecking the scrutinee. For example
382 -- will report that map is applied to too few arguments
384 -- But now, in the GADT world, we need to typecheck the scrutinee
385 -- first, to get type info that may be refined in the case alternatives
386 (scrut', scrut_ty) <- tcInferRho scrut
388 ; traceTc "HsCase" (ppr scrut_ty)
389 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
390 ; return (HsCase scrut' matches') }
392 match_ctxt = MC { mc_what = CaseAlt,
395 tcExpr (HsIf pred b1 b2) res_ty
396 = do { pred' <- tcMonoExpr pred boolTy
397 ; b1' <- tcMonoExpr b1 res_ty
398 ; b2' <- tcMonoExpr b2 res_ty
399 ; return (HsIf pred' b1' b2') }
401 tcExpr (HsDo do_or_lc stmts body _) res_ty
402 = tcDoStmts do_or_lc stmts body res_ty
404 tcExpr (HsProc pat cmd) res_ty
405 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
406 ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
408 tcExpr e@(HsArrApp _ _ _ _ _) _
409 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
410 ptext (sLit "was found where an expression was expected")])
412 tcExpr e@(HsArrForm _ _ _) _
413 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
414 ptext (sLit "was found where an expression was expected")])
417 %************************************************************************
419 Record construction and update
421 %************************************************************************
424 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
425 = do { data_con <- tcLookupDataCon con_name
427 -- Check for missing fields
428 ; checkMissingFields data_con rbinds
430 ; (con_expr, con_tau) <- tcInferId con_name
431 ; let arity = dataConSourceArity data_con
432 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
433 con_id = dataConWrapId data_con
435 ; co_res <- unifyType actual_res_ty res_ty
436 ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
437 ; return $ mkHsWrapCoI co_res $
438 RecordCon (L loc con_id) con_expr rbinds' }
441 Note [Type of a record update]
442 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
443 The main complication with RecordUpd is that we need to explicitly
444 handle the *non-updated* fields. Consider:
446 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
447 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
450 upd :: T a b c -> (b',c) -> T a b' c
451 upd t x = t { fb = x}
453 The result type should be (T a b' c)
454 not (T a b c), because 'b' *is not* mentioned in a non-updated field
455 not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field
456 NB that it's not good enough to look at just one constructor; we must
457 look at them all; cf Trac #3219
459 After all, upd should be equivalent to:
465 So we need to give a completely fresh type to the result record,
466 and then constrain it by the fields that are *not* updated ("p" above).
467 We call these the "fixed" type variables, and compute them in getFixedTyVars.
469 Note that because MkT3 doesn't contain all the fields being updated,
470 its RHS is simply an error, so it doesn't impose any type constraints.
471 Hence the use of 'relevant_cont'.
473 Note [Implict type sharing]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 We also take into account any "implicit" non-update fields. For example
476 data T a b where { MkT { f::a } :: T a a; ... }
477 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
482 upd :: T a b -> a -> T a b
483 upd (t::T a b) (x::a)
484 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
485 We can't give it the more general type
486 upd :: T a b -> c -> T c b
488 Note [Criteria for update]
489 ~~~~~~~~~~~~~~~~~~~~~~~~~~
490 We want to allow update for existentials etc, provided the updated
491 field isn't part of the existential. For example, this should be ok.
492 data T a where { MkT { f1::a, f2::b->b } :: T a }
496 The criterion we use is this:
498 The types of the updated fields
499 mention only the universally-quantified type variables
500 of the data constructor
502 NB: this is not (quite) the same as being a "naughty" record selector
503 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
504 in the case of GADTs. Consider
505 data T a where { MkT :: { f :: a } :: T [a] }
506 Then f is not "naughty" because it has a well-typed record selector.
507 But we don't allow updates for 'f'. (One could consider trying to
508 allow this, but it makes my head hurt. Badly. And no one has asked
511 In principle one could go further, and allow
513 g t = t { f2 = \x -> x }
514 because the expression is polymorphic...but that seems a bridge too far.
516 Note [Data family example]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~
518 data instance T (a,b) = MkT { x::a, y::b }
520 data :TP a b = MkT { a::a, y::b }
521 coTP a b :: T (a,b) ~ :TP a b
523 Suppose r :: T (t1,t2), e :: t3
524 Then r { x=e } :: T (t3,t1)
527 MkT x y -> MkT e y |> co2
528 where co1 :: T (t1,t2) ~ :TP t1 t2
529 co2 :: :TP t3 t2 ~ T (t3,t2)
530 The wrapping with co2 is done by the constructor wrapper for MkT
534 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
536 * cons are the data constructors to be updated
538 * in_inst_tys, out_inst_tys have same length, and instantiate the
539 *representation* tycon of the data cons. In Note [Data
540 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
543 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
544 = ASSERT( notNull upd_fld_names )
547 -- Check that the field names are really field names
548 ; sel_ids <- mapM tcLookupField upd_fld_names
549 -- The renamer has already checked that
550 -- selectors are all in scope
551 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
552 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
553 not (isRecordSelector sel_id), -- Excludes class ops
554 let L loc fld_name = hsRecFieldId fld ]
555 ; unless (null bad_guys) (sequence bad_guys >> failM)
558 -- Figure out the tycon and data cons from the first field name
559 ; let -- It's OK to use the non-tc splitters here (for a selector)
561 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
562 data_cons = tyConDataCons tycon -- it's not a field label
563 -- NB: for a data type family, the tycon is the instance tycon
565 relevant_cons = filter is_relevant data_cons
566 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
567 -- A constructor is only relevant to this process if
568 -- it contains *all* the fields that are being updated
569 -- Other ones will cause a runtime error if they occur
571 -- Take apart a representative constructor
572 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
573 (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
574 con1_flds = dataConFieldLabels con1
575 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
578 -- Check that at least one constructor has all the named fields
579 -- i.e. has an empty set of bad fields returned by badFields
580 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
582 -- STEP 3 Note [Criteria for update]
583 -- Check that each updated field is polymorphic; that is, its type
584 -- mentions only the universally-quantified variables of the data con
585 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
586 upd_flds1_w_tys = filter is_updated flds1_w_tys
587 is_updated (fld,_) = fld `elem` upd_fld_names
589 bad_upd_flds = filter bad_fld upd_flds1_w_tys
590 con1_tv_set = mkVarSet con1_tvs
591 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
592 not (tyVarsOfType ty `subVarSet` con1_tv_set)
593 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
595 -- STEP 4 Note [Type of a record update]
596 -- Figure out types for the scrutinee and result
597 -- Both are of form (T a b c), with fresh type variables, but with
598 -- common variables where the scrutinee and result must have the same type
599 -- These are variables that appear in *any* arg of *any* of the
600 -- relevant constructors *except* in the updated fields
602 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
603 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
604 mk_inst_ty tv result_inst_ty
605 | is_fixed_tv tv = return result_inst_ty -- Same as result type
606 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
608 ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
609 ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
611 ; let rec_res_ty = substTy result_inst_env con1_res_ty
612 con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
613 scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
614 scrut_ty = substTy scrut_subst con1_res_ty
616 ; co_res <- unifyType rec_res_ty res_ty
619 -- Typecheck the thing to be updated, and the bindings
620 ; record_expr' <- tcMonoExpr record_expr scrut_ty
621 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
623 -- STEP 6: Deal with the stupid theta
624 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
625 ; instStupidTheta RecordUpdOrigin theta'
627 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
628 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
629 = WpCast $ mkTyConApp co_con scrut_inst_tys
633 ; return $ mkHsWrapCoI co_res $
634 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
635 relevant_cons scrut_inst_tys result_inst_tys }
637 upd_fld_names = hsRecFields rbinds
639 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
640 -- These tyvars must not change across the updates
641 getFixedTyVars tvs1 cons
642 = mkVarSet [tv1 | con <- cons
643 , let (tvs, theta, arg_tys, _) = dataConSig con
644 flds = dataConFieldLabels con
645 fixed_tvs = exactTyVarsOfTypes fixed_tys
646 -- fixed_tys: See Note [Type of a record update]
647 `unionVarSet` tyVarsOfTheta theta
648 -- Universally-quantified tyvars that
649 -- appear in any of the *implicit*
650 -- arguments to the constructor are fixed
651 -- See Note [Implict type sharing]
653 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
654 , not (fld `elem` upd_fld_names)]
655 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
656 , tv `elemVarSet` fixed_tvs ]
659 %************************************************************************
661 Arithmetic sequences e.g. [a,b..]
662 and their parallel-array counterparts e.g. [: a,b.. :]
665 %************************************************************************
668 tcExpr (ArithSeq _ seq@(From expr)) res_ty
669 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
670 ; expr' <- tcPolyExpr expr elt_ty
671 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
673 ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
675 tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
676 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
677 ; expr1' <- tcPolyExpr expr1 elt_ty
678 ; expr2' <- tcPolyExpr expr2 elt_ty
679 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
680 enumFromThenName elt_ty
681 ; return $ mkHsWrapCoI coi
682 (ArithSeq enum_from_then (FromThen expr1' expr2')) }
684 tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
685 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
686 ; expr1' <- tcPolyExpr expr1 elt_ty
687 ; expr2' <- tcPolyExpr expr2 elt_ty
688 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
689 enumFromToName elt_ty
690 ; return $ mkHsWrapCoI coi
691 (ArithSeq enum_from_to (FromTo expr1' expr2')) }
693 tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
694 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
695 ; expr1' <- tcPolyExpr expr1 elt_ty
696 ; expr2' <- tcPolyExpr expr2 elt_ty
697 ; expr3' <- tcPolyExpr expr3 elt_ty
698 ; eft <- newMethodFromName (ArithSeqOrigin seq)
699 enumFromThenToName elt_ty
700 ; return $ mkHsWrapCoI coi
701 (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
703 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
704 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
705 ; expr1' <- tcPolyExpr expr1 elt_ty
706 ; expr2' <- tcPolyExpr expr2 elt_ty
707 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
708 enumFromToPName elt_ty
709 ; return $ mkHsWrapCoI coi
710 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
712 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
713 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
714 ; expr1' <- tcPolyExpr expr1 elt_ty
715 ; expr2' <- tcPolyExpr expr2 elt_ty
716 ; expr3' <- tcPolyExpr expr3 elt_ty
717 ; eft <- newMethodFromName (PArrSeqOrigin seq)
718 enumFromThenToPName elt_ty
719 ; return $ mkHsWrapCoI coi
720 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
722 tcExpr (PArrSeq _ _) _
723 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
724 -- the parser shouldn't have generated it and the renamer shouldn't have
729 %************************************************************************
733 %************************************************************************
736 #ifdef GHCI /* Only if bootstrapped */
737 -- Rename excludes these cases otherwise
738 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
739 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
741 tcExpr e@(HsQuasiQuoteE _) _ =
742 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
747 %************************************************************************
751 %************************************************************************
754 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
758 %************************************************************************
762 %************************************************************************
765 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
766 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
768 tcApp (L _ (HsPar e)) args res_ty
769 = tcApp e args res_ty
771 tcApp (L _ (HsApp e1 e2)) args res_ty
772 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
774 tcApp (L loc (HsVar fun)) args res_ty
775 | fun `hasKey` tagToEnumKey
777 = tcTagToEnum loc fun arg res_ty
779 tcApp fun args res_ty
780 = do { -- Type-check the function
781 ; (fun1, fun_tau) <- tcInferFun fun
783 -- Extract its argument types
784 ; (co_fun, expected_arg_tys, actual_res_ty)
785 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
787 -- Typecheck the result, thereby propagating
788 -- info (if any) from result into the argument types
789 -- Both actual_res_ty and res_ty are deeply skolemised
790 ; co_res <- unifyType actual_res_ty res_ty
792 -- Typecheck the arguments
793 ; args1 <- tcArgs fun args expected_arg_tys
795 -- Assemble the result
796 ; let fun2 = mkLHsWrapCoI co_fun fun1
797 app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
799 ; return (unLoc app) }
802 mk_app_msg :: LHsExpr Name -> SDoc
803 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
804 , ptext (sLit "is applied to")]
807 tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
808 -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
810 tcInferApp (L _ (HsPar e)) args = tcInferApp e args
811 tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
813 = -- Very like the tcApp version, except that there is
814 -- no expected result type passed in
815 do { (fun1, fun_tau) <- tcInferFun fun
816 ; (co_fun, expected_arg_tys, actual_res_ty)
817 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
818 ; args1 <- tcArgs fun args expected_arg_tys
819 ; let fun2 = mkLHsWrapCoI co_fun fun1
820 app = foldl mkHsApp fun2 args1
821 ; return (unLoc app, actual_res_ty) }
824 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
825 -- Infer and instantiate the type of a function
826 tcInferFun (L loc (HsVar name))
827 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
828 -- Don't wrap a context around a plain Id
829 ; return (L loc fun, ty) }
832 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
834 -- Zonk the function type carefully, to expose any polymorphism
835 -- E.g. (( \(x::forall a. a->a). blah ) e)
836 -- We can see the rank-2 type of the lambda in time to genrealise e
837 ; fun_ty' <- zonkTcTypeCarefully fun_ty
839 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
840 ; return (mkLHsWrap wrap fun, rho) }
843 tcArgs :: LHsExpr Name -- The function (for error messages)
844 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
845 -> TcM [LHsExpr TcId] -- Resulting args
847 tcArgs fun args expected_arg_tys
848 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
851 tcArg :: LHsExpr Name -- The function (for error messages)
852 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
853 -> TcM (LHsExpr TcId) -- Resulting argument
854 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
855 (tcPolyExprNC arg ty)
858 tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
860 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
862 go (Missing {}, arg_ty) = return (Missing arg_ty)
863 go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
864 ; return (Present expr') }
867 unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
868 -> TcM (CoercionI, [TcSigmaType], TcRhoType)
869 -- A wrapper for matchExpectedFunTys
870 unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
872 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
874 ---------------------------
875 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
876 -- Typecheck a syntax operator, checking that it has the specified type
877 -- The operator is always a variable at this stage (i.e. renamer output)
878 -- This version assumes res_ty is a monotype
879 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
880 ; tcWrapResult expr rho res_ty }
881 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
885 Note [Push result type in]
886 ~~~~~~~~~~~~~~~~~~~~~~~~~~
887 Unify with expected result before type-checking the args so that the
888 info from res_ty percolates to args. This is when we might detect a
889 too-few args situation. (One can think of cases when the opposite
890 order would give a better error message.)
891 experimenting with putting this first.
893 Here's an example where it actually makes a real difference
895 class C t a b | t a -> b
896 instance C Char a Bool
898 data P t a = forall b. (C t a b) => MkP b
899 data Q t = MkQ (forall a. P t a)
903 f2 = MkQ (MkP True :: forall a. P Char a)
905 With the change, f1 will type-check, because the 'Char' info from
906 the signature is propagated into MkQ's argument. With the check
907 in the other order, the extra signature in f2 is reqd.
910 %************************************************************************
914 %************************************************************************
917 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
918 tcCheckId name res_ty = do { (expr, rho) <- tcInferId name
919 ; tcWrapResult expr rho res_ty }
921 ------------------------
922 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
923 -- Infer type, and deeply instantiate
924 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
926 ------------------------
927 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
928 -- Look up an occurrence of an Id, and instantiate it (deeply)
930 tcInferIdWithOrig orig id_name
931 = do { id <- lookup_id
932 ; (id_expr, id_rho) <- instantiateOuter orig id
933 ; (wrap, rho) <- deeplyInstantiate orig id_rho
934 ; return (mkHsWrap wrap id_expr, rho) }
936 lookup_id :: TcM TcId
938 = do { thing <- tcLookup id_name
940 ATcId { tct_id = id, tct_level = lvl }
941 -> do { check_naughty id -- Note [Local record selectors]
942 ; checkThLocalId id lvl
946 -> do { check_naughty id; return id }
947 -- A global cannot possibly be ill-staged
948 -- nor does it need the 'lifting' treatment
949 -- hence no checkTh stuff here
951 AGlobal (ADataCon con) -> return (dataConWrapId con)
953 other -> failWithTc (bad_lookup other) }
955 bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
958 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
959 | otherwise = return ()
961 ------------------------
962 instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
963 -- Do just the first level of instantiation of an Id
964 -- a) Deal with method sharing
965 -- b) Deal with stupid checks
966 -- Only look at the *outer level* of quantification
967 -- See Note [Multiple instantiation]
969 instantiateOuter orig id
970 | null tvs && null theta
971 = return (HsVar id, tau)
974 = do { (_, tys, subst) <- tcInstTyVars tvs
975 ; doStupidChecks id tys
976 ; let theta' = substTheta subst theta
977 ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
978 ; wrap <- instCall orig tys theta'
979 ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
981 (tvs, theta, tau) = tcSplitSigmaTy (idType id)
984 Note [Multiple instantiation]
985 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
986 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
987 For example, consider
988 f :: forall a. Eq a => forall b. Ord b => a -> b
989 At a call to f, at say [Int, Bool], it's tempting to translate the call to
993 f_m1 :: forall b. Ord b => Int -> b
997 f_m2 = f_m1 Bool dOrdBool
999 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
1000 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
1002 But it's entirely possible that f_m2 will continue to float out, because it
1003 mentions no type variables. Result, f_m1 isn't in scope.
1005 Here's a concrete example that does this (test tc200):
1008 f :: Eq b => b -> a -> Int
1009 baz :: Eq a => Int -> a -> Int
1011 instance C Int where
1014 Current solution: only do the "method sharing" thing for the first type/dict
1015 application, not for the iterated ones. A horribly subtle point.
1017 Note [No method sharing]
1018 ~~~~~~~~~~~~~~~~~~~~~~~~
1019 The -fno-method-sharing flag controls what happens so far as the LIE
1020 is concerned. The default case is that for an overloaded function we
1021 generate a "method" Id, and add the Method Inst to the LIE. So you get
1023 f :: Num a => a -> a
1024 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
1025 If you specify -fno-method-sharing, the dictionary application
1026 isn't shared, so we get
1027 f :: Num a => a -> a
1028 f = /\a (d:Num a) (x:a) -> (+) a d x x
1029 This gets a bit less sharing, but
1030 a) it's better for RULEs involving overloaded functions
1031 b) perhaps fewer separated lambdas
1034 doStupidChecks :: TcId
1037 -- Check two tiresome and ad-hoc cases
1038 -- (a) the "stupid theta" for a data con; add the constraints
1039 -- from the "stupid theta" of a data constructor (sigh)
1041 doStupidChecks fun_id tys
1042 | Just con <- isDataConId_maybe fun_id -- (a)
1043 = addDataConStupidTheta con tys
1045 | fun_id `hasKey` tagToEnumKey -- (b)
1046 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1049 = return () -- The common case
1054 Nasty check to ensure that tagToEnum# is applied to a type that is an
1055 enumeration TyCon. Unification may refine the type later, but this
1056 check won't see that, alas. It's crude, because it relies on our
1057 knowing *now* that the type is ok, which in turn relies on the
1058 eager-unification part of the type checker pushing enough information
1059 here. In theory the Right Thing to do is to have a new form of
1060 constraint but I definitely cannot face that! And it works ok as-is.
1062 Here's are two cases that should fail
1064 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1067 g = tagToEnum# 0 -- Int is not an enumeration
1069 When data type families are involved it's a bit more complicated.
1071 data instance F [Int] = A | B | C
1072 Then we want to generate something like
1073 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1074 Usually that coercion is hidden inside the wrappers for
1075 constructors of F [Int] but here we have to do it explicitly.
1077 It's all grotesquely complicated.
1080 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1081 -- tagToEnum# :: forall a. Int# -> a
1082 -- See Note [tagToEnum#] Urgh!
1083 tcTagToEnum loc fun_name arg res_ty
1084 = do { fun <- tcLookupId fun_name
1085 ; ty' <- zonkTcType res_ty
1087 -- Check that the type is algebraic
1088 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1089 Just (tc, tc_args) = mb_tc_app
1090 ; checkTc (isJust mb_tc_app)
1091 (tagToEnumError ty' doc1)
1093 -- Look through any type family
1094 ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args
1096 ; checkTc (isEnumerationTyCon rep_tc)
1097 (tagToEnumError ty' doc2)
1099 ; arg' <- tcMonoExpr arg intPrimTy
1100 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1101 rep_ty = mkTyConApp rep_tc rep_args
1103 ; return (mkHsWrapCoI coi $ HsApp fun' arg') }
1105 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1106 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1107 doc2 = ptext (sLit "Result type must be an enumeration type")
1108 doc3 = ptext (sLit "No family instance for this type")
1110 get_rep_ty :: TcType -> TyCon -> [TcType]
1111 -> TcM (CoercionI, TyCon, [TcType])
1112 -- Converts a family type (eg F [a]) to its rep type (eg FList a)
1113 -- and returns a coercion between the two
1114 get_rep_ty ty tc tc_args
1115 | not (isFamilyTyCon tc)
1116 = return (IdCo ty, tc, tc_args)
1118 = do { mb_fam <- tcLookupFamInst tc tc_args
1120 Nothing -> failWithTc (tagToEnumError ty doc3)
1121 Just (rep_tc, rep_args)
1122 -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
1123 , rep_tc, rep_args )
1125 co_tc = expectJust "tcTagToEnum" $
1126 tyConFamilyCoercion_maybe rep_tc }
1128 tagToEnumError :: TcType -> SDoc -> SDoc
1129 tagToEnumError ty what
1130 = hang (ptext (sLit "Bad call to tagToEnum#")
1131 <+> ptext (sLit "at type") <+> ppr ty)
1136 %************************************************************************
1138 Template Haskell checks
1140 %************************************************************************
1143 checkThLocalId :: Id -> ThLevel -> TcM ()
1144 #ifndef GHCI /* GHCI and TH is off */
1145 --------------------------------------
1146 -- Check for cross-stage lifting
1147 checkThLocalId _id _bind_lvl
1150 #else /* GHCI and TH is on */
1151 checkThLocalId id bind_lvl
1152 = do { use_stage <- getStage -- TH case
1153 ; let use_lvl = thLevel use_stage
1154 ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1155 ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1156 ; when (use_lvl > bind_lvl) $
1157 checkCrossStageLifting id bind_lvl use_stage }
1159 --------------------------------------
1160 checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM ()
1161 -- We are inside brackets, and (use_lvl > bind_lvl)
1162 -- Now we must check whether there's a cross-stage lift to do
1163 -- Examples \x -> [| x |]
1166 checkCrossStageLifting _ _ Comp = return ()
1167 checkCrossStageLifting _ _ Splice = return ()
1169 checkCrossStageLifting id _ (Brack _ ps_var lie_var)
1171 = -- Top-level identifiers in this module,
1172 -- (which have External Names)
1173 -- are just like the imported case:
1174 -- no need for the 'lifting' treatment
1175 -- E.g. this is fine:
1178 -- But we do need to put f into the keep-alive
1179 -- set, because after desugaring the code will
1180 -- only mention f's *name*, not f itself.
1183 | otherwise -- bind_lvl = outerLevel presumably,
1184 -- but the Id is not bound at top level
1185 = -- Nested identifiers, such as 'x' in
1186 -- E.g. \x -> [| h x |]
1187 -- We must behave as if the reference to x was
1189 -- We use 'x' itself as the splice proxy, used by
1190 -- the desugarer to stitch it all back together.
1191 -- If 'x' occurs many times we may get many identical
1192 -- bindings of the same splice proxy, but that doesn't
1193 -- matter, although it's a mite untidy.
1194 do { let id_ty = idType id
1195 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1196 -- If x is polymorphic, its occurrence sites might
1197 -- have different instantiations, so we can't use plain
1198 -- 'x' as the splice proxy name. I don't know how to
1199 -- solve this, and it's probably unimportant, so I'm
1200 -- just going to flag an error for now
1202 ; lift <- if isStringTy id_ty then
1203 do { sid <- tcLookupId DsMeta.liftStringName
1204 -- See Note [Lifting strings]
1205 ; return (HsVar sid) }
1207 setConstraintVar lie_var $ do
1208 -- Put the 'lift' constraint into the right LIE
1209 newMethodFromName (OccurrenceOf (idName id))
1210 DsMeta.liftName id_ty
1212 -- Update the pending splices
1213 ; ps <- readMutVar ps_var
1214 ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
1220 Note [Lifting strings]
1221 ~~~~~~~~~~~~~~~~~~~~~~
1222 If we see $(... [| s |] ...) where s::String, we don't want to
1223 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1224 So this conditional short-circuits the lifting mechanism to generate
1225 (liftString "xy") in that case. I didn't want to use overlapping instances
1226 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1227 errors in a polymorphic situation.
1229 If this check fails (which isn't impossible) we get another chance; see
1230 Note [Converting strings] in Convert.lhs
1232 Local record selectors
1233 ~~~~~~~~~~~~~~~~~~~~~~
1234 Record selectors for TyCons in this module are ordinary local bindings,
1235 which show up as ATcIds rather than AGlobals. So we need to check for
1236 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1239 %************************************************************************
1241 \subsection{Record bindings}
1243 %************************************************************************
1245 Game plan for record bindings
1246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1247 1. Find the TyCon for the bindings, from the first field label.
1249 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1251 For each binding field = value
1253 3. Instantiate the field type (from the field label) using the type
1256 4 Type check the value using tcArg, passing the field type as
1257 the expected argument type.
1259 This extends OK when the field types are universally quantified.
1265 -> [TcType] -- Expected type for each field
1266 -> HsRecordBinds Name
1267 -> TcM (HsRecordBinds TcId)
1269 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1270 = do { mb_binds <- mapM do_bind rbinds
1271 ; return (HsRecFields (catMaybes mb_binds) dd) }
1273 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1274 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1275 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1276 = addErrCtxt (fieldCtxt field_lbl) $
1277 do { rhs' <- tcPolyExprNC rhs field_ty
1278 ; let field_id = mkUserLocal (nameOccName field_lbl)
1279 (nameUnique field_lbl)
1281 -- Yuk: the field_id has the *unique* of the selector Id
1282 -- (so we can find it easily)
1283 -- but is a LocalId with the appropriate type of the RHS
1284 -- (so the desugarer knows the type of local binder to make)
1285 ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1287 = do { addErrTc (badFieldCon data_con field_lbl)
1290 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1291 checkMissingFields data_con rbinds
1292 | null field_labels -- Not declared as a record;
1293 -- But C{} is still valid if no strict fields
1294 = if any isBanged field_strs then
1295 -- Illegal if any arg is strict
1296 addErrTc (missingStrictFields data_con [])
1300 | otherwise = do -- A record
1301 unless (null missing_s_fields)
1302 (addErrTc (missingStrictFields data_con missing_s_fields))
1304 warn <- doptM Opt_WarnMissingFields
1305 unless (not (warn && notNull missing_ns_fields))
1306 (warnTc True (missingFields data_con missing_ns_fields))
1310 = [ fl | (fl, str) <- field_info,
1312 not (fl `elem` field_names_used)
1315 = [ fl | (fl, str) <- field_info,
1317 not (fl `elem` field_names_used)
1320 field_names_used = hsRecFields rbinds
1321 field_labels = dataConFieldLabels data_con
1323 field_info = zipEqual "missingFields"
1327 field_strs = dataConStrictMarks data_con
1330 %************************************************************************
1332 \subsection{Errors and contexts}
1334 %************************************************************************
1336 Boring and alphabetical:
1338 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1339 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1341 exprCtxt :: LHsExpr Name -> SDoc
1343 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1345 fieldCtxt :: Name -> SDoc
1346 fieldCtxt field_name
1347 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1349 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1350 funAppCtxt fun arg arg_no
1351 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1352 quotes (ppr fun) <> text ", namely"])
1353 2 (quotes (ppr arg))
1355 badFieldTypes :: [(Name,TcType)] -> SDoc
1357 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1358 <> plural prs <> colon)
1359 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1361 badFieldsUpd :: HsRecFields Name a -> SDoc
1363 = hang (ptext (sLit "No constructor has all these fields:"))
1364 2 (pprQuotedList (hsRecFields rbinds))
1366 naughtyRecordSel :: TcId -> SDoc
1367 naughtyRecordSel sel_id
1368 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1369 ptext (sLit "as a function due to escaped type variables") $$
1370 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1372 notSelector :: Name -> SDoc
1374 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1376 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1377 missingStrictFields con fields
1380 rest | null fields = empty -- Happens for non-record constructors
1381 -- with strict fields
1382 | otherwise = colon <+> pprWithCommas ppr fields
1384 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1385 ptext (sLit "does not have the required strict field(s)")
1387 missingFields :: DataCon -> [FieldLabel] -> SDoc
1388 missingFields con fields
1389 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1390 <+> pprWithCommas ppr fields
1392 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1395 polySpliceErr :: Id -> SDoc
1397 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)