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