Remove PatSynBuilderId
[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 labels = conLikeFieldLabels con_like
552 ; case conLikeWrapId_maybe con_like of
553 Nothing -> nonBidirectionalErr (conLikeName con_like)
554 Just con_id -> do {
555 co_res <- unifyType actual_res_ty res_ty
556 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
557 ; return $ mkHsWrapCo co_res $
558 RecordCon (L loc con_id) con_expr rbinds' labels } }
559
560 {-
561 Note [Type of a record update]
562 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
563 The main complication with RecordUpd is that we need to explicitly
564 handle the *non-updated* fields. Consider:
565
566 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
567 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
568 | MkT3 { fd :: a }
569
570 upd :: T a b c -> (b',c) -> T a b' c
571 upd t x = t { fb = x}
572
573 The result type should be (T a b' c)
574 not (T a b c), because 'b' *is not* mentioned in a non-updated field
575 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
576 NB that it's not good enough to look at just one constructor; we must
577 look at them all; cf Trac #3219
578
579 After all, upd should be equivalent to:
580 upd t x = case t of
581 MkT1 p q -> MkT1 p x
582 MkT2 a b -> MkT2 p b
583 MkT3 d -> error ...
584
585 So we need to give a completely fresh type to the result record,
586 and then constrain it by the fields that are *not* updated ("p" above).
587 We call these the "fixed" type variables, and compute them in getFixedTyVars.
588
589 Note that because MkT3 doesn't contain all the fields being updated,
590 its RHS is simply an error, so it doesn't impose any type constraints.
591 Hence the use of 'relevant_cont'.
592
593 Note [Implicit type sharing]
594 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
595 We also take into account any "implicit" non-update fields. For example
596 data T a b where { MkT { f::a } :: T a a; ... }
597 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
598
599 Then consider
600 upd t x = t { f=x }
601 We infer the type
602 upd :: T a b -> a -> T a b
603 upd (t::T a b) (x::a)
604 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
605 We can't give it the more general type
606 upd :: T a b -> c -> T c b
607
608 Note [Criteria for update]
609 ~~~~~~~~~~~~~~~~~~~~~~~~~~
610 We want to allow update for existentials etc, provided the updated
611 field isn't part of the existential. For example, this should be ok.
612 data T a where { MkT { f1::a, f2::b->b } :: T a }
613 f :: T a -> b -> T b
614 f t b = t { f1=b }
615
616 The criterion we use is this:
617
618 The types of the updated fields
619 mention only the universally-quantified type variables
620 of the data constructor
621
622 NB: this is not (quite) the same as being a "naughty" record selector
623 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
624 in the case of GADTs. Consider
625 data T a where { MkT :: { f :: a } :: T [a] }
626 Then f is not "naughty" because it has a well-typed record selector.
627 But we don't allow updates for 'f'. (One could consider trying to
628 allow this, but it makes my head hurt. Badly. And no one has asked
629 for it.)
630
631 In principle one could go further, and allow
632 g :: T a -> T a
633 g t = t { f2 = \x -> x }
634 because the expression is polymorphic...but that seems a bridge too far.
635
636 Note [Data family example]
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~
638 data instance T (a,b) = MkT { x::a, y::b }
639 --->
640 data :TP a b = MkT { a::a, y::b }
641 coTP a b :: T (a,b) ~ :TP a b
642
643 Suppose r :: T (t1,t2), e :: t3
644 Then r { x=e } :: T (t3,t1)
645 --->
646 case r |> co1 of
647 MkT x y -> MkT e y |> co2
648 where co1 :: T (t1,t2) ~ :TP t1 t2
649 co2 :: :TP t3 t2 ~ T (t3,t2)
650 The wrapping with co2 is done by the constructor wrapper for MkT
651
652 Outgoing invariants
653 ~~~~~~~~~~~~~~~~~~~
654 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
655
656 * cons are the data constructors to be updated
657
658 * in_inst_tys, out_inst_tys have same length, and instantiate the
659 *representation* tycon of the data cons. In Note [Data
660 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
661
662 Note [Mixed Record Field Updates]
663 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
664
665 Consider the following pattern synonym.
666
667 data MyRec = MyRec { foo :: Int, qux :: String }
668
669 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
670
671 This allows updates such as the following
672
673 updater :: MyRec -> MyRec
674 updater a = a {f1 = 1 }
675
676 It would also make sense to allow the following update (which we reject).
677
678 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
679
680 This leads to confusing behaviour when the selectors in fact refer the same
681 field.
682
683 updater a = a {f1 = 1, foo = 2} ==? ???
684
685 For this reason, we reject a mixture of pattern synonym and normal record
686 selectors in the same update block. Although of course we still allow the
687 following.
688
689 updater a = (a {f1 = 1}) {foo = 2}
690
691 > updater (MyRec 0 "str")
692 MyRec 2 "str"
693
694 -}
695
696 tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
697 = ASSERT( notNull rbnds )
698 do {
699 -- STEP -1 See Note [Disambiguating record fields]
700 -- After this we know that rbinds is unambiguous
701 rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
702 ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
703 upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
704 sel_ids = map selectorAmbiguousFieldOcc upd_flds
705 -- STEP 0
706 -- Check that the field names are really field names
707 -- and they are all field names for proper records or
708 -- all field names for pattern synonyms.
709 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
710 | fld <- rbinds,
711 -- Excludes class ops
712 let L loc sel_id = hsRecUpdFieldId (unLoc fld),
713 not (isRecordSelector sel_id),
714 let fld_name = idName sel_id ]
715 ; unless (null bad_guys) (sequence bad_guys >> failM)
716 -- See note [Mixed Record Selectors]
717 ; let (data_sels, pat_syn_sels) =
718 partition isDataConRecordSelector sel_ids
719 ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
720 ; checkTc ( null data_sels || null pat_syn_sels )
721 ( mixedSelectors data_sels pat_syn_sels )
722
723 -- STEP 1
724 -- Figure out the tycon and data cons from the first field name
725 ; let -- It's OK to use the non-tc splitters here (for a selector)
726 sel_id : _ = sel_ids
727 mtycon =
728 case idDetails sel_id of
729 RecSelId (RecSelData tycon) _ -> Just tycon
730 _ -> Nothing
731 con_likes =
732 case idDetails sel_id of
733 RecSelId (RecSelData tc) _ ->
734 map RealDataCon (tyConDataCons tc)
735 RecSelId (RecSelPatSyn ps) _ ->
736 [PatSynCon ps]
737 _ -> panic "tcRecordUpd"
738 -- NB: for a data type family, the tycon is the instance tycon
739
740 relevant_cons = conLikesWithFields con_likes upd_fld_occs
741 -- A constructor is only relevant to this process if
742 -- it contains *all* the fields that are being updated
743 -- Other ones will cause a runtime error if they occur
744
745 -- Step 2
746 -- Check that at least one constructor has all the named fields
747 -- i.e. has an empty set of bad fields returned by badFields
748 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
749
750 -- Take apart a representative constructor
751 ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
752 (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) =
753 conLikeFullSig con1
754 con1_flds = map flLabel $ conLikeFieldLabels con1
755 def_res_ty = conLikeResTy con1
756 con1_res_ty =
757 (maybe def_res_ty mkFamilyTyConApp mtycon) (mkTyVarTys con1_tvs)
758
759 -- Check that we're not dealing with a unidirectional pattern
760 -- synonym
761 ; unless (isJust $ conLikeWrapId_maybe con1)
762 (nonBidirectionalErr (conLikeName con1))
763
764 -- STEP 3 Note [Criteria for update]
765 -- Check that each updated field is polymorphic; that is, its type
766 -- mentions only the universally-quantified variables of the data con
767 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
768 bad_upd_flds = filter bad_fld flds1_w_tys
769 con1_tv_set = mkVarSet con1_tvs
770 bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
771 not (tyVarsOfType ty `subVarSet` con1_tv_set)
772 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
773
774 -- STEP 4 Note [Type of a record update]
775 -- Figure out types for the scrutinee and result
776 -- Both are of form (T a b c), with fresh type variables, but with
777 -- common variables where the scrutinee and result must have the same type
778 -- These are variables that appear in *any* arg of *any* of the
779 -- relevant constructors *except* in the updated fields
780 --
781 ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
782 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
783
784 mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
785 -- Deals with instantiation of kind variables
786 -- c.f. TcMType.tcInstTyVars
787 mk_inst_ty subst (tv, result_inst_ty)
788 | is_fixed_tv tv -- Same as result type
789 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
790 | otherwise -- Fresh type, of correct kind
791 = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv))
792 ; return (extendTvSubst subst tv new_ty, new_ty) }
793
794 ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
795 ; let result_inst_tys = mkTyVarTys con1_tvs'
796
797 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst
798 (con1_tvs `zip` result_inst_tys)
799
800 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
801 scrut_ty = TcType.substTy scrut_subst con1_res_ty
802 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
803
804 ; co_res <- unifyType rec_res_ty res_ty
805
806 -- STEP 5
807 -- Typecheck the thing to be updated, and the bindings
808 ; record_expr' <- tcMonoExpr record_expr scrut_ty
809 ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds
810
811 -- STEP 6: Deal with the stupid theta
812 ; let theta' = substTheta scrut_subst (conLikeStupidTheta con1)
813 ; instStupidTheta RecordUpdOrigin theta'
814
815 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
816 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe =<< mtycon
817 = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys)
818 | otherwise
819 = idHsWrapper
820
821 -- Step 8: Check that the req constraints are satisfied
822 -- For normal data constructors req_theta is empty but we must do
823 -- this check for pattern synonyms.
824 ; let req_theta' = substTheta scrut_subst req_theta
825 ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
826
827 -- Phew!
828 ; return $ mkHsWrapCo co_res $
829 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
830 relevant_cons scrut_inst_tys result_inst_tys req_wrap }
831
832 tcExpr (HsRecFld f) res_ty
833 = tcCheckRecSelId f res_ty
834
835 {-
836 ************************************************************************
837 * *
838 Arithmetic sequences e.g. [a,b..]
839 and their parallel-array counterparts e.g. [: a,b.. :]
840
841 * *
842 ************************************************************************
843 -}
844
845 tcExpr (ArithSeq _ witness seq) res_ty
846 = tcArithSeq witness seq res_ty
847
848 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
849 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
850 ; expr1' <- tcPolyExpr expr1 elt_ty
851 ; expr2' <- tcPolyExpr expr2 elt_ty
852 ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
853 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
854 (idName enumFromToP) elt_ty
855 ; return $ mkHsWrapCo coi
856 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
857
858 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
859 = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
860 ; expr1' <- tcPolyExpr expr1 elt_ty
861 ; expr2' <- tcPolyExpr expr2 elt_ty
862 ; expr3' <- tcPolyExpr expr3 elt_ty
863 ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
864 ; eft <- newMethodFromName (PArrSeqOrigin seq)
865 (idName enumFromThenToP) elt_ty -- !!!FIXME: chak
866 ; return $ mkHsWrapCo coi
867 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
868
869 tcExpr (PArrSeq _ _) _
870 = panic "TcExpr.tcExpr: Infinite parallel array!"
871 -- the parser shouldn't have generated it and the renamer shouldn't have
872 -- let it through
873
874 {-
875 ************************************************************************
876 * *
877 Template Haskell
878 * *
879 ************************************************************************
880 -}
881
882 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
883 tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty
884 tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
885
886 {-
887 ************************************************************************
888 * *
889 Catch-all
890 * *
891 ************************************************************************
892 -}
893
894 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
895 -- Include ArrForm, ArrApp, which shouldn't appear at all
896 -- Also HsTcBracketOut, HsQuasiQuoteE
897
898 {-
899 ************************************************************************
900 * *
901 Arithmetic sequences [a..b] etc
902 * *
903 ************************************************************************
904 -}
905
906 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
907 -> TcM (HsExpr TcId)
908
909 tcArithSeq witness seq@(From expr) res_ty
910 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
911 ; expr' <- tcPolyExpr expr elt_ty
912 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
913 enumFromName elt_ty
914 ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
915
916 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
917 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
918 ; expr1' <- tcPolyExpr expr1 elt_ty
919 ; expr2' <- tcPolyExpr expr2 elt_ty
920 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
921 enumFromThenName elt_ty
922 ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
923
924 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
925 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
926 ; expr1' <- tcPolyExpr expr1 elt_ty
927 ; expr2' <- tcPolyExpr expr2 elt_ty
928 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
929 enumFromToName elt_ty
930 ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
931
932 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
933 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
934 ; expr1' <- tcPolyExpr expr1 elt_ty
935 ; expr2' <- tcPolyExpr expr2 elt_ty
936 ; expr3' <- tcPolyExpr expr3 elt_ty
937 ; eft <- newMethodFromName (ArithSeqOrigin seq)
938 enumFromThenToName elt_ty
939 ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
940
941 -----------------
942 arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
943 -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id))
944 arithSeqEltType Nothing res_ty
945 = do { (coi, elt_ty) <- matchExpectedListTy res_ty
946 ; return (coi, elt_ty, Nothing) }
947 arithSeqEltType (Just fl) res_ty
948 = do { list_ty <- newFlexiTyVarTy liftedTypeKind
949 ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
950 ; (coi, elt_ty) <- matchExpectedListTy list_ty
951 ; return (coi, elt_ty, Just fl') }
952
953 {-
954 ************************************************************************
955 * *
956 Applications
957 * *
958 ************************************************************************
959 -}
960
961 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
962 -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
963
964 tcApp (L _ (HsPar e)) args res_ty
965 = tcApp e args res_ty
966
967 tcApp (L _ (HsApp e1 e2)) args res_ty
968 = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
969
970 tcApp (L loc (HsVar fun)) args res_ty
971 | fun `hasKey` tagToEnumKey
972 , [arg] <- args
973 = tcTagToEnum loc fun arg res_ty
974
975 | fun `hasKey` seqIdKey
976 , [arg1,arg2] <- args
977 = tcSeq loc fun arg1 arg2 res_ty
978
979 -- Look for applications of ambiguous record selectors to arguments
980 -- with type signatures, see Note [Disambiguating record fields]
981 tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty
982 | Just sig_ty <- obviousSig arg
983 = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
984 ; sel_name <- disambiguateSelector lbl sig_tc_ty
985 ; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty }
986
987 tcApp fun args res_ty
988 = do { -- Type-check the function
989 ; (fun1, fun_tau) <- tcInferFun fun
990
991 -- Extract its argument types
992 ; (co_fun, expected_arg_tys, actual_res_ty)
993 <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
994
995 -- Typecheck the result, thereby propagating
996 -- info (if any) from result into the argument types
997 -- Both actual_res_ty and res_ty are deeply skolemised
998 -- Rather like tcWrapResult, but (perhaps for historical reasons)
999 -- we do this before typechecking the arguments
1000 ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $
1001 tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty
1002
1003 -- Typecheck the arguments
1004 ; args1 <- tcArgs fun args expected_arg_tys
1005
1006 -- Assemble the result
1007 ; let fun2 = mkLHsWrapCo co_fun fun1
1008 app = mkLHsWrap wrap_res (foldl mkHsApp fun2 args1)
1009
1010 ; return (unLoc app) }
1011
1012
1013 mk_app_msg :: LHsExpr Name -> SDoc
1014 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
1015 , ptext (sLit "is applied to")]
1016
1017 ----------------
1018 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
1019 -- Infer and instantiate the type of a function
1020 tcInferFun (L loc (HsVar name))
1021 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
1022 -- Don't wrap a context around a plain Id
1023 ; return (L loc fun, ty) }
1024
1025 tcInferFun (L loc (HsRecFld f))
1026 = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
1027 -- Don't wrap a context around a plain Id
1028 ; return (L loc fun, ty) }
1029
1030 tcInferFun fun
1031 = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
1032
1033 -- Zonk the function type carefully, to expose any polymorphism
1034 -- E.g. (( \(x::forall a. a->a). blah ) e)
1035 -- We can see the rank-2 type of the lambda in time to generalise e
1036 ; fun_ty' <- zonkTcType fun_ty
1037
1038 ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
1039 ; return (mkLHsWrap wrap fun, rho) }
1040
1041 ----------------
1042 tcArgs :: LHsExpr Name -- The function (for error messages)
1043 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
1044 -> TcM [LHsExpr TcId] -- Resulting args
1045
1046 tcArgs fun args expected_arg_tys
1047 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
1048
1049 ----------------
1050 tcArg :: LHsExpr Name -- The function (for error messages)
1051 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
1052 -> TcM (LHsExpr TcId) -- Resulting argument
1053 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
1054 (tcPolyExprNC arg ty)
1055
1056 ----------------
1057 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
1058 tcTupArgs args tys
1059 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
1060 where
1061 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
1062 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
1063 ; return (L l (Present expr')) }
1064
1065 ----------------
1066 unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType
1067 -> TcM (TcCoercion, [TcSigmaType], TcRhoType)
1068 -- A wrapper for matchExpectedFunTys
1069 unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty
1070 where
1071 herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
1072
1073 ---------------------------
1074 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
1075 -- Typecheck a syntax operator, checking that it has the specified type
1076 -- The operator is always a variable at this stage (i.e. renamer output)
1077 -- This version assumes res_ty is a monotype
1078 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op
1079 ; tcWrapResult expr rho res_ty }
1080 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
1081
1082 {-
1083 Note [Push result type in]
1084 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1085 Unify with expected result before type-checking the args so that the
1086 info from res_ty percolates to args. This is when we might detect a
1087 too-few args situation. (One can think of cases when the opposite
1088 order would give a better error message.)
1089 experimenting with putting this first.
1090
1091 Here's an example where it actually makes a real difference
1092
1093 class C t a b | t a -> b
1094 instance C Char a Bool
1095
1096 data P t a = forall b. (C t a b) => MkP b
1097 data Q t = MkQ (forall a. P t a)
1098
1099 f1, f2 :: Q Char;
1100 f1 = MkQ (MkP True)
1101 f2 = MkQ (MkP True :: forall a. P Char a)
1102
1103 With the change, f1 will type-check, because the 'Char' info from
1104 the signature is propagated into MkQ's argument. With the check
1105 in the other order, the extra signature in f2 is reqd.
1106
1107
1108 ************************************************************************
1109 * *
1110 tcInferId
1111 * *
1112 ************************************************************************
1113 -}
1114
1115 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
1116 tcCheckId name res_ty
1117 = do { (expr, actual_res_ty) <- tcInferId name
1118 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1119 ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
1120 tcWrapResult expr actual_res_ty res_ty }
1121
1122 tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
1123 tcCheckRecSelId f@(Unambiguous _ _) res_ty
1124 = do { (expr, actual_res_ty) <- tcInferRecSelId f
1125 ; addErrCtxtM (funResCtxt False (HsRecFld f) actual_res_ty res_ty) $
1126 tcWrapResult expr actual_res_ty res_ty }
1127 tcCheckRecSelId (Ambiguous lbl _) res_ty
1128 = case tcSplitFunTy_maybe res_ty of
1129 Nothing -> ambiguousSelector lbl
1130 Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
1131 ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
1132
1133 ------------------------
1134 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
1135 -- Infer type, and deeply instantiate
1136 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
1137
1138 tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
1139 tcInferRecSelId (Unambiguous lbl sel)
1140 = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
1141 tcInferRecSelId (Ambiguous lbl _)
1142 = ambiguousSelector lbl
1143
1144 ------------------------
1145 tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
1146 TcM (HsExpr TcId, TcRhoType)
1147 -- Look up an occurrence of an Id, and instantiate it (deeply)
1148 tcInferIdWithOrig orig lbl id_name
1149 | id_name `hasKey` tagToEnumKey
1150 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1151 -- tcApp catches the case (tagToEnum# arg)
1152
1153 | id_name `hasKey` assertIdKey
1154 = do { dflags <- getDynFlags
1155 ; if gopt Opt_IgnoreAsserts dflags
1156 then tc_infer_id orig lbl id_name
1157 else tc_infer_assert orig }
1158
1159 | otherwise
1160 = tc_infer_id orig lbl id_name
1161
1162 tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType)
1163 -- Deal with an occurrence of 'assert'
1164 -- See Note [Adding the implicit parameter to 'assert']
1165 tc_infer_assert orig
1166 = do { assert_error_id <- tcLookupId assertErrorName
1167 ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
1168 ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho)
1169 }
1170
1171 tc_infer_id :: CtOrigin -> RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
1172 -- Return type is deeply instantiated
1173 tc_infer_id orig lbl id_name
1174 = do { thing <- tcLookup id_name
1175 ; case thing of
1176 ATcId { tct_id = id }
1177 -> do { check_naughty id -- Note [Local record selectors]
1178 ; checkThLocalId id
1179 ; inst_normal_id id }
1180
1181 AGlobal (AnId id)
1182 -> do { check_naughty id
1183 ; inst_normal_id id }
1184 -- A global cannot possibly be ill-staged
1185 -- nor does it need the 'lifting' treatment
1186 -- hence no checkTh stuff here
1187
1188 AGlobal (AConLike cl) -> case cl of
1189 RealDataCon con -> inst_data_con con
1190 PatSynCon ps -> tcPatSynBuilderOcc orig ps
1191
1192 _ -> failWithTc $
1193 ppr thing <+> ptext (sLit "used where a value identifier was expected") }
1194 where
1195 inst_normal_id id
1196 = do { (wrap, rho) <- deeplyInstantiate orig (idType id)
1197 ; return (mkHsWrap wrap (HsVar id), rho) }
1198
1199 inst_data_con con
1200 -- For data constructors,
1201 -- * Must perform the stupid-theta check
1202 -- * No need to deeply instantiate because type has all foralls at top
1203 = do { let wrap_id = dataConWrapId con
1204 (tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
1205 ; (subst, tvs') <- tcInstTyVars tvs
1206 ; let tys' = mkTyVarTys tvs'
1207 theta' = substTheta subst theta
1208 rho' = substTy subst rho
1209 ; wrap <- instCall orig tys' theta'
1210 ; addDataConStupidTheta con tys'
1211 ; return (mkHsWrap wrap (HsVar wrap_id), rho') }
1212
1213 check_naughty id
1214 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
1215 | otherwise = return ()
1216
1217 {-
1218 Note [Adding the implicit parameter to 'assert']
1219 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1220 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
1221 This isn't really the Right Thing because there's no way to "undo"
1222 if you want to see the original source code in the typechecker
1223 output. We'll have fix this in due course, when we care more about
1224 being able to reconstruct the exact original program.
1225
1226 Note [tagToEnum#]
1227 ~~~~~~~~~~~~~~~~~
1228 Nasty check to ensure that tagToEnum# is applied to a type that is an
1229 enumeration TyCon. Unification may refine the type later, but this
1230 check won't see that, alas. It's crude, because it relies on our
1231 knowing *now* that the type is ok, which in turn relies on the
1232 eager-unification part of the type checker pushing enough information
1233 here. In theory the Right Thing to do is to have a new form of
1234 constraint but I definitely cannot face that! And it works ok as-is.
1235
1236 Here's are two cases that should fail
1237 f :: forall a. a
1238 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1239
1240 g :: Int
1241 g = tagToEnum# 0 -- Int is not an enumeration
1242
1243 When data type families are involved it's a bit more complicated.
1244 data family F a
1245 data instance F [Int] = A | B | C
1246 Then we want to generate something like
1247 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1248 Usually that coercion is hidden inside the wrappers for
1249 constructors of F [Int] but here we have to do it explicitly.
1250
1251 It's all grotesquely complicated.
1252 -}
1253
1254 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
1255 -> TcRhoType -> TcM (HsExpr TcId)
1256 -- (seq e1 e2) :: res_ty
1257 -- We need a special typing rule because res_ty can be unboxed
1258 -- See Note [Typing rule for seq]
1259 tcSeq loc fun_name arg1 arg2 res_ty
1260 = do { fun <- tcLookupId fun_name
1261 ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1)
1262 ; arg2' <- tcMonoExpr arg2 res_ty
1263 ; let fun' = L loc (HsWrap ty_args (HsVar fun))
1264 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1265 ; return (HsApp (L loc (HsApp fun' arg1')) arg2') }
1266
1267 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
1268 -- tagToEnum# :: forall a. Int# -> a
1269 -- See Note [tagToEnum#] Urgh!
1270 tcTagToEnum loc fun_name arg res_ty
1271 = do { fun <- tcLookupId fun_name
1272 ; ty' <- zonkTcType res_ty
1273
1274 -- Check that the type is algebraic
1275 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1276 Just (tc, tc_args) = mb_tc_app
1277 ; checkTc (isJust mb_tc_app)
1278 (mk_error ty' doc1)
1279
1280 -- Look through any type family
1281 ; fam_envs <- tcGetFamInstEnvs
1282 ; let (rep_tc, rep_args, coi) = tcLookupDataFamInst fam_envs tc tc_args
1283 -- coi :: tc tc_args ~R rep_tc rep_args
1284
1285 ; checkTc (isEnumerationTyCon rep_tc)
1286 (mk_error ty' doc2)
1287
1288 ; arg' <- tcMonoExpr arg intPrimTy
1289 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1290 rep_ty = mkTyConApp rep_tc rep_args
1291
1292 ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $ HsApp fun' arg') }
1293 -- coi is a Representational coercion
1294 where
1295 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1296 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1297 doc2 = ptext (sLit "Result type must be an enumeration type")
1298
1299 mk_error :: TcType -> SDoc -> SDoc
1300 mk_error ty what
1301 = hang (ptext (sLit "Bad call to tagToEnum#")
1302 <+> ptext (sLit "at type") <+> ppr ty)
1303 2 what
1304
1305 {-
1306 ************************************************************************
1307 * *
1308 Template Haskell checks
1309 * *
1310 ************************************************************************
1311 -}
1312
1313 checkThLocalId :: Id -> TcM ()
1314 checkThLocalId id
1315 = do { mb_local_use <- getStageAndBindLevel (idName id)
1316 ; case mb_local_use of
1317 Just (top_lvl, bind_lvl, use_stage)
1318 | thLevel use_stage > bind_lvl
1319 , isNotTopLevel top_lvl
1320 -> checkCrossStageLifting id use_stage
1321 _ -> return () -- Not a locally-bound thing, or
1322 -- no cross-stage link
1323 }
1324
1325 --------------------------------------
1326 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1327 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1328 -- we must check whether there's a cross-stage lift to do
1329 -- Examples \x -> [|| x ||]
1330 -- [|| map ||]
1331 -- There is no error-checking to do, because the renamer did that
1332 --
1333 -- This is similar to checkCrossStageLifting in RnSplice, but
1334 -- this code is applied to *typed* brackets.
1335
1336 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1337 = -- Nested identifiers, such as 'x' in
1338 -- E.g. \x -> [|| h x ||]
1339 -- We must behave as if the reference to x was
1340 -- h $(lift x)
1341 -- We use 'x' itself as the splice proxy, used by
1342 -- the desugarer to stitch it all back together.
1343 -- If 'x' occurs many times we may get many identical
1344 -- bindings of the same splice proxy, but that doesn't
1345 -- matter, although it's a mite untidy.
1346 do { let id_ty = idType id
1347 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1348 -- If x is polymorphic, its occurrence sites might
1349 -- have different instantiations, so we can't use plain
1350 -- 'x' as the splice proxy name. I don't know how to
1351 -- solve this, and it's probably unimportant, so I'm
1352 -- just going to flag an error for now
1353
1354 ; lift <- if isStringTy id_ty then
1355 do { sid <- tcLookupId THNames.liftStringName
1356 -- See Note [Lifting strings]
1357 ; return (HsVar sid) }
1358 else
1359 setConstraintVar lie_var $
1360 -- Put the 'lift' constraint into the right LIE
1361 newMethodFromName (OccurrenceOf (idName id))
1362 THNames.liftName id_ty
1363
1364 -- Update the pending splices
1365 ; ps <- readMutVar ps_var
1366 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1367 ; writeMutVar ps_var (pending_splice : ps)
1368
1369 ; return () }
1370
1371 checkCrossStageLifting _ _ = return ()
1372
1373 polySpliceErr :: Id -> SDoc
1374 polySpliceErr id
1375 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1376
1377 {-
1378 Note [Lifting strings]
1379 ~~~~~~~~~~~~~~~~~~~~~~
1380 If we see $(... [| s |] ...) where s::String, we don't want to
1381 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1382 So this conditional short-circuits the lifting mechanism to generate
1383 (liftString "xy") in that case. I didn't want to use overlapping instances
1384 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1385 errors in a polymorphic situation.
1386
1387 If this check fails (which isn't impossible) we get another chance; see
1388 Note [Converting strings] in Convert.hs
1389
1390 Local record selectors
1391 ~~~~~~~~~~~~~~~~~~~~~~
1392 Record selectors for TyCons in this module are ordinary local bindings,
1393 which show up as ATcIds rather than AGlobals. So we need to check for
1394 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1395
1396
1397 ************************************************************************
1398 * *
1399 \subsection{Record bindings}
1400 * *
1401 ************************************************************************
1402 -}
1403
1404 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
1405 -- These tyvars must not change across the updates
1406 getFixedTyVars upd_fld_occs univ_tvs cons
1407 = mkVarSet [tv1 | con <- cons
1408 , let (u_tvs, _, eqspec, prov_theta
1409 , req_theta, arg_tys, _)
1410 = conLikeFullSig con
1411 theta = eqSpecPreds eqspec
1412 ++ prov_theta
1413 ++ req_theta
1414 flds = conLikeFieldLabels con
1415 fixed_tvs = exactTyVarsOfTypes fixed_tys
1416 -- fixed_tys: See Note [Type of a record update]
1417 `unionVarSet` tyVarsOfTypes theta
1418 -- Universally-quantified tyvars that
1419 -- appear in any of the *implicit*
1420 -- arguments to the constructor are fixed
1421 -- See Note [Implict type sharing]
1422
1423 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
1424 , not (flLabel fl `elem` upd_fld_occs)]
1425 , (tv1,tv) <- univ_tvs `zip` u_tvs
1426 , tv `elemVarSet` fixed_tvs ]
1427
1428 {-
1429 Note [Disambiguating record fields]
1430 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1431
1432 When the -XDuplicateRecordFields extension is used, and the renamer
1433 encounters a record selector or update that it cannot immediately
1434 disambiguate (because it involves fields that belong to multiple
1435 datatypes), it will defer resolution of the ambiguity to the
1436 typechecker. In this case, the `Ambiguous` constructor of
1437 `AmbiguousFieldOcc` is used.
1438
1439 Consider the following definitions:
1440
1441 data S = MkS { foo :: Int }
1442 data T = MkT { foo :: Int, bar :: Int }
1443 data U = MkU { bar :: Int, baz :: Int }
1444
1445 When the renamer sees `foo` as a selector or an update, it will not
1446 know which parent datatype is in use.
1447
1448 For selectors, there are two possible ways to disambiguate:
1449
1450 1. Check if the pushed-in type is a function whose domain is a
1451 datatype, for example:
1452
1453 f s = (foo :: S -> Int) s
1454
1455 g :: T -> Int
1456 g = foo
1457
1458 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
1459
1460 2. Check if the selector is applied to an argument that has a type
1461 signature, for example:
1462
1463 h = foo (s :: S)
1464
1465 This is checked by `tcApp`.
1466
1467
1468 Updates are slightly more complex. The `disambiguateRecordBinds`
1469 function tries to determine the parent datatype in three ways:
1470
1471 1. Check for types that have all the fields being updated. For example:
1472
1473 f x = x { foo = 3, bar = 2 }
1474
1475 Here `f` must be updating `T` because neither `S` nor `U` have
1476 both fields. This may also discover that no possible type exists.
1477 For example the following will be rejected:
1478
1479 f' x = x { foo = 3, baz = 3 }
1480
1481 2. Use the type being pushed in, if it is already a TyConApp. The
1482 following are valid updates to `T`:
1483
1484 g :: T -> T
1485 g x = x { foo = 3 }
1486
1487 g' x = x { foo = 3 } :: T
1488
1489 3. Use the type signature of the record expression, if it exists and
1490 is a TyConApp. Thus this is valid update to `T`:
1491
1492 h x = (x :: T) { foo = 3 }
1493
1494
1495 Note that we do not look up the types of variables being updated, and
1496 no constraint-solving is performed, so for example the following will
1497 be rejected as ambiguous:
1498
1499 let bad (s :: S) = foo s
1500
1501 let r :: T
1502 r = blah
1503 in r { foo = 3 }
1504
1505 \r. (r { foo = 3 }, r :: T )
1506
1507 We could add further tests, of a more heuristic nature. For example,
1508 rather than looking for an explicit signature, we could try to infer
1509 the type of the argument to a selector or the record expression being
1510 updated, in case we are lucky enough to get a TyConApp straight
1511 away. However, it might be hard for programmers to predict whether a
1512 particular update is sufficiently obvious for the signature to be
1513 omitted. Moreover, this might change the behaviour of typechecker in
1514 non-obvious ways.
1515
1516 See also Note [HsRecField and HsRecUpdField] in HsPat.
1517 -}
1518
1519 -- Given a RdrName that refers to multiple record fields, and the type
1520 -- of its argument, try to determine the name of the selector that is
1521 -- meant.
1522 disambiguateSelector :: RdrName -> Type -> RnM Name
1523 disambiguateSelector rdr parent_type
1524 = do { fam_inst_envs <- tcGetFamInstEnvs
1525 ; case tyConOf fam_inst_envs parent_type of
1526 Nothing -> ambiguousSelector rdr
1527 Just p ->
1528 do { xs <- lookupParents rdr
1529 ; let parent = RecSelData p
1530 ; case lookup parent xs of
1531 Just gre -> do { addUsedGRE True gre
1532 ; return (gre_name gre) }
1533 Nothing -> failWithTc (fieldNotInType parent rdr) } }
1534
1535 -- This field name really is ambiguous, so add a suitable "ambiguous
1536 -- occurrence" error, then give up.
1537 ambiguousSelector :: RdrName -> RnM a
1538 ambiguousSelector rdr
1539 = do { env <- getGlobalRdrEnv
1540 ; let gres = lookupGRE_RdrName rdr env
1541 ; setErrCtxt [] $ addNameClashErrRn rdr gres
1542 ; failM }
1543
1544 -- Disambiguate the fields in a record update.
1545 -- See Note [Disambiguating record fields]
1546 disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type
1547 -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
1548 disambiguateRecordBinds record_expr rbnds res_ty
1549 -- Are all the fields unambiguous?
1550 = case mapM isUnambiguous rbnds of
1551 -- If so, just skip to looking up the Ids
1552 -- Always the case if DuplicateRecordFields is off
1553 Just rbnds' -> mapM lookupSelector rbnds'
1554 Nothing -> -- If not, try to identify a single parent
1555 do { fam_inst_envs <- tcGetFamInstEnvs
1556 -- Look up the possible parents for each field
1557 ; rbnds_with_parents <- getUpdFieldsParents
1558 ; let possible_parents = map (map fst . snd) rbnds_with_parents
1559 -- Identify a single parent
1560 ; p <- identifyParent fam_inst_envs possible_parents
1561 -- Pick the right selector with that parent for each field
1562 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
1563 where
1564 -- Extract the selector name of a field update if it is unambiguous
1565 isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
1566 isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
1567 Unambiguous _ sel_name -> Just (x, sel_name)
1568 Ambiguous{} -> Nothing
1569
1570 -- Look up the possible parents and selector GREs for each field
1571 getUpdFieldsParents :: TcM [(LHsRecUpdField Name
1572 , [(RecSelParent, GlobalRdrElt)])]
1573 getUpdFieldsParents
1574 = fmap (zip rbnds) $ mapM
1575 (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
1576 rbnds
1577
1578 -- Given a the lists of possible parents for each field,
1579 -- identify a single parent
1580 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
1581 identifyParent fam_inst_envs possible_parents
1582 = case foldr1 intersect possible_parents of
1583 -- No parents for all fields: record update is ill-typed
1584 [] -> failWithTc (noPossibleParents rbnds)
1585 -- Exactly one datatype with all the fields: use that
1586 [p] -> return p
1587 -- Multiple possible parents: try harder to disambiguate
1588 -- Can we get a parent TyCon from the pushed-in type?
1589 _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
1590 -- Does the expression being updated have a type signature?
1591 -- If so, try to extract a parent TyCon from it
1592 | Just sig_ty <- obviousSig (unLoc record_expr)
1593 -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
1594 ; case tyConOf fam_inst_envs sig_tc_ty of
1595 Just p -> return (RecSelData p)
1596 Nothing -> failWithTc badOverloadedUpdate }
1597 -- Nothing else we can try...
1598 _ -> failWithTc badOverloadedUpdate
1599
1600 -- Make a field unambiguous by choosing the given parent.
1601 -- Emits an error if the field cannot have that parent,
1602 -- e.g. if the user writes
1603 -- r { x = e } :: T
1604 -- where T does not have field x.
1605 pickParent :: RecSelParent
1606 -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
1607 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
1608 pickParent p (upd, xs)
1609 = case lookup p xs of
1610 -- Phew! The parent is valid for this field.
1611 -- Previously ambiguous fields must be marked as
1612 -- used now that we know which one is meant, but
1613 -- unambiguous ones shouldn't be recorded again
1614 -- (giving duplicate deprecation warnings).
1615 Just gre -> do { unless (null (tail xs)) $ do
1616 let L loc _ = hsRecFieldLbl (unLoc upd)
1617 setSrcSpan loc $ addUsedGRE True gre
1618 ; lookupSelector (upd, gre_name gre) }
1619 -- The field doesn't belong to this parent, so report
1620 -- an error but keep going through all the fields
1621 Nothing -> do { addErrTc (fieldNotInType p
1622 (unLoc (hsRecUpdFieldRdr (unLoc upd))))
1623 ; lookupSelector (upd, gre_name (snd (head xs))) }
1624
1625 -- Given a (field update, selector name) pair, look up the
1626 -- selector to give a field update with an unambiguous Id
1627 lookupSelector :: (LHsRecUpdField Name, Name)
1628 -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
1629 lookupSelector (L l upd, n)
1630 = do { i <- tcLookupId n
1631 ; let L loc af = hsRecFieldLbl upd
1632 lbl = rdrNameAmbiguousFieldOcc af
1633 ; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous lbl i) } }
1634
1635
1636 -- Extract the outermost TyCon of a type, if there is one; for
1637 -- data families this is the representation tycon (because that's
1638 -- where the fields live).
1639 tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
1640 tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
1641 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
1642 Nothing -> Nothing
1643
1644 -- For an ambiguous record field, find all the candidate record
1645 -- selectors (as GlobalRdrElts) and their parents.
1646 lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
1647 lookupParents rdr
1648 = do { env <- getGlobalRdrEnv
1649 ; let gres = lookupGRE_RdrName rdr env
1650 ; mapM lookupParent gres }
1651 where
1652 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
1653 lookupParent gre = do { id <- tcLookupId (gre_name gre)
1654 ; if isRecordSelector id
1655 then return (recordSelectorTyCon id, gre)
1656 else failWithTc (notSelector (gre_name gre)) }
1657
1658 -- A type signature on the argument of an ambiguous record selector or
1659 -- the record expression in an update must be "obvious", i.e. the
1660 -- outermost constructor ignoring parentheses.
1661 obviousSig :: HsExpr Name -> Maybe (LHsType Name)
1662 obviousSig (ExprWithTySig _ ty _) = Just ty
1663 obviousSig (HsPar p) = obviousSig (unLoc p)
1664 obviousSig _ = Nothing
1665
1666
1667 {-
1668 Game plan for record bindings
1669 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1670 1. Find the TyCon for the bindings, from the first field label.
1671
1672 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1673
1674 For each binding field = value
1675
1676 3. Instantiate the field type (from the field label) using the type
1677 envt from step 2.
1678
1679 4 Type check the value using tcArg, passing the field type as
1680 the expected argument type.
1681
1682 This extends OK when the field types are universally quantified.
1683 -}
1684
1685 tcRecordBinds
1686 :: ConLike
1687 -> [TcType] -- Expected type for each field
1688 -> HsRecordBinds Name
1689 -> TcM (HsRecordBinds TcId)
1690
1691 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
1692 = do { mb_binds <- mapM do_bind rbinds
1693 ; return (HsRecFields (catMaybes mb_binds) dd) }
1694 where
1695 fields = map flLabel $ conLikeFieldLabels con_like
1696 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
1697
1698 do_bind :: LHsRecField Name (LHsExpr Name)
1699 -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
1700 do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
1701 , hsRecFieldArg = rhs }))
1702
1703 = do { mb <- tcRecordField con_like flds_w_tys f rhs
1704 ; case mb of
1705 Nothing -> return Nothing
1706 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
1707 , hsRecFieldArg = rhs' }))) }
1708
1709 tcRecordUpd
1710 :: ConLike
1711 -> [TcType] -- Expected type for each field
1712 -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
1713 -> TcM [LHsRecUpdField TcId]
1714
1715 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
1716 where
1717 flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
1718
1719 do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
1720 do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
1721 , hsRecFieldArg = rhs }))
1722 = do { let lbl = rdrNameAmbiguousFieldOcc af
1723 sel_id = selectorAmbiguousFieldOcc af
1724 f = L loc (FieldOcc lbl (idName sel_id))
1725 ; mb <- tcRecordField con_like flds_w_tys f rhs
1726 ; case mb of
1727 Nothing -> return Nothing
1728 Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = L loc (Unambiguous lbl (selectorFieldOcc (unLoc f')))
1729 , hsRecFieldArg = rhs' }))) }
1730
1731 tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
1732 -> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
1733 tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
1734 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1735 = addErrCtxt (fieldCtxt field_lbl) $
1736 do { rhs' <- tcPolyExprNC rhs field_ty
1737 ; let field_id = mkUserLocal (nameOccName sel_name)
1738 (nameUnique sel_name)
1739 field_ty loc
1740 -- Yuk: the field_id has the *unique* of the selector Id
1741 -- (so we can find it easily)
1742 -- but is a LocalId with the appropriate type of the RHS
1743 -- (so the desugarer knows the type of local binder to make)
1744 ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
1745 | otherwise
1746 = do { addErrTc (badFieldCon con_like field_lbl)
1747 ; return Nothing }
1748 where
1749 field_lbl = occNameFS $ rdrNameOcc lbl
1750
1751
1752 checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
1753 checkMissingFields con_like rbinds
1754 | null field_labels -- Not declared as a record;
1755 -- But C{} is still valid if no strict fields
1756 = if any isBanged field_strs then
1757 -- Illegal if any arg is strict
1758 addErrTc (missingStrictFields con_like [])
1759 else
1760 return ()
1761
1762 | otherwise = do -- A record
1763 unless (null missing_s_fields)
1764 (addErrTc (missingStrictFields con_like missing_s_fields))
1765
1766 warn <- woptM Opt_WarnMissingFields
1767 unless (not (warn && notNull missing_ns_fields))
1768 (warnTc True (missingFields con_like missing_ns_fields))
1769
1770 where
1771 missing_s_fields
1772 = [ flLabel fl | (fl, str) <- field_info,
1773 isBanged str,
1774 not (fl `elemField` field_names_used)
1775 ]
1776 missing_ns_fields
1777 = [ flLabel fl | (fl, str) <- field_info,
1778 not (isBanged str),
1779 not (fl `elemField` field_names_used)
1780 ]
1781
1782 field_names_used = hsRecFields rbinds
1783 field_labels = conLikeFieldLabels con_like
1784
1785 field_info = zipEqual "missingFields"
1786 field_labels
1787 field_strs
1788
1789 field_strs = conLikeImplBangs con_like
1790
1791 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
1792
1793 {-
1794 ************************************************************************
1795 * *
1796 \subsection{Errors and contexts}
1797 * *
1798 ************************************************************************
1799
1800 Boring and alphabetical:
1801 -}
1802
1803 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1804 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1805
1806 exprCtxt :: LHsExpr Name -> SDoc
1807 exprCtxt expr
1808 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1809
1810 fieldCtxt :: FieldLabelString -> SDoc
1811 fieldCtxt field_name
1812 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1813
1814 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1815 funAppCtxt fun arg arg_no
1816 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1817 quotes (ppr fun) <> text ", namely"])
1818 2 (quotes (ppr arg))
1819
1820 funResCtxt :: Bool -- There is at least one argument
1821 -> HsExpr Name -> TcType -> TcType
1822 -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1823 -- When we have a mis-match in the return type of a function
1824 -- try to give a helpful message about too many/few arguments
1825 --
1826 -- Used for naked variables too; but with has_args = False
1827 funResCtxt has_args fun fun_res_ty env_ty tidy_env
1828 = do { fun_res' <- zonkTcType fun_res_ty
1829 ; env' <- zonkTcType env_ty
1830 ; let (args_fun, res_fun) = tcSplitFunTys fun_res'
1831 (args_env, res_env) = tcSplitFunTys env'
1832 n_fun = length args_fun
1833 n_env = length args_env
1834 info | n_fun == n_env = Outputable.empty
1835 | n_fun > n_env
1836 , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1837 <+> ptext (sLit "is applied to too few arguments")
1838 | has_args
1839 , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun)
1840 <+> ptext (sLit "is applied to too many arguments")
1841 | otherwise = Outputable.empty -- Never suggest that a naked variable is
1842 -- applied to too many args!
1843 ; return (tidy_env, info) }
1844 where
1845 not_fun ty -- ty is definitely not an arrow type,
1846 -- and cannot conceivably become one
1847 = case tcSplitTyConApp_maybe ty of
1848 Just (tc, _) -> isAlgTyCon tc
1849 Nothing -> False
1850
1851 badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
1852 badFieldTypes prs
1853 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1854 <> plural prs <> colon)
1855 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1856
1857 badFieldsUpd
1858 :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon
1859 -> [ConLike] -- Data cons of the type which the first field name belongs to
1860 -> SDoc
1861 badFieldsUpd rbinds data_cons
1862 = hang (ptext (sLit "No constructor has all these fields:"))
1863 2 (pprQuotedList conflictingFields)
1864 -- See Note [Finding the conflicting fields]
1865 where
1866 -- A (preferably small) set of fields such that no constructor contains
1867 -- all of them. See Note [Finding the conflicting fields]
1868 conflictingFields = case nonMembers of
1869 -- nonMember belongs to a different type.
1870 (nonMember, _) : _ -> [aMember, nonMember]
1871 [] -> let
1872 -- All of rbinds belong to one type. In this case, repeatedly add
1873 -- a field to the set until no constructor contains the set.
1874
1875 -- Each field, together with a list indicating which constructors
1876 -- have all the fields so far.
1877 growingSets :: [(FieldLabelString, [Bool])]
1878 growingSets = scanl1 combine membership
1879 combine (_, setMem) (field, fldMem)
1880 = (field, zipWith (&&) setMem fldMem)
1881 in
1882 -- Fields that don't change the membership status of the set
1883 -- are redundant and can be dropped.
1884 map (fst . head) $ groupBy ((==) `on` snd) growingSets
1885
1886 aMember = ASSERT( not (null members) ) fst (head members)
1887 (members, nonMembers) = partition (or . snd) membership
1888
1889 -- For each field, which constructors contain the field?
1890 membership :: [(FieldLabelString, [Bool])]
1891 membership = sortMembership $
1892 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
1893 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
1894
1895 fieldLabelSets :: [Set.Set FieldLabelString]
1896 fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
1897
1898 -- Sort in order of increasing number of True, so that a smaller
1899 -- conflicting set can be found.
1900 sortMembership =
1901 map snd .
1902 sortBy (compare `on` fst) .
1903 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
1904
1905 countTrue = length . filter id
1906
1907 {-
1908 Note [Finding the conflicting fields]
1909 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1910 Suppose we have
1911 data A = A {a0, a1 :: Int}
1912 | B {b0, b1 :: Int}
1913 and we see a record update
1914 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
1915 Then we'd like to find the smallest subset of fields that no
1916 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
1917 We don't really want to report that no constructor has all of
1918 {a0,a1,b0,b1}, because when there are hundreds of fields it's
1919 hard to see what was really wrong.
1920
1921 We may need more than two fields, though; eg
1922 data T = A { x,y :: Int, v::Int }
1923 | B { y,z :: Int, v::Int }
1924 | C { z,x :: Int, v::Int }
1925 with update
1926 r { x=e1, y=e2, z=e3 }, we
1927
1928 Finding the smallest subset is hard, so the code here makes
1929 a decent stab, no more. See Trac #7989.
1930 -}
1931
1932 naughtyRecordSel :: RdrName -> SDoc
1933 naughtyRecordSel sel_id
1934 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1935 ptext (sLit "as a function due to escaped type variables") $$
1936 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1937
1938 notSelector :: Name -> SDoc
1939 notSelector field
1940 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1941
1942 mixedSelectors :: [Id] -> [Id] -> SDoc
1943 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
1944 = ptext
1945 (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
1946 ptext (sLit "Record selectors defined by")
1947 <+> quotes (ppr (tyConName rep_dc))
1948 <> text ":"
1949 <+> pprWithCommas ppr data_sels $$
1950 ptext (sLit "Pattern synonym selectors defined by")
1951 <+> quotes (ppr (patSynName rep_ps))
1952 <> text ":"
1953 <+> pprWithCommas ppr pat_syn_sels
1954 where
1955 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
1956 RecSelData rep_dc = recordSelectorTyCon dc_rep_id
1957 mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
1958
1959
1960 missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
1961 missingStrictFields con fields
1962 = header <> rest
1963 where
1964 rest | null fields = Outputable.empty -- Happens for non-record constructors
1965 -- with strict fields
1966 | otherwise = colon <+> pprWithCommas ppr fields
1967
1968 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1969 ptext (sLit "does not have the required strict field(s)")
1970
1971 missingFields :: ConLike -> [FieldLabelString] -> SDoc
1972 missingFields con fields
1973 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1974 <+> pprWithCommas ppr fields
1975
1976 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
1977
1978 noPossibleParents :: [LHsRecUpdField Name] -> SDoc
1979 noPossibleParents rbinds
1980 = hang (ptext (sLit "No type has all these fields:"))
1981 2 (pprQuotedList fields)
1982 where
1983 fields = map (hsRecFieldLbl . unLoc) rbinds
1984
1985 badOverloadedUpdate :: SDoc
1986 badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
1987
1988 fieldNotInType :: RecSelParent -> RdrName -> SDoc
1989 fieldNotInType p rdr
1990 = unknownSubordinateErr (ptext (sLit "field of type") <+> quotes (ppr p)) rdr