Disambiguate record selectors by type signature
[ghc.git] / compiler / typecheck / TcExpr.hs
1 {-
2 c%
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6 \section[TcExpr]{Typecheck an expression}
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11
12 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
13 tcInferRho, tcInferRhoNC,
14 tcSyntaxOp, tcCheckId,
15 addExprErrCtxt,
16 getFixedTyVars ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
21 import THNames( liftStringName, liftName )
22
23 import HsSyn
24 import TcHsSyn
25 import TcRnMonad
26 import TcUnify
27 import BasicTypes
28 import Inst
29 import TcBinds
30 import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
31 import FamInstEnv ( FamInstEnvs )
32 import RnEnv ( addUsedGRE, addNameClashErrRn
33 , unknownSubordinateErr )
34 import TcEnv
35 import TcArrows
36 import TcMatches
37 import TcHsType
38 import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
39 import TcPat
40 import TcMType
41 import TcType
42 import DsMonad
43 import Id
44 import IdInfo
45 import ConLike
46 import DataCon
47 import PatSyn
48 import Name
49 import RdrName
50 import TyCon
51 import Type
52 import TcEvidence
53 import Var
54 import VarSet
55 import VarEnv
56 import TysWiredIn
57 import TysPrim( intPrimTy )
58 import PrimOp( tagToEnumKey )
59 import PrelNames
60 import DynFlags
61 import SrcLoc
62 import Util
63 import ListSetOps
64 import Maybes
65 import ErrUtils
66 import Outputable
67 import FastString
68 import Control.Monad
69 import Class(classTyCon)
70 import Data.Function
71 import Data.List
72 import qualified Data.Set as Set
73
74 {-
75 ************************************************************************
76 * *
77 \subsection{Main wrappers}
78 * *
79 ************************************************************************
80 -}
81
82 tcPolyExpr, tcPolyExprNC
83 :: LHsExpr Name -- Expression to type check
84 -> TcSigmaType -- Expected type (could be a polytype)
85 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
86
87 -- tcPolyExpr is a convenient place (frequent but not too frequent)
88 -- place to add context information.
89 -- The NC version does not do so, usually because the caller wants
90 -- to do so himself.
91
92 tcPolyExpr expr res_ty
93 = addExprErrCtxt expr $
94 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
95
96 tcPolyExprNC expr res_ty
97 = do { traceTc "tcPolyExprNC" (ppr res_ty)
98 ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
99 tcMonoExprNC expr rho
100 ; return (mkLHsWrap gen_fn expr') }
101
102 ---------------
103 tcMonoExpr, tcMonoExprNC
104 :: LHsExpr Name -- Expression to type check
105 -> TcRhoType -- Expected type (could be a type variable)
106 -- Definitely no foralls at the top
107 -> TcM (LHsExpr TcId)
108
109 tcMonoExpr expr res_ty
110 = addErrCtxt (exprCtxt expr) $
111 tcMonoExprNC expr res_ty
112
113 tcMonoExprNC (L loc expr) res_ty
114 = ASSERT( not (isSigmaTy res_ty) )
115 setSrcSpan loc $
116 do { expr' <- tcExpr expr res_ty
117 ; return (L loc expr') }
118
119 ---------------
120 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
121 -- Infer a *rho*-type. This is, in effect, a special case
122 -- for ids and partial applications, so that if
123 -- f :: Int -> (forall a. a -> a) -> Int
124 -- then we can infer
125 -- f 3 :: (forall a. a -> a) -> Int
126 -- And that in turn is useful
127 -- (a) for the function part of any application (see tcApp)
128 -- (b) for the special rule for '$'
129 tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
130
131 tcInferRhoNC (L loc expr)
132 = setSrcSpan loc $
133 do { (expr', rho) <- tcInfer (tcExpr expr)
134 ; return (L loc expr', rho) }
135
136 tcUnboundId :: OccName -> TcRhoType -> TcM (HsExpr TcId)
137 -- Typechedk an occurrence of an unbound Id
138 --
139 -- Some of these started life as a true hole "_". Others might simply
140 -- be variables that accidentally have no binding site
141 --
142 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
143 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
144 -- not unbound any more!
145 tcUnboundId occ res_ty
146 = do { ty <- newFlexiTyVarTy liftedTypeKind
147 ; name <- newSysName occ
148 ; let ev = mkLocalId name ty
149 ; loc <- getCtLocM HoleOrigin
150 ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ
151 , cc_hole = ExprHole }
152 ; emitInsoluble can
153 ; tcWrapResult (HsVar ev) ty res_ty }
154
155 {-
156 ************************************************************************
157 * *
158 tcExpr: the main expression typechecker
159 * *
160 ************************************************************************
161 -}
162
163 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
164 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
165 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
166
167 tcExpr (HsVar name) res_ty = tcCheckId name res_ty
168 tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
169
170 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
171
172 tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
173 ; tcWrapResult (HsLit lit) lit_ty res_ty }
174
175 tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
176 ; return (HsPar expr') }
177
178 tcExpr (HsSCC src lbl expr) res_ty
179 = do { expr' <- tcMonoExpr expr res_ty
180 ; return (HsSCC src lbl expr') }
181
182 tcExpr (HsTickPragma src info expr) res_ty
183 = do { expr' <- tcMonoExpr expr res_ty
184 ; return (HsTickPragma src info expr') }
185
186 tcExpr (HsCoreAnn src lbl expr) res_ty
187 = do { expr' <- tcMonoExpr expr res_ty
188 ; return (HsCoreAnn src lbl expr') }
189
190 tcExpr (HsOverLit lit) res_ty
191 = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
192 ; return (HsOverLit lit') }
193
194 tcExpr (NegApp expr neg_expr) res_ty
195 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
196 (mkFunTy res_ty res_ty)
197 ; expr' <- tcMonoExpr expr res_ty
198 ; return (NegApp expr' neg_expr') }
199
200 tcExpr (HsIPVar x) res_ty
201 = do { let origin = IPOccOrigin x
202 {- Implicit parameters must have a *tau-type* not a.
203 type scheme. We enforce this by creating a fresh
204 type variable as its type. (Because res_ty may not
205 be a tau-type.) -}
206 ; ip_ty <- newFlexiTyVarTy openTypeKind
207 ; let ip_name = mkStrLitTy (hsIPNameFS x)
208 ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
209 ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty }
210 where
211 -- Coerces a dictionary for `IP "x" t` into `t`.
212 fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
213 unwrapIP $ mkClassPred ipClass [x,ty]
214
215 tcExpr (HsLam match) res_ty
216 = do { (co_fn, match') <- tcMatchLambda match res_ty
217 ; return (mkHsWrap co_fn (HsLam match')) }
218
219 tcExpr e@(HsLamCase _ matches) res_ty
220 = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
221 ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
222 ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
223 where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
224 , ptext (sLit "requires")]
225 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
226
227 tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
228 = tcWildcardBinders wcs $ \ wc_prs ->
229 do { addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
230 emitWildcardHoleConstraints wc_prs
231 ; sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
232 ; (gen_fn, expr')
233 <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
234
235 -- Remember to extend the lexical type-variable environment
236 -- See Note [More instantiated than scoped] in TcBinds
237 tcExtendTyVarEnv2
238 [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $
239
240 tcMonoExprNC expr res_ty
241
242 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
243
244 ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
245 ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
246
247 tcExpr (HsType ty) _
248 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
249 -- This is the syntax for type applications that I was planning
250 -- but there are difficulties (e.g. what order for type args)
251 -- so it's not enabled yet.
252 -- Can't eliminate it altogether from the parser, because the
253 -- same parser parses *patterns*.
254
255 {-
256 ************************************************************************
257 * *
258 Infix operators and sections
259 * *
260 ************************************************************************
261
262 Note [Left sections]
263 ~~~~~~~~~~~~~~~~~~~~
264 Left sections, like (4 *), are equivalent to
265 \ x -> (*) 4 x,
266 or, if PostfixOperators is enabled, just
267 (*) 4
268 With PostfixOperators we don't actually require the function to take
269 two arguments at all. For example, (x `not`) means (not x); you get
270 postfix operators! Not Haskell 98, but it's less work and kind of
271 useful.
272
273 Note [Typing rule for ($)]
274 ~~~~~~~~~~~~~~~~~~~~~~~~~~
275 People write
276 runST $ blah
277 so much, where
278 runST :: (forall s. ST s a) -> a
279 that I have finally given in and written a special type-checking
280 rule just for saturated appliations of ($).
281 * Infer the type of the first argument
282 * Decompose it; should be of form (arg2_ty -> res_ty),
283 where arg2_ty might be a polytype
284 * Use arg2_ty to typecheck arg2
285
286 Note [Typing rule for seq]
287 ~~~~~~~~~~~~~~~~~~~~~~~~~~
288 We want to allow
289 x `seq` (# p,q #)
290 which suggests this type for seq:
291 seq :: forall (a:*) (b:Open). a -> b -> b,
292 with (b:Open) meaning that be can be instantiated with an unboxed
293 tuple. The trouble is that this might accept a partially-applied
294 'seq', and I'm just not certain that would work. I'm only sure it's
295 only going to work when it's fully applied, so it turns into
296 case x of _ -> (# p,q #)
297
298 So it seems more uniform to treat 'seq' as it it was a language
299 construct.
300
301 See Note [seqId magic] in MkId, and
302 -}
303
304 tcExpr (OpApp arg1 op fix arg2) res_ty
305 | (L loc (HsVar op_name)) <- op
306 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
307 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
308 ; let arg2_ty = res_ty
309 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
310 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
311 ; op_id <- tcLookupId op_name
312 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
313 ; return $ OpApp arg1' op' fix arg2' }
314
315 | (L loc (HsVar op_name)) <- op
316 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
317 = do { traceTc "Application rule" (ppr op)
318 ; (arg1', arg1_ty) <- tcInferRho arg1
319
320 ; let doc = ptext (sLit "The first argument of ($) takes")
321 ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
322
323 -- We have (arg1 $ arg2)
324 -- So: arg1_ty = arg2_ty -> op_res_ty
325 -- where arg2_ty maybe polymorphic; that's the point
326
327 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
328 ; co_b <- unifyType op_res_ty res_ty -- op_res ~ res
329
330 -- Make sure that the argument type has kind '*'
331 -- ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r
332 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
333 -- (which gives a seg fault)
334 -- We do this by unifying with a MetaTv; but of course
335 -- it must allow foralls in the type it unifies with (hence ReturnTv)!
336 --
337 -- The *result* type can have any kind (Trac #8739),
338 -- so we don't need to check anything for that
339 ; a2_tv <- newReturnTyVar liftedTypeKind
340 ; let a2_ty = mkTyVarTy a2_tv
341 ; co_a <- unifyType arg2_ty a2_ty -- arg2 ~ a2
342
343 ; op_id <- tcLookupId op_name
344 ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id))
345 ; return $
346 OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $
347 mkLHsWrapCo co_arg1 arg1')
348 op' fix
349 (mkLHsWrapCo co_a arg2') }
350
351 | otherwise
352 = do { traceTc "Non Application rule" (ppr op)
353 ; (op', op_ty) <- tcInferFun op
354 ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
355 ; co_res <- unifyType op_res_ty res_ty
356 ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
357 ; return $ mkHsWrapCo co_res $
358 OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
359
360 -- Right sections, equivalent to \ x -> x `op` expr, or
361 -- \ x -> op x expr
362
363 tcExpr (SectionR op arg2) res_ty
364 = do { (op', op_ty) <- tcInferFun op
365 ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty
366 ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
367 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
368 ; return $ mkHsWrapCo co_res $
369 SectionR (mkLHsWrapCo co_fn op') arg2' }
370
371 tcExpr (SectionL arg1 op) res_ty
372 = do { (op', op_ty) <- tcInferFun op
373 ; dflags <- getDynFlags -- Note [Left sections]
374 ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
375 | otherwise = 2
376
377 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty
378 ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
379 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
380 ; return $ mkHsWrapCo co_res $
381 SectionL arg1' (mkLHsWrapCo co_fn op') }
382
383 tcExpr (ExplicitTuple tup_args boxity) res_ty
384 | all tupArgPresent tup_args
385 = do { let tup_tc = tupleTyCon boxity (length tup_args)
386 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
387 ; tup_args1 <- tcTupArgs tup_args arg_tys
388 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
389
390 | otherwise
391 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
392 do { let kind = case boxity of { Boxed -> liftedTypeKind
393 ; Unboxed -> openTypeKind }
394 arity = length tup_args
395 tup_tc = tupleTyCon boxity arity
396
397 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
398 ; let actual_res_ty
399 = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
400 (mkTyConApp tup_tc arg_tys)
401
402 ; coi <- unifyType actual_res_ty res_ty
403
404 -- Handle tuple sections where
405 ; tup_args1 <- tcTupArgs tup_args arg_tys
406
407 ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
408
409 tcExpr (ExplicitList _ witness exprs) res_ty
410 = case witness of
411 Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty
412 ; exprs' <- mapM (tc_elt elt_ty) exprs
413 ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') }
414
415 Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind
416 ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty)
417 ; (coi, elt_ty) <- matchExpectedListTy list_ty
418 ; exprs' <- mapM (tc_elt elt_ty) exprs
419 ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') }
420 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
421
422 tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
423 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
424 ; exprs' <- mapM (tc_elt elt_ty) exprs
425 ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
426 where
427 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
428
429 {-
430 ************************************************************************
431 * *
432 Let, case, if, do
433 * *
434 ************************************************************************
435 -}
436
437 tcExpr (HsLet binds expr) res_ty
438 = do { (binds', expr') <- tcLocalBinds binds $
439 tcMonoExpr expr res_ty
440 ; return (HsLet binds' expr') }
441
442 tcExpr (HsCase scrut matches) exp_ty
443 = do { -- We used to typecheck the case alternatives first.
444 -- The case patterns tend to give good type info to use
445 -- when typechecking the scrutinee. For example
446 -- case (map f) of
447 -- (x:xs) -> ...
448 -- will report that map is applied to too few arguments
449 --
450 -- But now, in the GADT world, we need to typecheck the scrutinee
451 -- first, to get type info that may be refined in the case alternatives
452 (scrut', scrut_ty) <- tcInferRho scrut
453
454 ; traceTc "HsCase" (ppr scrut_ty)
455 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
456 ; return (HsCase scrut' matches') }
457 where
458 match_ctxt = MC { mc_what = CaseAlt,
459 mc_body = tcBody }
460
461 tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
462 = do { pred' <- tcMonoExpr pred boolTy
463 ; b1' <- tcMonoExpr b1 res_ty
464 ; b2' <- tcMonoExpr b2 res_ty
465 ; return (HsIf Nothing pred' b1' b2') }
466
467 tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
468 = do { pred_ty <- newFlexiTyVarTy openTypeKind
469 ; b1_ty <- newFlexiTyVarTy openTypeKind
470 ; b2_ty <- newFlexiTyVarTy openTypeKind
471 ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
472 ; fun' <- tcSyntaxOp IfOrigin fun if_ty
473 ; pred' <- tcMonoExpr pred pred_ty
474 ; b1' <- tcMonoExpr b1 b1_ty
475 ; b2' <- tcMonoExpr b2 b2_ty
476 -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
477 -- so maybe we should use the code for function applications
478 -- (which would allow ifThenElse to be higher rank).
479 -- But it's a little awkward, so I'm leaving it alone for now
480 -- and it maintains uniformity with other rebindable syntax
481 ; return (HsIf (Just fun') pred' b1' b2') }
482
483 tcExpr (HsMultiIf _ alts) res_ty
484 = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
485 ; return $ HsMultiIf res_ty alts' }
486 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
487
488 tcExpr (HsDo do_or_lc stmts _) res_ty
489 = tcDoStmts do_or_lc stmts res_ty
490
491 tcExpr (HsProc pat cmd) res_ty
492 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
493 ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
494
495 tcExpr (HsStatic expr) res_ty
496 = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName
497 ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
498 ; (expr', lie) <- captureConstraints $
499 addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
500 2 (ppr expr)
501 ) $
502 tcPolyExprNC expr expr_ty
503 -- Require the type of the argument to be Typeable.
504 -- The evidence is not used, but asking the constraint ensures that
505 -- the current implementation is as restrictive as future versions
506 -- of the StaticPointers extension.
507 ; typeableClass <- tcLookupClass typeableClassName
508 ; _ <- emitWanted StaticOrigin $
509 mkTyConApp (classTyCon typeableClass)
510 [liftedTypeKind, expr_ty]
511 -- Insert the static form in a global list for later validation.
512 ; stWC <- tcg_static_wc <$> getGblEnv
513 ; updTcRef stWC (andWC lie)
514 ; return $ mkHsWrapCo co $ HsStatic expr'
515 }
516
517 {-
518 Note [Rebindable syntax for if]
519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
520 The rebindable syntax for 'if' uses the most flexible possible type
521 for conditionals:
522 ifThenElse :: p -> b1 -> b2 -> res
523 to support expressions like this:
524
525 ifThenElse :: Maybe a -> (a -> b) -> b -> b
526 ifThenElse (Just a) f _ = f a
527 ifThenElse Nothing _ e = e
528
529 example :: String
530 example = if Just 2
531 then \v -> show v
532 else "No value"
533
534
535 ************************************************************************
536 * *
537 Record construction and update
538 * *
539 ************************************************************************
540 -}
541
542 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
543 = do { con_like <- tcLookupConLike con_name
544
545 -- Check for missing fields
546 ; checkMissingFields con_like rbinds
547
548 ; (con_expr, con_tau) <- tcInferId con_name
549 ; let arity = conLikeArity con_like
550 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
551 ; case conLikeWrapId_maybe con_like of
552 Nothing -> nonBidirectionalErr (conLikeName con_like)
553 Just con_id -> do {
554 co_res <- unifyType actual_res_ty res_ty
555 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
556 ; return $ mkHsWrapCo co_res $
557 RecordCon (L loc con_id) con_expr rbinds' } }
558
559 {-
560 Note [Type of a record update]
561 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
562 The main complication with RecordUpd is that we need to explicitly
563 handle the *non-updated* fields. Consider:
564
565 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
566 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
567 | MkT3 { fd :: a }
568
569 upd :: T a b c -> (b',c) -> T a b' c
570 upd t x = t { fb = x}
571
572 The result type should be (T a b' c)
573 not (T a b c), because 'b' *is not* mentioned in a non-updated field
574 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
575 NB that it's not good enough to look at just one constructor; we must
576 look at them all; cf Trac #3219
577
578 After all, upd should be equivalent to:
579 upd t x = case t of
580 MkT1 p q -> MkT1 p x
581 MkT2 a b -> MkT2 p b
582 MkT3 d -> error ...
583
584 So we need to give a completely fresh type to the result record,
585 and then constrain it by the fields that are *not* updated ("p" above).
586 We call these the "fixed" type variables, and compute them in getFixedTyVars.
587
588 Note that because MkT3 doesn't contain all the fields being updated,
589 its RHS is simply an error, so it doesn't impose any type constraints.
590 Hence the use of 'relevant_cont'.
591
592 Note [Implicit type sharing]
593 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
594 We also take into account any "implicit" non-update fields. For example
595 data T a b where { MkT { f::a } :: T a a; ... }
596 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
597
598 Then consider
599 upd t x = t { f=x }
600 We infer the type
601 upd :: T a b -> a -> T a b
602 upd (t::T a b) (x::a)
603 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
604 We can't give it the more general type
605 upd :: T a b -> c -> T c b
606
607 Note [Criteria for update]
608 ~~~~~~~~~~~~~~~~~~~~~~~~~~
609 We want to allow update for existentials etc, provided the updated
610 field isn't part of the existential. For example, this should be ok.
611 data T a where { MkT { f1::a, f2::b->b } :: T a }
612 f :: T a -> b -> T b
613 f t b = t { f1=b }
614
615 The criterion we use is this:
616
617 The types of the updated fields
618 mention only the universally-quantified type variables
619 of the data constructor
620
621 NB: this is not (quite) the same as being a "naughty" record selector
622 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
623 in the case of GADTs. Consider
624 data T a where { MkT :: { f :: a } :: T [a] }
625 Then f is not "naughty" because it has a well-typed record selector.
626 But we don't allow updates for 'f'. (One could consider trying to
627 allow this, but it makes my head hurt. Badly. And no one has asked
628 for it.)
629
630 In principle one could go further, and allow
631 g :: T a -> T a
632 g t = t { f2 = \x -> x }
633 because the expression is polymorphic...but that seems a bridge too far.
634
635 Note [Data family example]
636 ~~~~~~~~~~~~~~~~~~~~~~~~~~
637 data instance T (a,b) = MkT { x::a, y::b }
638 --->
639 data :TP a b = MkT { a::a, y::b }
640 coTP a b :: T (a,b) ~ :TP a b
641
642 Suppose r :: T (t1,t2), e :: t3
643 Then r { x=e } :: T (t3,t1)
644 --->
645 case r |> co1 of
646 MkT x y -> MkT e y |> co2
647 where co1 :: T (t1,t2) ~ :TP t1 t2
648 co2 :: :TP t3 t2 ~ T (t3,t2)
649 The wrapping with co2 is done by the constructor wrapper for MkT
650
651 Outgoing invariants
652 ~~~~~~~~~~~~~~~~~~~
653 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
654
655 * cons are the data constructors to be updated
656
657 * in_inst_tys, out_inst_tys have same length, and instantiate the
658 *representation* tycon of the data cons. In Note [Data
659 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
660
661 Note [Mixed Record Field Updates]
662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
663
664 Consider the following pattern synonym.
665
666 data MyRec = MyRec { foo :: Int, qux :: String }
667
668 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
669
670 This allows updates such as the following
671
672 updater :: MyRec -> MyRec
673 updater a = a {f1 = 1 }
674
675 It would also make sense to allow the following update (which we reject).
676
677 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
678
679 This leads to confusing behaviour when the selectors in fact refer the same
680 field.
681
682 updater a = a {f1 = 1, foo = 2} ==? ???
683
684 For this reason, we reject a mixture of pattern synonym and normal record
685 selectors in the same update block. Although of course we still allow the
686 following.
687
688 updater a = (a {f1 = 1}) {foo = 2}
689
690 > updater (MyRec 0 "str")
691 MyRec 2 "str"
692
693 -}
694
695 tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
696 = ASSERT( notNull rbnds )
697 do {
698 -- STEP -1 See Note [Disambiguating record fields]
699 -- After this we know that rbinds is unambiguous
700 rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
701 ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
702 upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
703 sel_ids = map selectorAmbiguousFieldOcc upd_flds
704 -- STEP 0
705 -- Check that the field names are really field names
706 -- and they are all field names for proper records or
707 -- all field names for pattern synonyms.
708 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
709 | fld <- rbinds,
710 -- Excludes class ops
711 let L loc sel_id = hsRecUpdFieldId (unLoc fld),
712 not (isRecordSelector sel_id),
713 let fld_name = idName sel_id ]
714 ; unless (null bad_guys) (sequence bad_guys >> failM)
715 -- See note [Mixed Record Selectors]
716 ; let (data_sels, pat_syn_sels) =
717 partition isDataConRecordSelector sel_ids
718 ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
719 ; checkTc ( null data_sels || null pat_syn_sels )
720 ( mixedSelectors data_sels pat_syn_sels )
721
722 -- STEP 1
723 -- Figure out the tycon and data cons from the first field name
724 ; let -- It's OK to use the non-tc splitters here (for a selector)
725 sel_id : _ = sel_ids
726 mtycon =
727 case idDetails sel_id of
728 RecSelId (RecSelData tycon) _ -> Just tycon
729 _ -> Nothing
730 con_likes =
731 case idDetails sel_id of
732 RecSelId (RecSelData tc) _ ->
733 map RealDataCon (tyConDataCons tc)
734 RecSelId (RecSelPatSyn ps) _ ->
735 [PatSynCon ps]
736 _ -> panic "tcRecordUpd"
737 -- NB: for a data type family, the tycon is the instance tycon
738
739 relevant_cons = conLikesWithFields con_likes upd_fld_occs
740 -- A constructor is only relevant to this process if
741 -- it contains *all* the fields that are being updated
742 -- Other ones will cause a runtime error if they occur
743
744 -- Step 2
745 -- Check that at least one constructor has all the named fields
746 -- i.e. has an empty set of bad fields returned by badFields
747 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
748
749 -- Take apart a representative constructor
750 ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
751 (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) =
752 conLikeFullSig con1
753 con1_flds = map flLabel $ conLikeFieldLabels con1
754 def_res_ty = conLikeResTy con1
755 con1_res_ty =
756 (maybe def_res_ty mkFamilyTyConApp mtycon) (mkTyVarTys con1_tvs)
757
758 -- Check that we're not dealing with a unidirectional pattern
759 -- synonym
760 ; unless (isJust $ conLikeWrapId_maybe con1)
761 (nonBidirectionalErr (conLikeName con1))
762
763 -- STEP 3 Note [Criteria for update]
764 -- Check that each updated field is polymorphic; that is, its type
765 -- mentions only the universally-quantified variables of the data con
766 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
767 bad_upd_flds = filter bad_fld flds1_w_tys
768 con1_tv_set = mkVarSet con1_tvs
769 bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
770 not (tyVarsOfType ty `subVarSet` con1_tv_set)
771 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
772
773 -- STEP 4 Note [Type of a record update]
774 -- Figure out types for the scrutinee and result
775 -- Both are of form (T a b c), with fresh type variables, but with
776 -- common variables where the scrutinee and result must have the same type
777 -- These are variables that appear in *any* arg of *any* of the
778 -- relevant constructors *except* in the updated fields
779 --
780 ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
781 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
782
783 mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
784 -- Deals with instantiation of kind variables
785 -- c.f. TcMType.tcInstTyVars
786 mk_inst_ty subst (tv, result_inst_ty)
787 | is_fixed_tv tv -- Same as result type
788 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
789 | otherwise -- Fresh type, of correct kind
790 = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv))
791 ; return (extendTvSubst subst tv new_ty, new_ty) }
792
793 ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
794 ; let result_inst_tys = mkTyVarTys con1_tvs'
795
796 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst
797 (con1_tvs `zip` result_inst_tys)
798
799 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
800 scrut_ty = TcType.substTy scrut_subst con1_res_ty
801 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
802
803 ; co_res <- unifyType rec_res_ty res_ty
804
805 -- STEP 5
806 -- Typecheck the thing to be updated, and the bindings
807 ; record_expr' <- tcMonoExpr record_expr scrut_ty
808 ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds
809
810 -- STEP 6: Deal with the stupid theta
811 ; let theta' = substTheta scrut_subst (conLikeStupidTheta con1)
812 ; instStupidTheta RecordUpdOrigin theta'
813
814 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
815 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe =<< mtycon
816 = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys)
817 | otherwise
818 = idHsWrapper
819
820 -- Step 8: Check that the req constraints are satisfied
821 -- For normal data constructors req_theta is empty but we must do
822 -- this check for pattern synonyms.
823 ; let req_theta' = substTheta scrut_subst req_theta
824 ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
825
826 -- Phew!
827 ; return $ mkHsWrapCo co_res $
828 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
829 relevant_cons scrut_inst_tys result_inst_tys req_wrap }
830
831 tcExpr (HsRecFld f) res_ty
832 = tcCheckRecSelId f res_ty
833
834 {-
835 ************************************************************************
836 * *
837 Arithmetic sequences e.g. [a,b..]
838 and their parallel-array counterparts e.g. [: a,b.. :]
839
840 * *
841 ************************************************************************
842 -}
843
844 tcExpr (ArithSeq _ witness seq) res_ty
845 = tcArithSeq witness seq res_ty
846
847 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
848 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
849 ; expr1' <- tcPolyExpr expr1 elt_ty
850 ; expr2' <- tcPolyExpr expr2 elt_ty
851 ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
852 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
853 (idName enumFromToP) elt_ty
854 ; return $ mkHsWrapCo coi
855 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
856
857 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
858 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
859 ; expr1' <- tcPolyExpr expr1 elt_ty
860 ; expr2' <- tcPolyExpr expr2 elt_ty
861 ; expr3' <- tcPolyExpr expr3 elt_ty
862 ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
863 ; eft <- newMethodFromName (PArrSeqOrigin seq)
864 (idName enumFromThenToP) elt_ty -- !!!FIXME: chak
865 ; return $ mkHsWrapCo coi
866 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
867
868 tcExpr (PArrSeq _ _) _
869 = panic "TcExpr.tcExpr: Infinite parallel array!"
870 -- the parser shouldn't have generated it and the renamer shouldn't have
871 -- let it through
872
873 {-
874 ************************************************************************
875 * *
876 Template Haskell
877 * *
878 ************************************************************************
879 -}
880
881 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
882 tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty
883 tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
884
885 {-
886 ************************************************************************
887 * *
888 Catch-all
889 * *
890 ************************************************************************
891 -}
892
893 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
894 -- Include ArrForm, ArrApp, which shouldn't appear at all
895 -- Also HsTcBracketOut, HsQuasiQuoteE
896
897 {-
898 ************************************************************************
899 * *
900 Arithmetic sequences [a..b] etc
901 * *
902 ************************************************************************
903 -}
904
905 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
906 -> TcM (HsExpr TcId)
907
908 tcArithSeq witness seq@(From expr) res_ty
909 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
910 ; expr' <- tcPolyExpr expr elt_ty
911 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
912 enumFromName elt_ty
913 ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
914
915 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
916 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
917 ; expr1' <- tcPolyExpr expr1 elt_ty
918 ; expr2' <- tcPolyExpr expr2 elt_ty
919 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
920 enumFromThenName elt_ty
921 ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
922
923 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
924 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
925 ; expr1' <- tcPolyExpr expr1 elt_ty
926 ; expr2' <- tcPolyExpr expr2 elt_ty
927 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
928 enumFromToName elt_ty
929 ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
930
931 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
932 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
933 ; expr1' <- tcPolyExpr expr1 elt_ty
934 ; expr2' <- tcPolyExpr expr2 elt_ty
935 ; expr3' <- tcPolyExpr expr3 elt_ty
936 ; eft <- newMethodFromName (ArithSeqOrigin seq)
937 enumFromThenToName elt_ty
938 ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
939
940 -----------------
941 arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
942 -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id))
943 arithSeqEltType Nothing res_ty
944 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
945 ; return (coi, elt_ty, Nothing) }
946 arithSeqEltType (Just fl) res_ty
947 = do { list_ty <- newFlexiTyVarTy liftedTypeKind
948 ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
949 ; (coi, elt_ty) <- matchExpectedListTy list_ty
950 ; return (coi, elt_ty, Just fl') }
951
952 {-
953 ************************************************************************
954 * *
955 Applications
956 * *
957 ************************************************************************
958 -}
959
960 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
961 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
962
963 tcApp (L _ (HsPar e)) args res_ty
964 = tcApp e args res_ty
965
966 tcApp (L _ (HsApp e1 e2)) args res_ty
967 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
968
969 tcApp (L loc (HsVar fun)) args res_ty
970 | fun `hasKey` tagToEnumKey
971 , [arg] <- args
972 = tcTagToEnum loc fun arg res_ty
973
974 | fun `hasKey` seqIdKey
975 , [arg1,arg2] <- args
976 = tcSeq loc fun arg1 arg2 res_ty
977
978 -- Look for applications of ambiguous record selectors to arguments
979 -- with type signatures, see Note [Disambiguating record fields]
980 tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty
981 | Just sig_ty <- obviousSig arg
982 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
983 ; sel_name <- disambiguateSelector lbl sig_tc_ty
984 ; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty }
985
986 tcApp fun args res_ty
987 = do { -- Type-check the function
988 ; (fun1, fun_tau) <- tcInferFun fun
989
990 -- Extract its argument types
991 ; (co_fun, expected_arg_tys, actual_res_ty)
992 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
993
994 -- Typecheck the result, thereby propagating
995 -- info (if any) from result into the argument types
996 -- Both actual_res_ty and res_ty are deeply skolemised
997 -- Rather like tcWrapResult, but (perhaps for historical reasons)
998 -- we do this before typechecking the arguments
999 ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $
1000 tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty
1001
1002 -- Typecheck the arguments
1003 ; args1 <- tcArgs fun args expected_arg_tys
1004
1005 -- Assemble the result
1006 ; let fun2 = mkLHsWrapCo co_fun fun1
1007 app = mkLHsWrap wrap_res (foldl mkHsApp fun2 args1)
1008
1009 ; return (unLoc app) }
1010
1011
1012 mk_app_msg :: LHsExpr Name -> SDoc
1013 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
1014 , ptext (sLit "is applied to")]
1015
1016 ----------------
1017 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
1018 -- Infer and instantiate the type of a function
1019 tcInferFun (L loc (HsVar name))
1020 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
1021 -- Don't wrap a context around a plain Id
1022 ; return (L loc fun, ty) }
1023
1024 tcInferFun (L loc (HsRecFld f))
1025 = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
1026 -- Don't wrap a context around a plain Id
1027 ; return (L loc fun, ty) }
1028
1029 tcInferFun fun
1030 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
1031
1032 -- Zonk the function type carefully, to expose any polymorphism
1033 -- E.g. (( \(x::forall a. a->a). blah ) e)
1034 -- We can see the rank-2 type of the lambda in time to generalise e
1035 ; fun_ty' <- zonkTcType fun_ty
1036
1037 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
1038 ; return (mkLHsWrap wrap fun, rho) }
1039
1040 ----------------
1041 tcArgs :: LHsExpr Name -- The function (for error messages)
1042 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
1043 -> TcM [LHsExpr TcId] -- Resulting args
1044
1045 tcArgs fun args expected_arg_tys
1046 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
1047
1048 ----------------
1049 tcArg :: LHsExpr Name -- The function (for error messages)
1050 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
1051 -> TcM (LHsExpr TcId) -- Resulting argument
1052 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
1053 (tcPolyExprNC arg ty)
1054
1055 ----------------
1056 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
1057 tcTupArgs args tys
1058 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
1059 where
1060 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
1061 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
1062 ; return (L l (Present expr')) }
1063
1064 ----------------
1065 unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType
1066 -> TcM (TcCoercion, [TcSigmaType], TcRhoType)
1067 -- A wrapper for matchExpectedFunTys
1068 unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty
1069 where
1070 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
1071
1072 ---------------------------
1073 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
1074 -- Typecheck a syntax operator, checking that it has the specified type
1075 -- The operator is always a variable at this stage (i.e. renamer output)
1076 -- This version assumes res_ty is a monotype
1077 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op
1078 ; tcWrapResult expr rho res_ty }
1079 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
1080
1081 {-
1082 Note [Push result type in]
1083 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1084 Unify with expected result before type-checking the args so that the
1085 info from res_ty percolates to args. This is when we might detect a
1086 too-few args situation. (One can think of cases when the opposite
1087 order would give a better error message.)
1088 experimenting with putting this first.
1089
1090 Here's an example where it actually makes a real difference
1091
1092 class C t a b | t a -> b
1093 instance C Char a Bool
1094
1095 data P t a = forall b. (C t a b) => MkP b
1096 data Q t = MkQ (forall a. P t a)
1097
1098 f1, f2 :: Q Char;
1099 f1 = MkQ (MkP True)
1100 f2 = MkQ (MkP True :: forall a. P Char a)
1101
1102 With the change, f1 will type-check, because the 'Char' info from
1103 the signature is propagated into MkQ's argument. With the check
1104 in the other order, the extra signature in f2 is reqd.
1105
1106
1107 ************************************************************************
1108 * *
1109 tcInferId
1110 * *
1111 ************************************************************************
1112 -}
1113
1114 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
1115 tcCheckId name res_ty
1116 = do { (expr, actual_res_ty) <- tcInferId name
1117 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1118 ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
1119 tcWrapResult expr actual_res_ty res_ty }
1120
1121 tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
1122 tcCheckRecSelId f@(Unambiguous _ _) res_ty
1123 = do { (expr, actual_res_ty) <- tcInferRecSelId f
1124 ; addErrCtxtM (funResCtxt False (HsRecFld f) actual_res_ty res_ty) $
1125 tcWrapResult expr actual_res_ty res_ty }
1126 tcCheckRecSelId (Ambiguous lbl _) res_ty
1127 = case tcSplitFunTy_maybe res_ty of
1128 Nothing -> ambiguousSelector lbl
1129 Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
1130 ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
1131
1132 ------------------------
1133 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
1134 -- Infer type, and deeply instantiate
1135 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
1136
1137 tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
1138 tcInferRecSelId (Unambiguous lbl sel)
1139 = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
1140 tcInferRecSelId (Ambiguous lbl _)
1141 = ambiguousSelector lbl
1142
1143 ------------------------
1144 tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
1145 TcM (HsExpr TcId, TcRhoType)
1146 -- Look up an occurrence of an Id, and instantiate it (deeply)
1147 tcInferIdWithOrig orig lbl id_name
1148 | id_name `hasKey` tagToEnumKey
1149 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1150 -- tcApp catches the case (tagToEnum# arg)
1151
1152 | id_name `hasKey` assertIdKey
1153 = do { dflags <- getDynFlags
1154 ; if gopt Opt_IgnoreAsserts dflags
1155 then tc_infer_id orig lbl id_name
1156 else tc_infer_assert orig }
1157
1158 | otherwise
1159 = tc_infer_id orig lbl id_name
1160
1161 tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType)
1162 -- Deal with an occurrence of 'assert'
1163 -- See Note [Adding the implicit parameter to 'assert']
1164 tc_infer_assert orig
1165 = do { assert_error_id <- tcLookupId assertErrorName
1166 ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
1167 ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho)
1168 }
1169
1170 tc_infer_id :: CtOrigin -> RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
1171 -- Return type is deeply instantiated
1172 tc_infer_id orig lbl id_name
1173 = do { thing <- tcLookup id_name
1174 ; case thing of
1175 ATcId { tct_id = id }
1176 -> do { check_naughty id -- Note [Local record selectors]
1177 ; checkThLocalId id
1178 ; inst_normal_id id }
1179
1180 AGlobal (AnId id)
1181 -> do { check_naughty id
1182 ; inst_normal_id id }
1183 -- A global cannot possibly be ill-staged
1184 -- nor does it need the 'lifting' treatment
1185 -- hence no checkTh stuff here
1186
1187 AGlobal (AConLike cl) -> case cl of
1188 RealDataCon con -> inst_data_con con
1189 PatSynCon ps -> tcPatSynBuilderOcc orig ps
1190
1191 _ -> failWithTc $
1192 ppr thing <+> ptext (sLit "used where a value identifier was expected") }
1193 where
1194 inst_normal_id id
1195 = do { (wrap, rho) <- deeplyInstantiate orig (idType id)
1196 ; return (mkHsWrap wrap (HsVar id), rho) }
1197
1198 inst_data_con con
1199 -- For data constructors,
1200 -- * Must perform the stupid-theta check
1201 -- * No need to deeply instantiate because type has all foralls at top
1202 = do { let wrap_id = dataConWrapId con
1203 (tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
1204 ; (subst, tvs') <- tcInstTyVars tvs
1205 ; let tys' = mkTyVarTys tvs'
1206 theta' = substTheta subst theta
1207 rho' = substTy subst rho
1208 ; wrap <- instCall orig tys' theta'
1209 ; addDataConStupidTheta con tys'
1210 ; return (mkHsWrap wrap (HsVar wrap_id), rho') }
1211
1212 check_naughty id
1213 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
1214 | otherwise = return ()
1215
1216 {-
1217 Note [Adding the implicit parameter to 'assert']
1218 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1219 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
1220 This isn't really the Right Thing because there's no way to "undo"
1221 if you want to see the original source code in the typechecker
1222 output. We'll have fix this in due course, when we care more about
1223 being able to reconstruct the exact original program.
1224
1225 Note [tagToEnum#]
1226 ~~~~~~~~~~~~~~~~~
1227 Nasty check to ensure that tagToEnum# is applied to a type that is an
1228 enumeration TyCon. Unification may refine the type later, but this
1229 check won't see that, alas. It's crude, because it relies on our
1230 knowing *now* that the type is ok, which in turn relies on the
1231 eager-unification part of the type checker pushing enough information
1232 here. In theory the Right Thing to do is to have a new form of
1233 constraint but I definitely cannot face that! And it works ok as-is.
1234
1235 Here's are two cases that should fail
1236 f :: forall a. a
1237 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1238
1239 g :: Int
1240 g = tagToEnum# 0 -- Int is not an enumeration
1241
1242 When data type families are involved it's a bit more complicated.
1243 data family F a
1244 data instance F [Int] = A | B | C
1245 Then we want to generate something like
1246 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1247 Usually that coercion is hidden inside the wrappers for
1248 constructors of F [Int] but here we have to do it explicitly.
1249
1250 It's all grotesquely complicated.
1251 -}
1252
1253 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
1254 -> TcRhoType -> TcM (HsExpr TcId)
1255 -- (seq e1 e2) :: res_ty
1256 -- We need a special typing rule because res_ty can be unboxed
1257 -- See Note [Typing rule for seq]
1258 tcSeq loc fun_name arg1 arg2 res_ty
1259 = do { fun <- tcLookupId fun_name
1260 ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1)
1261 ; arg2' <- tcMonoExpr arg2 res_ty
1262 ; let fun' = L loc (HsWrap ty_args (HsVar fun))
1263 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1264 ; return (HsApp (L loc (HsApp fun' arg1')) arg2') }
1265
1266 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1267 -- tagToEnum# :: forall a. Int# -> a
1268 -- See Note [tagToEnum#] Urgh!
1269 tcTagToEnum loc fun_name arg res_ty
1270 = do { fun <- tcLookupId fun_name
1271 ; ty' <- zonkTcType res_ty
1272
1273 -- Check that the type is algebraic
1274 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1275 Just (tc, tc_args) = mb_tc_app
1276 ; checkTc (isJust mb_tc_app)
1277 (mk_error ty' doc1)
1278
1279 -- Look through any type family
1280 ; fam_envs <- tcGetFamInstEnvs
1281 ; let (rep_tc, rep_args, coi) = tcLookupDataFamInst fam_envs tc tc_args
1282 -- coi :: tc tc_args ~R rep_tc rep_args
1283
1284 ; checkTc (isEnumerationTyCon rep_tc)
1285 (mk_error ty' doc2)
1286
1287 ; arg' <- tcMonoExpr arg intPrimTy
1288 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1289 rep_ty = mkTyConApp rep_tc rep_args
1290
1291 ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $ HsApp fun' arg') }
1292 -- coi is a Representational coercion
1293 where
1294 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1295 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1296 doc2 = ptext (sLit "Result type must be an enumeration type")
1297
1298 mk_error :: TcType -> SDoc -> SDoc
1299 mk_error ty what
1300 = hang (ptext (sLit "Bad call to tagToEnum#")
1301 <+> ptext (sLit "at type") <+> ppr ty)
1302 2 what
1303
1304 {-
1305 ************************************************************************
1306 * *
1307 Template Haskell checks
1308 * *
1309 ************************************************************************
1310 -}
1311
1312 checkThLocalId :: Id -> TcM ()
1313 checkThLocalId id
1314 = do { mb_local_use <- getStageAndBindLevel (idName id)
1315 ; case mb_local_use of
1316 Just (top_lvl, bind_lvl, use_stage)
1317 | thLevel use_stage > bind_lvl
1318 , isNotTopLevel top_lvl
1319 -> checkCrossStageLifting id use_stage
1320 _ -> return () -- Not a locally-bound thing, or
1321 -- no cross-stage link
1322 }
1323
1324 --------------------------------------
1325 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1326 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1327 -- we must check whether there's a cross-stage lift to do
1328 -- Examples \x -> [|| x ||]
1329 -- [|| map ||]
1330 -- There is no error-checking to do, because the renamer did that
1331 --
1332 -- This is similar to checkCrossStageLifting in RnSplice, but
1333 -- this code is applied to *typed* brackets.
1334
1335 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1336 = -- Nested identifiers, such as 'x' in
1337 -- E.g. \x -> [|| h x ||]
1338 -- We must behave as if the reference to x was
1339 -- h $(lift x)
1340 -- We use 'x' itself as the splice proxy, used by
1341 -- the desugarer to stitch it all back together.
1342 -- If 'x' occurs many times we may get many identical
1343 -- bindings of the same splice proxy, but that doesn't
1344 -- matter, although it's a mite untidy.
1345 do { let id_ty = idType id
1346 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1347 -- If x is polymorphic, its occurrence sites might
1348 -- have different instantiations, so we can't use plain
1349 -- 'x' as the splice proxy name. I don't know how to
1350 -- solve this, and it's probably unimportant, so I'm
1351 -- just going to flag an error for now
1352
1353 ; lift <- if isStringTy id_ty then
1354 do { sid <- tcLookupId THNames.liftStringName
1355 -- See Note [Lifting strings]
1356 ; return (HsVar sid) }
1357 else
1358 setConstraintVar lie_var $
1359 -- Put the 'lift' constraint into the right LIE
1360 newMethodFromName (OccurrenceOf (idName id))
1361 THNames.liftName id_ty
1362
1363 -- Update the pending splices
1364 ; ps <- readMutVar ps_var
1365 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1366 ; writeMutVar ps_var (pending_splice : ps)
1367
1368 ; return () }
1369
1370 checkCrossStageLifting _ _ = return ()
1371
1372 polySpliceErr :: Id -> SDoc
1373 polySpliceErr id
1374 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1375
1376 {-
1377 Note [Lifting strings]
1378 ~~~~~~~~~~~~~~~~~~~~~~
1379 If we see $(... [| s |] ...) where s::String, we don't want to
1380 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1381 So this conditional short-circuits the lifting mechanism to generate
1382 (liftString "xy") in that case. I didn't want to use overlapping instances
1383 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1384 errors in a polymorphic situation.
1385
1386 If this check fails (which isn't impossible) we get another chance; see
1387 Note [Converting strings] in Convert.hs
1388
1389 Local record selectors
1390 ~~~~~~~~~~~~~~~~~~~~~~
1391 Record selectors for TyCons in this module are ordinary local bindings,
1392 which show up as ATcIds rather than AGlobals. So we need to check for
1393 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1394
1395
1396 ************************************************************************
1397 * *
1398 \subsection{Record bindings}
1399 * *
1400 ************************************************************************
1401 -}
1402
1403 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
1404 -- These tyvars must not change across the updates
1405 getFixedTyVars upd_fld_occs univ_tvs cons
1406 = mkVarSet [tv1 | con <- cons
1407 , let (u_tvs, _, eqspec, prov_theta
1408 , req_theta, arg_tys, _)
1409 = conLikeFullSig con
1410 theta = eqSpecPreds eqspec
1411 ++ prov_theta
1412 ++ req_theta
1413 flds = conLikeFieldLabels con
1414 fixed_tvs = exactTyVarsOfTypes fixed_tys
1415 -- fixed_tys: See Note [Type of a record update]
1416 `unionVarSet` tyVarsOfTypes theta
1417 -- Universally-quantified tyvars that
1418 -- appear in any of the *implicit*
1419 -- arguments to the constructor are fixed
1420 -- See Note [Implict type sharing]
1421
1422 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
1423 , not (flLabel fl `elem` upd_fld_occs)]
1424 , (tv1,tv) <- univ_tvs `zip` u_tvs
1425 , tv `elemVarSet` fixed_tvs ]
1426
1427 {-
1428 Note [Disambiguating record fields]
1429 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1430
1431 When the -XDuplicateRecordFields extension is used, and the renamer
1432 encounters a record selector or update that it cannot immediately
1433 disambiguate (because it involves fields that belong to multiple
1434 datatypes), it will defer resolution of the ambiguity to the
1435 typechecker. In this case, the `Ambiguous` constructor of
1436 `AmbiguousFieldOcc` is used.
1437
1438 Consider the following definitions:
1439
1440 data S = MkS { foo :: Int }
1441 data T = MkT { foo :: Int, bar :: Int }
1442 data U = MkU { bar :: Int, baz :: Int }
1443
1444 When the renamer sees `foo` as a selector or an update, it will not
1445 know which parent datatype is in use.
1446
1447 For selectors, there are two possible ways to disambiguate:
1448
1449 1. Check if the pushed-in type is a function whose domain is a
1450 datatype, for example:
1451
1452 f s = (foo :: S -> Int) s
1453
1454 g :: T -> Int
1455 g = foo
1456
1457 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
1458
1459 2. Check if the selector is applied to an argument that has a type
1460 signature, for example:
1461
1462 h = foo (s :: S)
1463
1464 This is checked by `tcApp`.
1465
1466
1467 Updates are slightly more complex. The `disambiguateRecordBinds`
1468 function tries to determine the parent datatype in three ways:
1469
1470 1. Check for types that have all the fields being updated. For example:
1471
1472 f x = x { foo = 3, bar = 2 }
1473
1474 Here `f` must be updating `T` because neither `S` nor `U` have
1475 both fields. This may also discover that no possible type exists.
1476 For example the following will be rejected:
1477
1478 f' x = x { foo = 3, baz = 3 }
1479
1480 2. Use the type being pushed in, if it is already a TyConApp. The
1481 following are valid updates to `T`:
1482
1483 g :: T -> T
1484 g x = x { foo = 3 }
1485
1486 g' x = x { foo = 3 } :: T
1487
1488 3. Use the type signature of the record expression, if it exists and
1489 is a TyConApp. Thus this is valid update to `T`:
1490
1491 h x = (x :: T) { foo = 3 }
1492
1493
1494 Note that we do not look up the types of variables being updated, and
1495 no constraint-solving is performed, so for example the following will
1496 be rejected as ambiguous:
1497
1498 let bad (s :: S) = foo s
1499
1500 let r :: T
1501 r = blah
1502 in r { foo = 3 }
1503
1504 \r. (r { foo = 3 }, r :: T )
1505
1506 We could add further tests, of a more heuristic nature. For example,
1507 rather than looking for an explicit signature, we could try to infer
1508 the type of the argument to a selector or the record expression being
1509 updated, in case we are lucky enough to get a TyConApp straight
1510 away. However, it might be hard for programmers to predict whether a
1511 particular update is sufficiently obvious for the signature to be
1512 omitted. Moreover, this might change the behaviour of typechecker in
1513 non-obvious ways.
1514
1515 See also Note [HsRecField and HsRecUpdField] in HsPat.
1516 -}
1517
1518 -- Given a RdrName that refers to multiple record fields, and the type
1519 -- of its argument, try to determine the name of the selector that is
1520 -- meant.
1521 disambiguateSelector :: RdrName -> Type -> RnM Name
1522 disambiguateSelector rdr parent_type
1523 = do { fam_inst_envs <- tcGetFamInstEnvs
1524 ; case tyConOf fam_inst_envs parent_type of
1525 Nothing -> ambiguousSelector rdr
1526 Just p ->
1527 do { xs <- lookupParents rdr
1528 ; let parent = RecSelData p
1529 ; case lookup parent xs of
1530 Just gre -> do { addUsedGRE True gre
1531 ; return (gre_name gre) }
1532 Nothing -> failWithTc (fieldNotInType parent rdr) } }
1533
1534 -- This field name really is ambiguous, so add a suitable "ambiguous
1535 -- occurrence" error, then give up.
1536 ambiguousSelector :: RdrName -> RnM a
1537 ambiguousSelector rdr
1538 = do { env <- getGlobalRdrEnv
1539 ; let gres = lookupGRE_RdrName rdr env
1540 ; setErrCtxt [] $ addNameClashErrRn rdr gres
1541 ; failM }
1542
1543 -- Disambiguate the fields in a record update.
1544 -- See Note [Disambiguating record fields]
1545 disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type
1546 -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
1547 disambiguateRecordBinds record_expr rbnds res_ty
1548 -- Are all the fields unambiguous?
1549 = case mapM isUnambiguous rbnds of
1550 -- If so, just skip to looking up the Ids
1551 -- Always the case if DuplicateRecordFields is off
1552 Just rbnds' -> mapM lookupSelector rbnds'
1553 Nothing -> -- If not, try to identify a single parent
1554 do { fam_inst_envs <- tcGetFamInstEnvs
1555 -- Look up the possible parents for each field
1556 ; rbnds_with_parents <- getUpdFieldsParents
1557 ; let possible_parents = map (map fst . snd) rbnds_with_parents
1558 -- Identify a single parent
1559 ; p <- identifyParent fam_inst_envs possible_parents
1560 -- Pick the right selector with that parent for each field
1561 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
1562 where
1563 -- Extract the selector name of a field update if it is unambiguous
1564 isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
1565 isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
1566 Unambiguous _ sel_name -> Just (x, sel_name)
1567 Ambiguous{} -> Nothing
1568
1569 -- Look up the possible parents and selector GREs for each field
1570 getUpdFieldsParents :: TcM [(LHsRecUpdField Name
1571 , [(RecSelParent, GlobalRdrElt)])]
1572 getUpdFieldsParents
1573 = fmap (zip rbnds) $ mapM
1574 (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
1575 rbnds
1576
1577 -- Given a the lists of possible parents for each field,
1578 -- identify a single parent
1579 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
1580 identifyParent fam_inst_envs possible_parents
1581 = case foldr1 intersect possible_parents of
1582 -- No parents for all fields: record update is ill-typed
1583 [] -> failWithTc (noPossibleParents rbnds)
1584 -- Exactly one datatype with all the fields: use that
1585 [p] -> return p
1586 -- Multiple possible parents: try harder to disambiguate
1587 -- Can we get a parent TyCon from the pushed-in type?
1588 _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
1589 -- Does the expression being updated have a type signature?
1590 -- If so, try to extract a parent TyCon from it
1591 | Just sig_ty <- obviousSig (unLoc record_expr)
1592 -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
1593 ; case tyConOf fam_inst_envs sig_tc_ty of
1594 Just p -> return (RecSelData p)
1595 Nothing -> failWithTc badOverloadedUpdate }
1596 -- Nothing else we can try...
1597 _ -> failWithTc badOverloadedUpdate
1598
1599 -- Make a field unambiguous by choosing the given parent.
1600 -- Emits an error if the field cannot have that parent,
1601 -- e.g. if the user writes
1602 -- r { x = e } :: T
1603 -- where T does not have field x.
1604 pickParent :: RecSelParent
1605 -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
1606 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
1607 pickParent p (upd, xs)
1608 = case lookup p xs of
1609 -- Phew! The parent is valid for this field.
1610 -- Previously ambiguous fields must be marked as
1611 -- used now that we know which one is meant, but
1612 -- unambiguous ones shouldn't be recorded again
1613 -- (giving duplicate deprecation warnings).
1614 Just gre -> do { unless (null (tail xs)) $ do
1615 let L loc _ = hsRecFieldLbl (unLoc upd)
1616 setSrcSpan loc $ addUsedGRE True gre
1617 ; lookupSelector (upd, gre_name gre) }
1618 -- The field doesn't belong to this parent, so report
1619 -- an error but keep going through all the fields
1620 Nothing -> do { addErrTc (fieldNotInType p
1621 (unLoc (hsRecUpdFieldRdr (unLoc upd))))
1622 ; lookupSelector (upd, gre_name (snd (head xs))) }
1623
1624 -- Given a (field update, selector name) pair, look up the
1625 -- selector to give a field update with an unambiguous Id
1626 lookupSelector :: (LHsRecUpdField Name, Name)
1627 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
1628 lookupSelector (L l upd, n)
1629 = do { i <- tcLookupId n
1630 ; let L loc af = hsRecFieldLbl upd
1631 lbl = rdrNameAmbiguousFieldOcc af
1632 ; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous lbl i) } }
1633
1634
1635 -- Extract the outermost TyCon of a type, if there is one; for
1636 -- data families this is the representation tycon (because that's
1637 -- where the fields live).
1638 tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
1639 tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
1640 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
1641 Nothing -> Nothing
1642
1643 -- For an ambiguous record field, find all the candidate record
1644 -- selectors (as GlobalRdrElts) and their parents.
1645 lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
1646 lookupParents rdr
1647 = do { env <- getGlobalRdrEnv
1648 ; let gres = lookupGRE_RdrName rdr env
1649 ; mapM lookupParent gres }
1650 where
1651 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
1652 lookupParent gre = do { id <- tcLookupId (gre_name gre)
1653 ; if isRecordSelector id
1654 then return (recordSelectorTyCon id, gre)
1655 else failWithTc (notSelector (gre_name gre)) }
1656
1657 -- A type signature on the argument of an ambiguous record selector or
1658 -- the record expression in an update must be "obvious", i.e. the
1659 -- outermost constructor ignoring parentheses.
1660 obviousSig :: HsExpr Name -> Maybe (LHsType Name)
1661 obviousSig (ExprWithTySig _ ty _) = Just ty
1662 obviousSig (HsPar p) = obviousSig (unLoc p)
1663 obviousSig _ = Nothing
1664
1665
1666 {-
1667 Game plan for record bindings
1668 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1669 1. Find the TyCon for the bindings, from the first field label.
1670
1671 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1672
1673 For each binding field = value
1674
1675 3. Instantiate the field type (from the field label) using the type
1676 envt from step 2.
1677
1678 4 Type check the value using tcArg, passing the field type as
1679 the expected argument type.
1680
1681 This extends OK when the field types are universally quantified.
1682 -}
1683
1684 tcRecordBinds
1685 :: ConLike
1686 -> [TcType] -- Expected type for each field
1687 -> HsRecordBinds Name
1688 -> TcM (HsRecordBinds TcId)
1689
1690 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
1691 = do { mb_binds <- mapM do_bind rbinds
1692 ; return (HsRecFields (catMaybes mb_binds) dd) }
1693 where
1694 fields = map flLabel $ conLikeFieldLabels con_like
1695 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
1696
1697 do_bind :: LHsRecField Name (LHsExpr Name)
1698 -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
1699 do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
1700 , hsRecFieldArg = rhs }))
1701
1702 = do { mb <- tcRecordField con_like flds_w_tys f rhs
1703 ; case mb of
1704 Nothing -> return Nothing
1705 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
1706 , hsRecFieldArg = rhs' }))) }
1707
1708 tcRecordUpd
1709 :: ConLike
1710 -> [TcType] -- Expected type for each field
1711 -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
1712 -> TcM [LHsRecUpdField TcId]
1713
1714 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
1715 where
1716 flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
1717
1718 do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
1719 do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
1720 , hsRecFieldArg = rhs }))
1721 = do { let lbl = rdrNameAmbiguousFieldOcc af
1722 sel_id = selectorAmbiguousFieldOcc af
1723 f = L loc (FieldOcc lbl (idName sel_id))
1724 ; mb <- tcRecordField con_like flds_w_tys f rhs
1725 ; case mb of
1726 Nothing -> return Nothing
1727 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = L loc (Unambiguous lbl (selectorFieldOcc (unLoc f')))
1728 , hsRecFieldArg = rhs' }))) }
1729
1730 tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
1731 -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
1732 tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
1733 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1734 = addErrCtxt (fieldCtxt field_lbl) $
1735 do { rhs' <- tcPolyExprNC rhs field_ty
1736 ; let field_id = mkUserLocal (nameOccName sel_name)
1737 (nameUnique sel_name)
1738 field_ty loc
1739 -- Yuk: the field_id has the *unique* of the selector Id
1740 -- (so we can find it easily)
1741 -- but is a LocalId with the appropriate type of the RHS
1742 -- (so the desugarer knows the type of local binder to make)
1743 ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
1744 | otherwise
1745 = do { addErrTc (badFieldCon con_like field_lbl)
1746 ; return Nothing }
1747 where
1748 field_lbl = occNameFS $ rdrNameOcc lbl
1749
1750
1751 checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
1752 checkMissingFields con_like rbinds
1753 | null field_labels -- Not declared as a record;
1754 -- But C{} is still valid if no strict fields
1755 = if any isBanged field_strs then
1756 -- Illegal if any arg is strict
1757 addErrTc (missingStrictFields con_like [])
1758 else
1759 return ()
1760
1761 | otherwise = do -- A record
1762 unless (null missing_s_fields)
1763 (addErrTc (missingStrictFields con_like missing_s_fields))
1764
1765 warn <- woptM Opt_WarnMissingFields
1766 unless (not (warn && notNull missing_ns_fields))
1767 (warnTc True (missingFields con_like missing_ns_fields))
1768
1769 where
1770 missing_s_fields
1771 = [ flLabel fl | (fl, str) <- field_info,
1772 isBanged str,
1773 not (fl `elemField` field_names_used)
1774 ]
1775 missing_ns_fields
1776 = [ flLabel fl | (fl, str) <- field_info,
1777 not (isBanged str),
1778 not (fl `elemField` field_names_used)
1779 ]
1780
1781 field_names_used = hsRecFields rbinds
1782 field_labels = conLikeFieldLabels con_like
1783
1784 field_info = zipEqual "missingFields"
1785 field_labels
1786 field_strs
1787
1788 field_strs = conLikeImplBangs con_like
1789
1790 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
1791
1792 {-
1793 ************************************************************************
1794 * *
1795 \subsection{Errors and contexts}
1796 * *
1797 ************************************************************************
1798
1799 Boring and alphabetical:
1800 -}
1801
1802 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1803 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1804
1805 exprCtxt :: LHsExpr Name -> SDoc
1806 exprCtxt expr
1807 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1808
1809 fieldCtxt :: FieldLabelString -> SDoc
1810 fieldCtxt field_name
1811 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1812
1813 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1814 funAppCtxt fun arg arg_no
1815 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1816 quotes (ppr fun) <> text ", namely"])
1817 2 (quotes (ppr arg))
1818
1819 funResCtxt :: Bool -- There is at least one argument
1820 -> HsExpr Name -> TcType -> TcType
1821 -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1822 -- When we have a mis-match in the return type of a function
1823 -- try to give a helpful message about too many/few arguments
1824 --
1825 -- Used for naked variables too; but with has_args = False
1826 funResCtxt has_args fun fun_res_ty env_ty tidy_env
1827 = do { fun_res' <- zonkTcType fun_res_ty
1828 ; env' <- zonkTcType env_ty
1829 ; let (args_fun, res_fun) = tcSplitFunTys fun_res'
1830 (args_env, res_env) = tcSplitFunTys env'
1831 n_fun = length args_fun
1832 n_env = length args_env
1833 info | n_fun == n_env = Outputable.empty
1834 | n_fun > n_env
1835 , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1836 <+> ptext (sLit "is applied to too few arguments")
1837 | has_args
1838 , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun)
1839 <+> ptext (sLit "is applied to too many arguments")
1840 | otherwise = Outputable.empty -- Never suggest that a naked variable is
1841 -- applied to too many args!
1842 ; return (tidy_env, info) }
1843 where
1844 not_fun ty -- ty is definitely not an arrow type,
1845 -- and cannot conceivably become one
1846 = case tcSplitTyConApp_maybe ty of
1847 Just (tc, _) -> isAlgTyCon tc
1848 Nothing -> False
1849
1850 badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
1851 badFieldTypes prs
1852 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1853 <> plural prs <> colon)
1854 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1855
1856 badFieldsUpd
1857 :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon
1858 -> [ConLike] -- Data cons of the type which the first field name belongs to
1859 -> SDoc
1860 badFieldsUpd rbinds data_cons
1861 = hang (ptext (sLit "No constructor has all these fields:"))
1862 2 (pprQuotedList conflictingFields)
1863 -- See Note [Finding the conflicting fields]
1864 where
1865 -- A (preferably small) set of fields such that no constructor contains
1866 -- all of them. See Note [Finding the conflicting fields]
1867 conflictingFields = case nonMembers of
1868 -- nonMember belongs to a different type.
1869 (nonMember, _) : _ -> [aMember, nonMember]
1870 [] -> let
1871 -- All of rbinds belong to one type. In this case, repeatedly add
1872 -- a field to the set until no constructor contains the set.
1873
1874 -- Each field, together with a list indicating which constructors
1875 -- have all the fields so far.
1876 growingSets :: [(FieldLabelString, [Bool])]
1877 growingSets = scanl1 combine membership
1878 combine (_, setMem) (field, fldMem)
1879 = (field, zipWith (&&) setMem fldMem)
1880 in
1881 -- Fields that don't change the membership status of the set
1882 -- are redundant and can be dropped.
1883 map (fst . head) $ groupBy ((==) `on` snd) growingSets
1884
1885 aMember = ASSERT( not (null members) ) fst (head members)
1886 (members, nonMembers) = partition (or . snd) membership
1887
1888 -- For each field, which constructors contain the field?
1889 membership :: [(FieldLabelString, [Bool])]
1890 membership = sortMembership $
1891 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
1892 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
1893
1894 fieldLabelSets :: [Set.Set FieldLabelString]
1895 fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
1896
1897 -- Sort in order of increasing number of True, so that a smaller
1898 -- conflicting set can be found.
1899 sortMembership =
1900 map snd .
1901 sortBy (compare `on` fst) .
1902 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
1903
1904 countTrue = length . filter id
1905
1906 {-
1907 Note [Finding the conflicting fields]
1908 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1909 Suppose we have
1910 data A = A {a0, a1 :: Int}
1911 | B {b0, b1 :: Int}
1912 and we see a record update
1913 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
1914 Then we'd like to find the smallest subset of fields that no
1915 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
1916 We don't really want to report that no constructor has all of
1917 {a0,a1,b0,b1}, because when there are hundreds of fields it's
1918 hard to see what was really wrong.
1919
1920 We may need more than two fields, though; eg
1921 data T = A { x,y :: Int, v::Int }
1922 | B { y,z :: Int, v::Int }
1923 | C { z,x :: Int, v::Int }
1924 with update
1925 r { x=e1, y=e2, z=e3 }, we
1926
1927 Finding the smallest subset is hard, so the code here makes
1928 a decent stab, no more. See Trac #7989.
1929 -}
1930
1931 naughtyRecordSel :: RdrName -> SDoc
1932 naughtyRecordSel sel_id
1933 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1934 ptext (sLit "as a function due to escaped type variables") $$
1935 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1936
1937 notSelector :: Name -> SDoc
1938 notSelector field
1939 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1940
1941 mixedSelectors :: [Id] -> [Id] -> SDoc
1942 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
1943 = ptext
1944 (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
1945 ptext (sLit "Record selectors defined by")
1946 <+> quotes (ppr (tyConName rep_dc))
1947 <> text ":"
1948 <+> pprWithCommas ppr data_sels $$
1949 ptext (sLit "Pattern synonym selectors defined by")
1950 <+> quotes (ppr (patSynName rep_ps))
1951 <> text ":"
1952 <+> pprWithCommas ppr pat_syn_sels
1953 where
1954 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
1955 RecSelData rep_dc = recordSelectorTyCon dc_rep_id
1956 mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
1957
1958
1959 missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
1960 missingStrictFields con fields
1961 = header <> rest
1962 where
1963 rest | null fields = Outputable.empty -- Happens for non-record constructors
1964 -- with strict fields
1965 | otherwise = colon <+> pprWithCommas ppr fields
1966
1967 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1968 ptext (sLit "does not have the required strict field(s)")
1969
1970 missingFields :: ConLike -> [FieldLabelString] -> SDoc
1971 missingFields con fields
1972 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1973 <+> pprWithCommas ppr fields
1974
1975 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1976
1977 noPossibleParents :: [LHsRecUpdField Name] -> SDoc
1978 noPossibleParents rbinds
1979 = hang (ptext (sLit "No type has all these fields:"))
1980 2 (pprQuotedList fields)
1981 where
1982 fields = map (hsRecFieldLbl . unLoc) rbinds
1983
1984 badOverloadedUpdate :: SDoc
1985 badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
1986
1987 fieldNotInType :: RecSelParent -> RdrName -> SDoc
1988 fieldNotInType p rdr
1989 = unknownSubordinateErr (ptext (sLit "field of type") <+> quotes (ppr p)) rdr