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