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