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