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