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
50 import TysPrim( intPrimTy )
51 import PrimOp( tagToEnumKey )
65 %************************************************************************
67 \subsection{Main wrappers}
69 %************************************************************************
72 tcPolyExpr, tcPolyExprNC
73 :: LHsExpr Name -- Expression to type check
74 -> TcSigmaType -- Expected type (could be a polytpye)
75 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
77 -- tcPolyExpr is a convenient place (frequent but not too frequent)
78 -- place to add context information.
79 -- The NC version does not do so, usually because the caller wants
82 tcPolyExpr expr res_ty
83 = addExprErrCtxt expr $
84 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
86 tcPolyExprNC expr res_ty
87 = do { traceTc "tcPolyExprNC" (ppr res_ty)
88 ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
90 ; return (mkLHsWrap gen_fn expr') }
93 tcMonoExpr, tcMonoExprNC
94 :: LHsExpr Name -- Expression to type check
95 -> TcRhoType -- Expected type (could be a type variable)
96 -- Definitely no foralls at the top
99 tcMonoExpr expr res_ty
100 = addErrCtxt (exprCtxt expr) $
101 tcMonoExprNC expr res_ty
103 tcMonoExprNC (L loc expr) res_ty
104 = ASSERT( not (isSigmaTy res_ty) )
106 do { expr' <- tcExpr expr res_ty
107 ; return (L loc expr') }
110 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
111 -- Infer a *rho*-type. This is, in effect, a special case
112 -- for ids and partial applications, so that if
113 -- f :: Int -> (forall a. a -> a) -> Int
115 -- f 3 :: (forall a. a -> a) -> Int
116 -- And that in turn is useful
117 -- (a) for the function part of any application (see tcApp)
118 -- (b) for the special rule for '$'
119 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
121 tcInferRhoNC (L loc expr)
123 do { (expr', rho) <- tcInfExpr expr
124 ; return (L loc expr', rho) }
126 tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
127 tcInfExpr (HsVar f) = tcInferId f
128 tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e
129 ; return (HsPar e', ty) }
130 tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
131 tcInfExpr e = tcInfer (tcExpr e)
135 %************************************************************************
137 tcExpr: the main expression typechecker
139 %************************************************************************
142 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
143 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
144 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
146 tcExpr (HsVar name) res_ty = tcCheckId name res_ty
148 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
150 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
151 ; tcWrapResult (HsLit lit) lit_ty res_ty }
153 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
154 ; return (HsPar expr') }
156 tcExpr (HsSCC lbl expr) res_ty
157 = do { expr' <- tcMonoExpr expr res_ty
158 ; return (HsSCC lbl expr') }
160 tcExpr (HsTickPragma info expr) res_ty
161 = do { expr' <- tcMonoExpr expr res_ty
162 ; return (HsTickPragma info expr') }
164 tcExpr (HsCoreAnn lbl expr) res_ty
165 = do { expr' <- tcMonoExpr expr res_ty
166 ; return (HsCoreAnn lbl expr') }
168 tcExpr (HsOverLit lit) res_ty
169 = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
170 ; return (HsOverLit lit') }
172 tcExpr (NegApp expr neg_expr) res_ty
173 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
174 (mkFunTy res_ty res_ty)
175 ; expr' <- tcMonoExpr expr res_ty
176 ; return (NegApp expr' neg_expr') }
178 tcExpr (HsIPVar ip) res_ty
179 = do { let origin = IPOccOrigin ip
180 -- Implicit parameters must have a *tau-type* not a
181 -- type scheme. We enforce this by creating a fresh
182 -- type variable as its type. (Because res_ty may not
184 ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
185 ; ip_var <- emitWanted origin (mkIPPred ip ip_ty)
186 ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty }
188 tcExpr (HsLam match) res_ty
189 = do { (co_fn, match') <- tcMatchLambda match res_ty
190 ; return (mkHsWrap co_fn (HsLam match')) }
192 tcExpr (ExprWithTySig expr sig_ty) res_ty
193 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
195 -- Remember to extend the lexical type-variable environment
197 <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
198 tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
199 -- See Note [More instantiated than scoped] in TcBinds
200 tcMonoExprNC expr res_ty
202 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
204 ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
205 ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
208 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
209 -- This is the syntax for type applications that I was planning
210 -- but there are difficulties (e.g. what order for type args)
211 -- so it's not enabled yet.
212 -- Can't eliminate it altogether from the parser, because the
213 -- same parser parses *patterns*.
217 %************************************************************************
219 Infix operators and sections
221 %************************************************************************
225 Left sections, like (4 *), are equivalent to
227 or, if PostfixOperators is enabled, just
229 With PostfixOperators we don't actually require the function to take
230 two arguments at all. For example, (x `not`) means (not x); you get
231 postfix operators! Not Haskell 98, but it's less work and kind of
234 Note [Typing rule for ($)]
235 ~~~~~~~~~~~~~~~~~~~~~~~~~~
239 runST :: (forall s. ST s a) -> a
240 that I have finally given in and written a special type-checking
241 rule just for saturated appliations of ($).
242 * Infer the type of the first argument
243 * Decompose it; should be of form (arg2_ty -> res_ty),
244 where arg2_ty might be a polytype
245 * Use arg2_ty to typecheck arg2
247 Note [Typing rule for seq]
248 ~~~~~~~~~~~~~~~~~~~~~~~~~~
251 which suggests this type for seq:
252 seq :: forall (a:*) (b:??). a -> b -> b,
253 with (b:??) meaning that be can be instantiated with an unboxed tuple.
254 But that's ill-kinded! Function arguments can't be unboxed tuples.
255 And indeed, you could not expect to do this with a partially-applied
256 'seq'; it's only going to work when it's fully applied. so it turns
258 case x of _ -> (# p,q #)
260 For a while I slid by by giving 'seq' an ill-kinded type, but then
261 the simplifier eta-reduced an application of seq and Lint blew up
262 with a kind error. It seems more uniform to treat 'seq' as it it
263 was a language construct.
265 See Note [seqId magic] in MkId, and
269 tcExpr (OpApp arg1 op fix arg2) res_ty
270 | (L loc (HsVar op_name)) <- op
271 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
272 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
273 ; let arg2_ty = res_ty
274 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
275 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
276 ; op_id <- tcLookupId op_name
277 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
278 ; return $ OpApp arg1' op' fix arg2' }
280 | (L loc (HsVar op_name)) <- op
281 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
282 = do { traceTc "Application rule" (ppr op)
283 ; (arg1', arg1_ty) <- tcInferRho arg1
284 ; let doc = ptext (sLit "The first argument of ($) takes")
285 ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
286 -- arg2_ty maybe polymorphic; that's the point
287 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
288 ; co_res <- unifyType op_res_ty res_ty
289 ; op_id <- tcLookupId op_name
290 ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
291 ; return $ mkHsWrapCoI co_res $
292 OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
295 = do { traceTc "Non Application rule" (ppr op)
296 ; (op', op_ty) <- tcInferFun op
297 ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
298 ; co_res <- unifyType op_res_ty res_ty
299 ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
300 ; return $ mkHsWrapCoI co_res $
301 OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
303 -- Right sections, equivalent to \ x -> x `op` expr, or
306 tcExpr (SectionR op arg2) res_ty
307 = do { (op', op_ty) <- tcInferFun op
308 ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
309 ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
310 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
311 ; return $ mkHsWrapCoI co_res $
312 SectionR (mkLHsWrapCoI co_fn op') arg2' }
314 tcExpr (SectionL arg1 op) res_ty
315 = do { (op', op_ty) <- tcInferFun op
316 ; dflags <- getDOpts -- Note [Left sections]
317 ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
320 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
321 ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
322 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
323 ; return $ mkHsWrapCoI co_res $
324 SectionL arg1' (mkLHsWrapCoI co_fn op') }
326 tcExpr (ExplicitTuple tup_args boxity) res_ty
327 | all tupArgPresent tup_args
328 = do { let tup_tc = tupleTyCon boxity (length tup_args)
329 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
330 ; tup_args1 <- tcTupArgs tup_args arg_tys
331 ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
334 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
335 do { let kind = case boxity of { Boxed -> liftedTypeKind
336 ; Unboxed -> argTypeKind }
337 arity = length tup_args
338 tup_tc = tupleTyCon boxity arity
340 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
342 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
343 (mkTyConApp tup_tc arg_tys)
345 ; coi <- unifyType actual_res_ty res_ty
347 -- Handle tuple sections where
348 ; tup_args1 <- tcTupArgs tup_args arg_tys
350 ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
352 tcExpr (ExplicitList _ exprs) res_ty
353 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
354 ; exprs' <- mapM (tc_elt elt_ty) exprs
355 ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
357 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
359 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
360 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
361 ; exprs' <- mapM (tc_elt elt_ty) exprs
362 ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
364 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
367 %************************************************************************
371 %************************************************************************
374 tcExpr (HsLet binds expr) res_ty
375 = do { (binds', expr') <- tcLocalBinds binds $
376 tcMonoExpr expr res_ty
377 ; return (HsLet binds' expr') }
379 tcExpr (HsCase scrut matches) exp_ty
380 = do { -- We used to typecheck the case alternatives first.
381 -- The case patterns tend to give good type info to use
382 -- when typechecking the scrutinee. For example
385 -- will report that map is applied to too few arguments
387 -- But now, in the GADT world, we need to typecheck the scrutinee
388 -- first, to get type info that may be refined in the case alternatives
389 (scrut', scrut_ty) <- tcInferRho scrut
391 ; traceTc "HsCase" (ppr scrut_ty)
392 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
393 ; return (HsCase scrut' matches') }
395 match_ctxt = MC { mc_what = CaseAlt,
398 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
399 = do { pred' <- tcMonoExpr pred boolTy
400 ; b1' <- tcMonoExpr b1 res_ty
401 ; b2' <- tcMonoExpr b2 res_ty
402 ; return (HsIf Nothing pred' b1' b2') }
404 tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
405 = do { pred_ty <- newFlexiTyVarTy openTypeKind
406 ; b1_ty <- newFlexiTyVarTy openTypeKind
407 ; b2_ty <- newFlexiTyVarTy openTypeKind
408 ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
409 ; fun' <- tcSyntaxOp IfOrigin fun if_ty
410 ; pred' <- tcMonoExpr pred pred_ty
411 ; b1' <- tcMonoExpr b1 b1_ty
412 ; b2' <- tcMonoExpr b2 b2_ty
413 -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
414 -- so maybe we should use the code for function applications
415 -- (which would allow ifThenElse to be higher rank).
416 -- But it's a little awkward, so I'm leaving it alone for now
417 -- and it maintains uniformity with other rebindable syntax
418 ; return (HsIf (Just fun') pred' b1' b2') }
420 tcExpr (HsDo do_or_lc stmts _) res_ty
421 = tcDoStmts do_or_lc stmts res_ty
423 tcExpr (HsProc pat cmd) res_ty
424 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
425 ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
427 tcExpr e@(HsArrApp _ _ _ _ _) _
428 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
429 ptext (sLit "was found where an expression was expected")])
431 tcExpr e@(HsArrForm _ _ _) _
432 = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
433 ptext (sLit "was found where an expression was expected")])
436 Note [Rebindable syntax for if]
437 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
438 The rebindable syntax for 'if' uses the most flexible possible type
440 ifThenElse :: p -> b1 -> b2 -> res
441 to support expressions like this:
443 ifThenElse :: Maybe a -> (a -> b) -> b -> b
444 ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e
452 %************************************************************************
454 Record construction and update
456 %************************************************************************
459 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
460 = do { data_con <- tcLookupDataCon con_name
462 -- Check for missing fields
463 ; checkMissingFields data_con rbinds
465 ; (con_expr, con_tau) <- tcInferId con_name
466 ; let arity = dataConSourceArity data_con
467 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
468 con_id = dataConWrapId data_con
470 ; co_res <- unifyType actual_res_ty res_ty
471 ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
472 ; return $ mkHsWrapCoI co_res $
473 RecordCon (L loc con_id) con_expr rbinds' }
476 Note [Type of a record update]
477 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 The main complication with RecordUpd is that we need to explicitly
479 handle the *non-updated* fields. Consider:
481 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
482 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
485 upd :: T a b c -> (b',c) -> T a b' c
486 upd t x = t { fb = x}
488 The result type should be (T a b' c)
489 not (T a b c), because 'b' *is not* mentioned in a non-updated field
490 not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field
491 NB that it's not good enough to look at just one constructor; we must
492 look at them all; cf Trac #3219
494 After all, upd should be equivalent to:
500 So we need to give a completely fresh type to the result record,
501 and then constrain it by the fields that are *not* updated ("p" above).
502 We call these the "fixed" type variables, and compute them in getFixedTyVars.
504 Note that because MkT3 doesn't contain all the fields being updated,
505 its RHS is simply an error, so it doesn't impose any type constraints.
506 Hence the use of 'relevant_cont'.
508 Note [Implict type sharing]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 We also take into account any "implicit" non-update fields. For example
511 data T a b where { MkT { f::a } :: T a a; ... }
512 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
517 upd :: T a b -> a -> T a b
518 upd (t::T a b) (x::a)
519 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
520 We can't give it the more general type
521 upd :: T a b -> c -> T c b
523 Note [Criteria for update]
524 ~~~~~~~~~~~~~~~~~~~~~~~~~~
525 We want to allow update for existentials etc, provided the updated
526 field isn't part of the existential. For example, this should be ok.
527 data T a where { MkT { f1::a, f2::b->b } :: T a }
531 The criterion we use is this:
533 The types of the updated fields
534 mention only the universally-quantified type variables
535 of the data constructor
537 NB: this is not (quite) the same as being a "naughty" record selector
538 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
539 in the case of GADTs. Consider
540 data T a where { MkT :: { f :: a } :: T [a] }
541 Then f is not "naughty" because it has a well-typed record selector.
542 But we don't allow updates for 'f'. (One could consider trying to
543 allow this, but it makes my head hurt. Badly. And no one has asked
546 In principle one could go further, and allow
548 g t = t { f2 = \x -> x }
549 because the expression is polymorphic...but that seems a bridge too far.
551 Note [Data family example]
552 ~~~~~~~~~~~~~~~~~~~~~~~~~~
553 data instance T (a,b) = MkT { x::a, y::b }
555 data :TP a b = MkT { a::a, y::b }
556 coTP a b :: T (a,b) ~ :TP a b
558 Suppose r :: T (t1,t2), e :: t3
559 Then r { x=e } :: T (t3,t1)
562 MkT x y -> MkT e y |> co2
563 where co1 :: T (t1,t2) ~ :TP t1 t2
564 co2 :: :TP t3 t2 ~ T (t3,t2)
565 The wrapping with co2 is done by the constructor wrapper for MkT
569 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
571 * cons are the data constructors to be updated
573 * in_inst_tys, out_inst_tys have same length, and instantiate the
574 *representation* tycon of the data cons. In Note [Data
575 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
578 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
579 = ASSERT( notNull upd_fld_names )
582 -- Check that the field names are really field names
583 ; sel_ids <- mapM tcLookupField upd_fld_names
584 -- The renamer has already checked that
585 -- selectors are all in scope
586 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
587 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
588 not (isRecordSelector sel_id), -- Excludes class ops
589 let L loc fld_name = hsRecFieldId fld ]
590 ; unless (null bad_guys) (sequence bad_guys >> failM)
593 -- Figure out the tycon and data cons from the first field name
594 ; let -- It's OK to use the non-tc splitters here (for a selector)
596 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
597 data_cons = tyConDataCons tycon -- it's not a field label
598 -- NB: for a data type family, the tycon is the instance tycon
600 relevant_cons = filter is_relevant data_cons
601 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
602 -- A constructor is only relevant to this process if
603 -- it contains *all* the fields that are being updated
604 -- Other ones will cause a runtime error if they occur
606 -- Take apart a representative constructor
607 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
608 (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
609 con1_flds = dataConFieldLabels con1
610 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
613 -- Check that at least one constructor has all the named fields
614 -- i.e. has an empty set of bad fields returned by badFields
615 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
617 -- STEP 3 Note [Criteria for update]
618 -- Check that each updated field is polymorphic; that is, its type
619 -- mentions only the universally-quantified variables of the data con
620 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
621 upd_flds1_w_tys = filter is_updated flds1_w_tys
622 is_updated (fld,_) = fld `elem` upd_fld_names
624 bad_upd_flds = filter bad_fld upd_flds1_w_tys
625 con1_tv_set = mkVarSet con1_tvs
626 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
627 not (tyVarsOfType ty `subVarSet` con1_tv_set)
628 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
630 -- STEP 4 Note [Type of a record update]
631 -- Figure out types for the scrutinee and result
632 -- Both are of form (T a b c), with fresh type variables, but with
633 -- common variables where the scrutinee and result must have the same type
634 -- These are variables that appear in *any* arg of *any* of the
635 -- relevant constructors *except* in the updated fields
637 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
638 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
639 mk_inst_ty tv result_inst_ty
640 | is_fixed_tv tv = return result_inst_ty -- Same as result type
641 | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
643 ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
644 ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
646 ; let rec_res_ty = substTy result_inst_env con1_res_ty
647 con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
648 scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
649 scrut_ty = substTy scrut_subst con1_res_ty
651 ; co_res <- unifyType rec_res_ty res_ty
654 -- Typecheck the thing to be updated, and the bindings
655 ; record_expr' <- tcMonoExpr record_expr scrut_ty
656 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
658 -- STEP 6: Deal with the stupid theta
659 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
660 ; instStupidTheta RecordUpdOrigin theta'
662 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
663 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
664 = WpCast $ mkTyConApp co_con scrut_inst_tys
668 ; return $ mkHsWrapCoI co_res $
669 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
670 relevant_cons scrut_inst_tys result_inst_tys }
672 upd_fld_names = hsRecFields rbinds
674 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
675 -- These tyvars must not change across the updates
676 getFixedTyVars tvs1 cons
677 = mkVarSet [tv1 | con <- cons
678 , let (tvs, theta, arg_tys, _) = dataConSig con
679 flds = dataConFieldLabels con
680 fixed_tvs = exactTyVarsOfTypes fixed_tys
681 -- fixed_tys: See Note [Type of a record update]
682 `unionVarSet` tyVarsOfTheta theta
683 -- Universally-quantified tyvars that
684 -- appear in any of the *implicit*
685 -- arguments to the constructor are fixed
686 -- See Note [Implict type sharing]
688 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
689 , not (fld `elem` upd_fld_names)]
690 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
691 , tv `elemVarSet` fixed_tvs ]
694 %************************************************************************
696 Arithmetic sequences e.g. [a,b..]
697 and their parallel-array counterparts e.g. [: a,b.. :]
700 %************************************************************************
703 tcExpr (ArithSeq _ seq@(From expr)) res_ty
704 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
705 ; expr' <- tcPolyExpr expr elt_ty
706 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
708 ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
710 tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
711 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
712 ; expr1' <- tcPolyExpr expr1 elt_ty
713 ; expr2' <- tcPolyExpr expr2 elt_ty
714 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
715 enumFromThenName elt_ty
716 ; return $ mkHsWrapCoI coi
717 (ArithSeq enum_from_then (FromThen expr1' expr2')) }
719 tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
720 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
721 ; expr1' <- tcPolyExpr expr1 elt_ty
722 ; expr2' <- tcPolyExpr expr2 elt_ty
723 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
724 enumFromToName elt_ty
725 ; return $ mkHsWrapCoI coi
726 (ArithSeq enum_from_to (FromTo expr1' expr2')) }
728 tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
729 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
730 ; expr1' <- tcPolyExpr expr1 elt_ty
731 ; expr2' <- tcPolyExpr expr2 elt_ty
732 ; expr3' <- tcPolyExpr expr3 elt_ty
733 ; eft <- newMethodFromName (ArithSeqOrigin seq)
734 enumFromThenToName elt_ty
735 ; return $ mkHsWrapCoI coi
736 (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
738 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
739 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
740 ; expr1' <- tcPolyExpr expr1 elt_ty
741 ; expr2' <- tcPolyExpr expr2 elt_ty
742 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
743 (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
744 ; return $ mkHsWrapCoI coi
745 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
747 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
748 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
749 ; expr1' <- tcPolyExpr expr1 elt_ty
750 ; expr2' <- tcPolyExpr expr2 elt_ty
751 ; expr3' <- tcPolyExpr expr3 elt_ty
752 ; eft <- newMethodFromName (PArrSeqOrigin seq)
753 (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
754 ; return $ mkHsWrapCoI coi
755 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
757 tcExpr (PArrSeq _ _) _
758 = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
759 -- the parser shouldn't have generated it and the renamer shouldn't have
764 %************************************************************************
768 %************************************************************************
771 #ifdef GHCI /* Only if bootstrapped */
772 -- Rename excludes these cases otherwise
773 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
774 tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
776 tcExpr e@(HsQuasiQuoteE _) _ =
777 pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
782 %************************************************************************
786 %************************************************************************
789 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
793 %************************************************************************
797 %************************************************************************
800 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
801 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
803 tcApp (L _ (HsPar e)) args res_ty
804 = tcApp e args res_ty
806 tcApp (L _ (HsApp e1 e2)) args res_ty
807 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
809 tcApp (L loc (HsVar fun)) args res_ty
810 | fun `hasKey` tagToEnumKey
812 = tcTagToEnum loc fun arg res_ty
814 tcApp fun args res_ty
815 = do { -- Type-check the function
816 ; (fun1, fun_tau) <- tcInferFun fun
818 -- Extract its argument types
819 ; (co_fun, expected_arg_tys, actual_res_ty)
820 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
822 -- Typecheck the result, thereby propagating
823 -- info (if any) from result into the argument types
824 -- Both actual_res_ty and res_ty are deeply skolemised
825 ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
826 unifyType actual_res_ty res_ty
828 -- Typecheck the arguments
829 ; args1 <- tcArgs fun args expected_arg_tys
831 -- Assemble the result
832 ; let fun2 = mkLHsWrapCoI co_fun fun1
833 app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
835 ; return (unLoc app) }
838 mk_app_msg :: LHsExpr Name -> SDoc
839 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
840 , ptext (sLit "is applied to")]
843 tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
844 -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
846 tcInferApp (L _ (HsPar e)) args = tcInferApp e args
847 tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
849 = -- Very like the tcApp version, except that there is
850 -- no expected result type passed in
851 do { (fun1, fun_tau) <- tcInferFun fun
852 ; (co_fun, expected_arg_tys, actual_res_ty)
853 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
854 ; args1 <- tcArgs fun args expected_arg_tys
855 ; let fun2 = mkLHsWrapCoI co_fun fun1
856 app = foldl mkHsApp fun2 args1
857 ; return (unLoc app, actual_res_ty) }
860 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
861 -- Infer and instantiate the type of a function
862 tcInferFun (L loc (HsVar name))
863 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
864 -- Don't wrap a context around a plain Id
865 ; return (L loc fun, ty) }
868 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
870 -- Zonk the function type carefully, to expose any polymorphism
871 -- E.g. (( \(x::forall a. a->a). blah ) e)
872 -- We can see the rank-2 type of the lambda in time to genrealise e
873 ; fun_ty' <- zonkTcTypeCarefully fun_ty
875 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
876 ; return (mkLHsWrap wrap fun, rho) }
879 tcArgs :: LHsExpr Name -- The function (for error messages)
880 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
881 -> TcM [LHsExpr TcId] -- Resulting args
883 tcArgs fun args expected_arg_tys
884 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
887 tcArg :: LHsExpr Name -- The function (for error messages)
888 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
889 -> TcM (LHsExpr TcId) -- Resulting argument
890 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
891 (tcPolyExprNC arg ty)
894 tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
896 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
898 go (Missing {}, arg_ty) = return (Missing arg_ty)
899 go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
900 ; return (Present expr') }
903 unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
904 -> TcM (CoercionI, [TcSigmaType], TcRhoType)
905 -- A wrapper for matchExpectedFunTys
906 unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
908 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
910 ---------------------------
911 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
912 -- Typecheck a syntax operator, checking that it has the specified type
913 -- The operator is always a variable at this stage (i.e. renamer output)
914 -- This version assumes res_ty is a monotype
915 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
916 ; tcWrapResult expr rho res_ty }
917 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
921 Note [Push result type in]
922 ~~~~~~~~~~~~~~~~~~~~~~~~~~
923 Unify with expected result before type-checking the args so that the
924 info from res_ty percolates to args. This is when we might detect a
925 too-few args situation. (One can think of cases when the opposite
926 order would give a better error message.)
927 experimenting with putting this first.
929 Here's an example where it actually makes a real difference
931 class C t a b | t a -> b
932 instance C Char a Bool
934 data P t a = forall b. (C t a b) => MkP b
935 data Q t = MkQ (forall a. P t a)
939 f2 = MkQ (MkP True :: forall a. P Char a)
941 With the change, f1 will type-check, because the 'Char' info from
942 the signature is propagated into MkQ's argument. With the check
943 in the other order, the extra signature in f2 is reqd.
946 %************************************************************************
950 %************************************************************************
953 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
954 tcCheckId name res_ty = do { (expr, rho) <- tcInferId name
955 ; tcWrapResult expr rho res_ty }
957 ------------------------
958 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
959 -- Infer type, and deeply instantiate
960 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
962 ------------------------
963 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
964 -- Look up an occurrence of an Id, and instantiate it (deeply)
966 tcInferIdWithOrig orig id_name
967 = do { id <- lookup_id
968 ; (id_expr, id_rho) <- instantiateOuter orig id
969 ; (wrap, rho) <- deeplyInstantiate orig id_rho
970 ; return (mkHsWrap wrap id_expr, rho) }
972 lookup_id :: TcM TcId
974 = do { thing <- tcLookup id_name
976 ATcId { tct_id = id, tct_level = lvl }
977 -> do { check_naughty id -- Note [Local record selectors]
978 ; checkThLocalId id lvl
982 -> do { check_naughty id; return id }
983 -- A global cannot possibly be ill-staged
984 -- nor does it need the 'lifting' treatment
985 -- hence no checkTh stuff here
987 AGlobal (ADataCon con) -> return (dataConWrapId con)
989 other -> failWithTc (bad_lookup other) }
991 bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
994 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
995 | otherwise = return ()
997 ------------------------
998 instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
999 -- Do just the first level of instantiation of an Id
1000 -- a) Deal with method sharing
1001 -- b) Deal with stupid checks
1002 -- Only look at the *outer level* of quantification
1003 -- See Note [Multiple instantiation]
1005 instantiateOuter orig id
1006 | null tvs && null theta
1007 = return (HsVar id, tau)
1010 = do { (_, tys, subst) <- tcInstTyVars tvs
1011 ; doStupidChecks id tys
1012 ; let theta' = substTheta subst theta
1013 ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
1014 ; wrap <- instCall orig tys theta'
1015 ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
1017 (tvs, theta, tau) = tcSplitSigmaTy (idType id)
1020 Note [Multiple instantiation]
1021 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1022 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
1023 For example, consider
1024 f :: forall a. Eq a => forall b. Ord b => a -> b
1025 At a call to f, at say [Int, Bool], it's tempting to translate the call to
1029 f_m1 :: forall b. Ord b => Int -> b
1033 f_m2 = f_m1 Bool dOrdBool
1035 But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
1036 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
1038 But it's entirely possible that f_m2 will continue to float out, because it
1039 mentions no type variables. Result, f_m1 isn't in scope.
1041 Here's a concrete example that does this (test tc200):
1044 f :: Eq b => b -> a -> Int
1045 baz :: Eq a => Int -> a -> Int
1047 instance C Int where
1050 Current solution: only do the "method sharing" thing for the first type/dict
1051 application, not for the iterated ones. A horribly subtle point.
1053 Note [No method sharing]
1054 ~~~~~~~~~~~~~~~~~~~~~~~~
1055 The -fno-method-sharing flag controls what happens so far as the LIE
1056 is concerned. The default case is that for an overloaded function we
1057 generate a "method" Id, and add the Method Inst to the LIE. So you get
1059 f :: Num a => a -> a
1060 f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
1061 If you specify -fno-method-sharing, the dictionary application
1062 isn't shared, so we get
1063 f :: Num a => a -> a
1064 f = /\a (d:Num a) (x:a) -> (+) a d x x
1065 This gets a bit less sharing, but
1066 a) it's better for RULEs involving overloaded functions
1067 b) perhaps fewer separated lambdas
1070 doStupidChecks :: TcId
1073 -- Check two tiresome and ad-hoc cases
1074 -- (a) the "stupid theta" for a data con; add the constraints
1075 -- from the "stupid theta" of a data constructor (sigh)
1077 doStupidChecks fun_id tys
1078 | Just con <- isDataConId_maybe fun_id -- (a)
1079 = addDataConStupidTheta con tys
1081 | fun_id `hasKey` tagToEnumKey -- (b)
1082 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1085 = return () -- The common case
1090 Nasty check to ensure that tagToEnum# is applied to a type that is an
1091 enumeration TyCon. Unification may refine the type later, but this
1092 check won't see that, alas. It's crude, because it relies on our
1093 knowing *now* that the type is ok, which in turn relies on the
1094 eager-unification part of the type checker pushing enough information
1095 here. In theory the Right Thing to do is to have a new form of
1096 constraint but I definitely cannot face that! And it works ok as-is.
1098 Here's are two cases that should fail
1100 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1103 g = tagToEnum# 0 -- Int is not an enumeration
1105 When data type families are involved it's a bit more complicated.
1107 data instance F [Int] = A | B | C
1108 Then we want to generate something like
1109 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1110 Usually that coercion is hidden inside the wrappers for
1111 constructors of F [Int] but here we have to do it explicitly.
1113 It's all grotesquely complicated.
1116 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1117 -- tagToEnum# :: forall a. Int# -> a
1118 -- See Note [tagToEnum#] Urgh!
1119 tcTagToEnum loc fun_name arg res_ty
1120 = do { fun <- tcLookupId fun_name
1121 ; ty' <- zonkTcType res_ty
1123 -- Check that the type is algebraic
1124 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1125 Just (tc, tc_args) = mb_tc_app
1126 ; checkTc (isJust mb_tc_app)
1127 (tagToEnumError ty' doc1)
1129 -- Look through any type family
1130 ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args
1132 ; checkTc (isEnumerationTyCon rep_tc)
1133 (tagToEnumError ty' doc2)
1135 ; arg' <- tcMonoExpr arg intPrimTy
1136 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1137 rep_ty = mkTyConApp rep_tc rep_args
1139 ; return (mkHsWrapCoI coi $ HsApp fun' arg') }
1141 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1142 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1143 doc2 = ptext (sLit "Result type must be an enumeration type")
1144 doc3 = ptext (sLit "No family instance for this type")
1146 get_rep_ty :: TcType -> TyCon -> [TcType]
1147 -> TcM (CoercionI, TyCon, [TcType])
1148 -- Converts a family type (eg F [a]) to its rep type (eg FList a)
1149 -- and returns a coercion between the two
1150 get_rep_ty ty tc tc_args
1151 | not (isFamilyTyCon tc)
1152 = return (IdCo ty, tc, tc_args)
1154 = do { mb_fam <- tcLookupFamInst tc tc_args
1156 Nothing -> failWithTc (tagToEnumError ty doc3)
1157 Just (rep_tc, rep_args)
1158 -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
1159 , rep_tc, rep_args )
1161 co_tc = expectJust "tcTagToEnum" $
1162 tyConFamilyCoercion_maybe rep_tc }
1164 tagToEnumError :: TcType -> SDoc -> SDoc
1165 tagToEnumError ty what
1166 = hang (ptext (sLit "Bad call to tagToEnum#")
1167 <+> ptext (sLit "at type") <+> ppr ty)
1172 %************************************************************************
1174 Template Haskell checks
1176 %************************************************************************
1179 checkThLocalId :: Id -> ThLevel -> TcM ()
1180 #ifndef GHCI /* GHCI and TH is off */
1181 --------------------------------------
1182 -- Check for cross-stage lifting
1183 checkThLocalId _id _bind_lvl
1186 #else /* GHCI and TH is on */
1187 checkThLocalId id bind_lvl
1188 = do { use_stage <- getStage -- TH case
1189 ; let use_lvl = thLevel use_stage
1190 ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
1191 ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
1192 ; when (use_lvl > bind_lvl) $
1193 checkCrossStageLifting id bind_lvl use_stage }
1195 --------------------------------------
1196 checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM ()
1197 -- We are inside brackets, and (use_lvl > bind_lvl)
1198 -- Now we must check whether there's a cross-stage lift to do
1199 -- Examples \x -> [| x |]
1202 checkCrossStageLifting _ _ Comp = return ()
1203 checkCrossStageLifting _ _ Splice = return ()
1205 checkCrossStageLifting id _ (Brack _ ps_var lie_var)
1207 = -- Top-level identifiers in this module,
1208 -- (which have External Names)
1209 -- are just like the imported case:
1210 -- no need for the 'lifting' treatment
1211 -- E.g. this is fine:
1214 -- But we do need to put f into the keep-alive
1215 -- set, because after desugaring the code will
1216 -- only mention f's *name*, not f itself.
1219 | otherwise -- bind_lvl = outerLevel presumably,
1220 -- but the Id is not bound at top level
1221 = -- Nested identifiers, such as 'x' in
1222 -- E.g. \x -> [| h x |]
1223 -- We must behave as if the reference to x was
1225 -- We use 'x' itself as the splice proxy, used by
1226 -- the desugarer to stitch it all back together.
1227 -- If 'x' occurs many times we may get many identical
1228 -- bindings of the same splice proxy, but that doesn't
1229 -- matter, although it's a mite untidy.
1230 do { let id_ty = idType id
1231 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1232 -- If x is polymorphic, its occurrence sites might
1233 -- have different instantiations, so we can't use plain
1234 -- 'x' as the splice proxy name. I don't know how to
1235 -- solve this, and it's probably unimportant, so I'm
1236 -- just going to flag an error for now
1238 ; lift <- if isStringTy id_ty then
1239 do { sid <- tcLookupId DsMeta.liftStringName
1240 -- See Note [Lifting strings]
1241 ; return (HsVar sid) }
1243 setConstraintVar lie_var $ do
1244 -- Put the 'lift' constraint into the right LIE
1245 newMethodFromName (OccurrenceOf (idName id))
1246 DsMeta.liftName id_ty
1248 -- Update the pending splices
1249 ; ps <- readMutVar ps_var
1250 ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
1256 Note [Lifting strings]
1257 ~~~~~~~~~~~~~~~~~~~~~~
1258 If we see $(... [| s |] ...) where s::String, we don't want to
1259 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1260 So this conditional short-circuits the lifting mechanism to generate
1261 (liftString "xy") in that case. I didn't want to use overlapping instances
1262 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1263 errors in a polymorphic situation.
1265 If this check fails (which isn't impossible) we get another chance; see
1266 Note [Converting strings] in Convert.lhs
1268 Local record selectors
1269 ~~~~~~~~~~~~~~~~~~~~~~
1270 Record selectors for TyCons in this module are ordinary local bindings,
1271 which show up as ATcIds rather than AGlobals. So we need to check for
1272 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1275 %************************************************************************
1277 \subsection{Record bindings}
1279 %************************************************************************
1281 Game plan for record bindings
1282 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1283 1. Find the TyCon for the bindings, from the first field label.
1285 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1287 For each binding field = value
1289 3. Instantiate the field type (from the field label) using the type
1292 4 Type check the value using tcArg, passing the field type as
1293 the expected argument type.
1295 This extends OK when the field types are universally quantified.
1301 -> [TcType] -- Expected type for each field
1302 -> HsRecordBinds Name
1303 -> TcM (HsRecordBinds TcId)
1305 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1306 = do { mb_binds <- mapM do_bind rbinds
1307 ; return (HsRecFields (catMaybes mb_binds) dd) }
1309 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1310 do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
1311 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1312 = addErrCtxt (fieldCtxt field_lbl) $
1313 do { rhs' <- tcPolyExprNC rhs field_ty
1314 ; let field_id = mkUserLocal (nameOccName field_lbl)
1315 (nameUnique field_lbl)
1317 -- Yuk: the field_id has the *unique* of the selector Id
1318 -- (so we can find it easily)
1319 -- but is a LocalId with the appropriate type of the RHS
1320 -- (so the desugarer knows the type of local binder to make)
1321 ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
1323 = do { addErrTc (badFieldCon data_con field_lbl)
1326 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1327 checkMissingFields data_con rbinds
1328 | null field_labels -- Not declared as a record;
1329 -- But C{} is still valid if no strict fields
1330 = if any isBanged field_strs then
1331 -- Illegal if any arg is strict
1332 addErrTc (missingStrictFields data_con [])
1336 | otherwise = do -- A record
1337 unless (null missing_s_fields)
1338 (addErrTc (missingStrictFields data_con missing_s_fields))
1340 warn <- doptM Opt_WarnMissingFields
1341 unless (not (warn && notNull missing_ns_fields))
1342 (warnTc True (missingFields data_con missing_ns_fields))
1346 = [ fl | (fl, str) <- field_info,
1348 not (fl `elem` field_names_used)
1351 = [ fl | (fl, str) <- field_info,
1353 not (fl `elem` field_names_used)
1356 field_names_used = hsRecFields rbinds
1357 field_labels = dataConFieldLabels data_con
1359 field_info = zipEqual "missingFields"
1363 field_strs = dataConStrictMarks data_con
1366 %************************************************************************
1368 \subsection{Errors and contexts}
1370 %************************************************************************
1372 Boring and alphabetical:
1374 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1375 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1377 exprCtxt :: LHsExpr Name -> SDoc
1379 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1381 fieldCtxt :: Name -> SDoc
1382 fieldCtxt field_name
1383 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1385 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1386 funAppCtxt fun arg arg_no
1387 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1388 quotes (ppr fun) <> text ", namely"])
1389 2 (quotes (ppr arg))
1391 funResCtxt :: LHsExpr Name -> TcType -> TcType
1392 -> TidyEnv -> TcM (TidyEnv, Message)
1393 -- When we have a mis-match in the return type of a function
1394 -- try to give a helpful message about too many/few arguments
1395 funResCtxt fun fun_res_ty res_ty env0
1396 = do { fun_res' <- zonkTcType fun_res_ty
1397 ; res' <- zonkTcType res_ty
1398 ; let n_fun = length (fst (tcSplitFunTys fun_res'))
1399 n_res = length (fst (tcSplitFunTys res'))
1400 what | n_fun > n_res = ptext (sLit "few")
1401 | otherwise = ptext (sLit "many")
1402 extra | n_fun == n_res = empty
1403 | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1404 <+> ptext (sLit "is applied to too") <+> what
1405 <+> ptext (sLit "arguments")
1406 msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
1407 ; return (env0, msg $$ extra) }
1409 badFieldTypes :: [(Name,TcType)] -> SDoc
1411 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1412 <> plural prs <> colon)
1413 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1415 badFieldsUpd :: HsRecFields Name a -> SDoc
1417 = hang (ptext (sLit "No constructor has all these fields:"))
1418 2 (pprQuotedList (hsRecFields rbinds))
1420 naughtyRecordSel :: TcId -> SDoc
1421 naughtyRecordSel sel_id
1422 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1423 ptext (sLit "as a function due to escaped type variables") $$
1424 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1426 notSelector :: Name -> SDoc
1428 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1430 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1431 missingStrictFields con fields
1434 rest | null fields = empty -- Happens for non-record constructors
1435 -- with strict fields
1436 | otherwise = colon <+> pprWithCommas ppr fields
1438 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1439 ptext (sLit "does not have the required strict field(s)")
1441 missingFields :: DataCon -> [FieldLabel] -> SDoc
1442 missingFields con fields
1443 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1444 <+> pprWithCommas ppr fields
1446 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1449 polySpliceErr :: Id -> SDoc
1451 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)