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