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