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