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