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