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