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