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