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